mirror of
https://github.com/haskoin/haskoin-core.git
synced 2024-09-11 10:05:34 +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
|
# Changelog
|
||||||
|
|
||||||
All notable changes to this project will be documented in this file.
|
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/)
|
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).
|
and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html).
|
||||||
|
|
||||||
## 0.21.2
|
## [1.0.0]
|
||||||
|
|
||||||
### Changed
|
### 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.
|
- Serialisation test now works for both strict and lazy bytestrings.
|
||||||
|
|
||||||
## 0.21.1
|
## [0.21.1] - 2021-12-13
|
||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
|
|
||||||
- Make Base58 faster.
|
- Make Base58 faster.
|
||||||
|
|
||||||
## 0.21.0
|
## [0.21.0] - 2022-11-23
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- BCH Testnet4 support.
|
- BCH Testnet4 support.
|
||||||
|
|
||||||
### Changed
|
### 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
|
### Fixed
|
||||||
|
|
||||||
- Makes `finalScriptWitness` field encoding conform to bitcoin core.
|
- Makes `finalScriptWitness` field encoding conform to bitcoin core.
|
||||||
- Fixes bug in `finalizeTransaction`
|
- Fixes bug in `finalizeTransaction`
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- Signing support for PSBTs
|
- Signing support for PSBTs
|
||||||
- Helper function for merging PSBTs
|
- Helper function for merging PSBTs
|
||||||
- More PSBT tests
|
- More PSBT tests
|
||||||
- Partial support for taproot
|
- Partial support for taproot
|
||||||
|
|
||||||
## 0.20.5
|
## [0.20.5] - 2021-09-13
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- Support Bech32m address format for Taproot.
|
- Support Bech32m address format for Taproot.
|
||||||
|
|
||||||
## 0.20.4
|
## [0.20.4] - 2021-06-08
|
||||||
|
|
||||||
### Fixed
|
### Fixed
|
||||||
|
|
||||||
- Add missing case for witness version.
|
- Add missing case for witness version.
|
||||||
|
|
||||||
## 0.20.3
|
## [0.20.3] - 2021-05-17
|
||||||
|
|
||||||
### Fixed
|
### Fixed
|
||||||
|
|
||||||
- Allow unknown inv types.
|
- Allow unknown inv types.
|
||||||
|
|
||||||
## 0.20.2
|
## [0.20.2] - 2021-05-17
|
||||||
|
|
||||||
### Fixed
|
### Fixed
|
||||||
|
|
||||||
- Allow unknown messages of zero length.
|
- Allow unknown messages of zero length.
|
||||||
|
|
||||||
## 0.20.1
|
## [0.20.1] - 2021-05-14
|
||||||
|
|
||||||
### Fixed
|
### Fixed
|
||||||
|
|
||||||
- Correct case where binary search returned the wrong element.
|
- Correct case where binary search returned the wrong element.
|
||||||
|
|
||||||
## 0.20.0
|
## [0.20.0] - 2021-02-22
|
||||||
|
|
||||||
### Chaged
|
### Chaged
|
||||||
|
|
||||||
- Use bytes instead of binary or cereal.
|
- Use bytes instead of binary or cereal.
|
||||||
|
|
||||||
## 0.19.0
|
## [0.19.0] - 2021-01-25
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- Hashable instances for extended keys.
|
- Hashable instances for extended keys.
|
||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
|
|
||||||
- Mnemonic passphrases now `Text` instead of `ByteString`.
|
- Mnemonic passphrases now `Text` instead of `ByteString`.
|
||||||
|
|
||||||
### Fixed
|
### Fixed
|
||||||
|
|
||||||
- Tests now pass for witness addresses.
|
- Tests now pass for witness addresses.
|
||||||
|
|
||||||
## 0.18.0
|
## [0.18.0] - 2020-12-10
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- Support SegWit addresses with version other than 0.
|
- Support SegWit addresses with version other than 0.
|
||||||
|
|
||||||
## 0.17.6
|
## [0.17.6] - 2020-12-07
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- Serialize instances for `XPubKey` and `XPrvKey`.
|
- Serialize instances for `XPubKey` and `XPrvKey`.
|
||||||
|
|
||||||
## 0.17.5
|
## [0.17.5] - 2020-12-03
|
||||||
|
|
||||||
### Fixed
|
### Fixed
|
||||||
|
|
||||||
- Handle special case in block header binary search function.
|
- Handle special case in block header binary search function.
|
||||||
|
|
||||||
## 0.17.4
|
## [0.17.4] - 2020-12-03
|
||||||
|
|
||||||
### Fixed
|
### Fixed
|
||||||
|
|
||||||
- Bounds check too restrictive in block header binary search function.
|
- Bounds check too restrictive in block header binary search function.
|
||||||
|
|
||||||
## 0.17.3
|
## [0.17.3] - 2020-11-17
|
||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
|
|
||||||
- Reduce minimum version of text package dependency.
|
- Reduce minimum version of text package dependency.
|
||||||
|
|
||||||
## 0.17.2
|
## [0.17.2] - 2020-11-17
|
||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
|
|
||||||
- Update lists of seeds for all networks.
|
- Update lists of seeds for all networks.
|
||||||
|
|
||||||
## 0.17.1
|
## [0.17.1] - 2020-11-02
|
||||||
### Changed
|
|
||||||
- Use the C-preprocessor to handle versions of `base16-bytestring` including 1.0
|
### Changed
|
||||||
(with a breaking API change)
|
|
||||||
|
- Use the C-preprocessor to handle versions of `base16-bytestring`
|
||||||
|
|
||||||
|
## [0.17.0] - 2020-10-21
|
||||||
|
|
||||||
## 0.17.0
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- Support for Bitcoin Cash November 2020 hard fork.
|
- Support for Bitcoin Cash November 2020 hard fork.
|
||||||
- Functions to find block headers matching arbitrary sorted attributes.
|
- Functions to find block headers matching arbitrary sorted attributes.
|
||||||
|
|
||||||
### Removed
|
### Removed
|
||||||
|
|
||||||
- GenesisNode constructor for BlockNode type.
|
- GenesisNode constructor for BlockNode type.
|
||||||
|
|
||||||
## 0.15.0
|
## [0.15.0] - 2020-07-23
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- Add more test vectors
|
- Add more test vectors
|
||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
|
|
||||||
- stringToAddr renamed to textToAddr
|
- stringToAddr renamed to textToAddr
|
||||||
- Move ScriptOutput to Standard.hs
|
- Move ScriptOutput to Standard.hs
|
||||||
- Move WIF encoding/decoding to Keys.hs
|
- Move WIF encoding/decoding to Keys.hs
|
||||||
- (breaking) rename `OP_NOP2` and `OP_NOP3` to `OP_CHECKLOCKTIMEVERIFY` and
|
- (breaking) rename `OP_NOP2` and `OP_NOP3` to `OP_CHECKLOCKTIMEVERIFY` and `OP_CHECKSEQUENCEVERIFY` resp.
|
||||||
`OP_CHECKSEQUENCEVERIFY` resp.
|
|
||||||
- Update to latest secp256k1 bindings.
|
- Update to latest secp256k1 bindings.
|
||||||
|
|
||||||
## 0.14.1
|
## [0.14.1] - 2020-06-14
|
||||||
|
|
||||||
### Fixed
|
### Fixed
|
||||||
|
|
||||||
- Correct some Bitcoin Cash Testnet3 seeds.
|
- Correct some Bitcoin Cash Testnet3 seeds.
|
||||||
- Add helpers for writing Data.Serialize and Data.Aeson identity tests
|
- Add helpers for writing Data.Serialize and Data.Aeson identity tests
|
||||||
|
|
||||||
## 0.14.0
|
## [0.14.0] - 2020-06-14
|
||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
|
|
||||||
- Expose all modules for tests.
|
- Expose all modules for tests.
|
||||||
- Tests depend on library instead of having access to its source code.
|
- Tests depend on library instead of having access to its source code.
|
||||||
- Use MIT license.
|
- Use MIT license.
|
||||||
- Update seeds.
|
- Update seeds.
|
||||||
- Bump secp256k1-haskell dependency.
|
- Bump secp256k1-haskell dependency.
|
||||||
|
|
||||||
## 0.13.6
|
## [0.13.6] - 2020-06-05
|
||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
|
|
||||||
- Expose the Arbitrary test instances under Haskoin.Util.Arbitrary
|
- Expose the Arbitrary test instances under Haskoin.Util.Arbitrary
|
||||||
|
|
||||||
## 0.13.5
|
## [0.13.5] - 2020-05-16
|
||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
|
|
||||||
- Provide meaningful JSON instances for most types.
|
- Provide meaningful JSON instances for most types.
|
||||||
|
|
||||||
## 0.13.4
|
## [0.13.4] - 2020-05-14
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- Support for Bitcoin Cash May 2020 hard fork.
|
- Support for Bitcoin Cash May 2020 hard fork.
|
||||||
|
|
||||||
## 0.13.3
|
## [0.13.3] - 2020-05-08
|
||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
|
|
||||||
- Improve code and documentation organisation.
|
- Improve code and documentation organisation.
|
||||||
|
|
||||||
## 0.13.2
|
## [0.13.2] - 2020-05-08
|
||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
|
|
||||||
- Move all packages from Network.Haskoin namespace to Haskoin namespace.
|
- Move all packages from Network.Haskoin namespace to Haskoin namespace.
|
||||||
- Expose all top-level modules directly.
|
- Expose all top-level modules directly.
|
||||||
|
|
||||||
## 0.13.1
|
## [0.13.1] - 2020-05-06
|
||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
|
|
||||||
- Faster JSON serialization.
|
- Faster JSON serialization.
|
||||||
|
|
||||||
## 0.13.0
|
## [0.13.0] - 2020-05-06
|
||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
|
|
||||||
- Consolidate all modules in Haskoin module.
|
- Consolidate all modules in Haskoin module.
|
||||||
|
|
||||||
### Removed
|
### Removed
|
||||||
|
|
||||||
- Deprecate Network.Haskoin namespace.
|
- Deprecate Network.Haskoin namespace.
|
||||||
- Hide QuickCheck generators in test suite.
|
- Hide QuickCheck generators in test suite.
|
||||||
|
|
||||||
## 0.12.0
|
## [0.12.0] - 2020-04-10
|
||||||
### Added
|
|
||||||
- Support for signing segwit transactions.
|
|
||||||
|
|
||||||
## 0.11.0
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
|
- Support for signing segwit transactions.
|
||||||
- High-level representation of segwit v0 data and auxilliary functions.
|
- High-level representation of segwit v0 data and auxilliary functions.
|
||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
|
|
||||||
- Adds handling of segwit signing parameters to transaction signing code.
|
- Adds handling of segwit signing parameters to transaction signing code.
|
||||||
|
|
||||||
## 0.10.1
|
## [0.10.1] - 2020-02-08
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- Lower bound versions for some dependencies.
|
- Lower bound versions for some dependencies.
|
||||||
|
|
||||||
## 0.10.0
|
## [0.10.0] - 2020-01-15
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- DeepSeq instances for all data types.
|
- DeepSeq instances for all data types.
|
||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
|
|
||||||
- There is no `SockAddr` inside `NetworkAddress` anymore.
|
- There is no `SockAddr` inside `NetworkAddress` anymore.
|
||||||
|
|
||||||
## 0.9.8
|
## [0.9.8] - 2020-01-01
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- Ord instance for `DerivPathI`
|
- Ord instance for `DerivPathI`
|
||||||
|
|
||||||
## 0.9.7
|
## [0.9.7] - 2019-12-04
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- JSON encoding/decoding for blocks.
|
- JSON encoding/decoding for blocks.
|
||||||
|
|
||||||
### Fixed
|
### Fixed
|
||||||
|
|
||||||
- Fix lowercase HRP test for Bech32.
|
- Fix lowercase HRP test for Bech32.
|
||||||
|
|
||||||
## 0.9.6
|
## [0.9.6] - 2019-10-29
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- `bloomRelevantUpdate` implementation for Bloom filters (thanks to @IlyasRidhuan).
|
- `bloomRelevantUpdate` implementation for Bloom filters (thanks to @IlyasRidhuan).
|
||||||
|
|
||||||
### Fixed
|
### Fixed
|
||||||
|
|
||||||
- Fix for Bech32 encoding (thanks to @pavel-main).
|
- Fix for Bech32 encoding (thanks to @pavel-main).
|
||||||
|
|
||||||
## 0.9.5
|
## [0.9.5] - 2019-10-23
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- Expose functions added in 0.9.4.
|
- Expose functions added in 0.9.4.
|
||||||
|
|
||||||
## 0.9.4
|
## [0.9.4] - 2019-10-23
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- Support for (P2SH-)P2WPKH addresses derived from extended keys.
|
- Support for (P2SH-)P2WPKH addresses derived from extended keys.
|
||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
|
|
||||||
- Change names of backwards-compatible P2SH-P2WPKH functions from 0.9.3.
|
- Change names of backwards-compatible P2SH-P2WPKH functions from 0.9.3.
|
||||||
|
|
||||||
## 0.9.3
|
## [0.9.3] - 2019-10-22
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- Some support for P2WPKH-over-P2SH addresses.
|
- Some support for P2WPKH-over-P2SH addresses.
|
||||||
|
|
||||||
## 0.9.2
|
## [0.9.2] - 2019-10-09
|
||||||
|
|
||||||
### Removed
|
### Removed
|
||||||
|
|
||||||
- Disable unnecessary `-O2` optimisation added in previous version.
|
- Disable unnecessary `-O2` optimisation added in previous version.
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- Allow decoding unknown P2P messages.
|
- Allow decoding unknown P2P messages.
|
||||||
|
|
||||||
## 0.9.1
|
## [0.9.1] - 2019-10-02
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- Add a function to produce a structured signature over a transaction.
|
- Add a function to produce a structured signature over a transaction.
|
||||||
- Enable `-O2` optimisations.
|
- Enable `-O2` optimisations.
|
||||||
|
|
||||||
## 0.9.0
|
## [0.9.0] - 2019-04-12
|
||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
|
|
||||||
- Address conversion to string now defined for all inputs.
|
- Address conversion to string now defined for all inputs.
|
||||||
|
|
||||||
## 0.8.4
|
## [0.8.4] - 2018-12-05
|
||||||
### 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.3
|
|
||||||
### Added
|
### 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.
|
- Add reward halving interval parameter to network constants.
|
||||||
|
|
||||||
## 0.8.2
|
## [0.8.2] - 2018-11-06
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- Recognize `OP_CHECKDATASIG` and `OP_CHECKDATASIGVERIFY` opcodes.
|
- Recognize `OP_CHECKDATASIG` and `OP_CHECKDATASIGVERIFY` opcodes.
|
||||||
|
|
||||||
## 0.8.1
|
## [0.8.1] - 2018-10-13
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- Add instances of `Hashable` and `Generic` where possible.
|
- Add instances of `Hashable` and `Generic` where possible.
|
||||||
|
|
||||||
## 0.8.0
|
## [0.8.0] - 2018-10-13
|
||||||
|
|
||||||
### Removed
|
### Removed
|
||||||
|
|
||||||
- Remove `deepseq` dependency.
|
- Remove `deepseq` dependency.
|
||||||
- Remove network constant reference from address and extended keys.
|
- Remove network constant reference from address and extended keys.
|
||||||
|
|
||||||
## 0.7.0
|
## [0.7.0] - 2018-10-13
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- Add `Serialize` instance for network constants.
|
- Add `Serialize` instance for network constants.
|
||||||
- Add `Serialize` instance for addresses that includes network constants.
|
- Add `Serialize` instance for addresses that includes network constants.
|
||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
|
|
||||||
- Move functions related to addresses from `Script` to `Address` module.
|
- Move functions related to addresses from `Script` to `Address` module.
|
||||||
|
|
||||||
## 0.6.1
|
## [0.6.1] - 2018-10-09
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- Compatibility with latest GHC and base.
|
- Compatibility with latest GHC and base.
|
||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
|
|
||||||
- Update minimum base to 4.9.
|
- Update minimum base to 4.9.
|
||||||
|
|
||||||
## 0.6.0
|
## [0.6.0] - 2018-10-08
|
||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
|
|
||||||
- Force initialization of addresses through smart constructor.
|
- Force initialization of addresses through smart constructor.
|
||||||
- Assume addresses are always valid when instantiated in code.
|
- Assume addresses are always valid when instantiated in code.
|
||||||
- Allow to provide unwrapped private keys to transaction signing functions.
|
- Allow to provide unwrapped private keys to transaction signing functions.
|
||||||
|
|
||||||
## 0.5.2
|
## [0.5.2] - 2018-09-10
|
||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
|
|
||||||
- Make dependencies more specific.
|
- Make dependencies more specific.
|
||||||
|
|
||||||
## 0.5.1
|
## [0.5.1] - 2018-09-10
|
||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
|
|
||||||
- Remove some unneeded dependencies from `stack.yaml`.
|
- Remove some unneeded dependencies from `stack.yaml`.
|
||||||
- Change `secp256k1` dependency to `secp256k1-haskell`.
|
- Change `secp256k1` dependency to `secp256k1-haskell`.
|
||||||
|
|
||||||
## 0.5.0
|
## [0.5.0] - 2018-09-09
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- Support for Bitcoin Cash network block sychronization.
|
- Support for Bitcoin Cash network block sychronization.
|
||||||
- Support for Bitcoin Cash signatures.
|
- Support for Bitcoin Cash signatures.
|
||||||
- Initial work on SegWit support.
|
- 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.
|
- Support for CashAddr addresses.
|
||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
|
|
||||||
- Use of hpack `package.yaml` file to auto-generate Cabal file.
|
- Use of hpack `package.yaml` file to auto-generate Cabal file.
|
||||||
- Removal of dependency version limits, relying on `stack.yaml` instead.
|
- Removal of dependency version limits, relying on `stack.yaml` instead.
|
||||||
- Tests moved to `hspec`.
|
- 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.
|
- Target LTS Haskell 12.9.
|
||||||
|
|
||||||
### Removed
|
### Removed
|
||||||
|
|
||||||
- Removed `.stylish-haskell.yaml` files.
|
- Removed `.stylish-haskell.yaml` files.
|
||||||
- Removed old `haskoin-node` and `haskoin-wallet` packages from main repository.
|
- Removed old `haskoin-node` and `haskoin-wallet` packages from main repository.
|
||||||
- Removed support for non-strict signatures and related tests.
|
- 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
|
## 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
|
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
|
-- see: https://github.com/sol/hpack
|
||||||
|
|
||||||
name: haskoin-core
|
name: haskoin-core
|
||||||
version: 0.22.0
|
version: 1.0.0
|
||||||
synopsis: Bitcoin & Bitcoin Cash library for Haskell
|
synopsis: Bitcoin & Bitcoin Cash library for Haskell
|
||||||
description: Please see the README on GitHub at <https://github.com/haskoin/haskoin-core#readme>
|
description: Please see the README on GitHub at <https://github.com/haskoin/haskoin-core#readme>
|
||||||
category: Bitcoin, Finance, Network
|
category: Bitcoin, Finance, Network
|
||||||
@ -25,9 +25,9 @@ extra-source-files:
|
|||||||
data/forkid_sighash.json
|
data/forkid_sighash.json
|
||||||
data/key_io_invalid.json
|
data/key_io_invalid.json
|
||||||
data/key_io_valid.json
|
data/key_io_valid.json
|
||||||
data/rfc6979abc.json
|
data/rfc6979cash.json
|
||||||
data/rfc6979core.json
|
data/rfc6979core.json
|
||||||
data/rfc6979DERabc.json
|
data/rfc6979DERcash.json
|
||||||
data/rfc6979DERcore.json
|
data/rfc6979DERcore.json
|
||||||
data/script_tests.json
|
data/script_tests.json
|
||||||
data/sig_nonstrict.json
|
data/sig_nonstrict.json
|
||||||
@ -51,18 +51,18 @@ library
|
|||||||
Haskoin.Block.Common
|
Haskoin.Block.Common
|
||||||
Haskoin.Block.Headers
|
Haskoin.Block.Headers
|
||||||
Haskoin.Block.Merkle
|
Haskoin.Block.Merkle
|
||||||
Haskoin.Constants
|
|
||||||
Haskoin.Crypto
|
Haskoin.Crypto
|
||||||
Haskoin.Crypto.Hash
|
Haskoin.Crypto.Hash
|
||||||
|
Haskoin.Crypto.Keys
|
||||||
|
Haskoin.Crypto.Keys.Common
|
||||||
|
Haskoin.Crypto.Keys.Extended
|
||||||
|
Haskoin.Crypto.Keys.Mnemonic
|
||||||
Haskoin.Crypto.Signature
|
Haskoin.Crypto.Signature
|
||||||
Haskoin.Data
|
|
||||||
Haskoin.Keys
|
|
||||||
Haskoin.Keys.Common
|
|
||||||
Haskoin.Keys.Extended
|
|
||||||
Haskoin.Keys.Mnemonic
|
|
||||||
Haskoin.Network
|
Haskoin.Network
|
||||||
Haskoin.Network.Bloom
|
Haskoin.Network.Bloom
|
||||||
Haskoin.Network.Common
|
Haskoin.Network.Common
|
||||||
|
Haskoin.Network.Constants
|
||||||
|
Haskoin.Network.Data
|
||||||
Haskoin.Network.Message
|
Haskoin.Network.Message
|
||||||
Haskoin.Script
|
Haskoin.Script
|
||||||
Haskoin.Script.Common
|
Haskoin.Script.Common
|
||||||
@ -87,8 +87,10 @@ library
|
|||||||
Haskoin.Util.Arbitrary.Script
|
Haskoin.Util.Arbitrary.Script
|
||||||
Haskoin.Util.Arbitrary.Transaction
|
Haskoin.Util.Arbitrary.Transaction
|
||||||
Haskoin.Util.Arbitrary.Util
|
Haskoin.Util.Arbitrary.Util
|
||||||
|
Haskoin.Util.Helpers
|
||||||
|
Haskoin.Util.Marshal
|
||||||
other-modules:
|
other-modules:
|
||||||
Haskoin.Keys.Extended.Internal
|
Haskoin.Crypto.Keys.Extended.Internal
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
src
|
src
|
||||||
build-depends:
|
build-depends:
|
||||||
@ -114,7 +116,7 @@ library
|
|||||||
, network >=3.1.1.1
|
, network >=3.1.1.1
|
||||||
, safe >=0.3.18
|
, safe >=0.3.18
|
||||||
, scientific >=0.3.6.2
|
, scientific >=0.3.6.2
|
||||||
, secp256k1-haskell >=0.7.0
|
, secp256k1-haskell >=1.0.0
|
||||||
, split >=0.2.3.3
|
, split >=0.2.3.3
|
||||||
, string-conversions >=0.4.0.1
|
, string-conversions >=0.4.0.1
|
||||||
, text >=1.2.3.0
|
, text >=1.2.3.0
|
||||||
@ -133,10 +135,10 @@ test-suite spec
|
|||||||
Haskoin.AddressSpec
|
Haskoin.AddressSpec
|
||||||
Haskoin.BlockSpec
|
Haskoin.BlockSpec
|
||||||
Haskoin.Crypto.HashSpec
|
Haskoin.Crypto.HashSpec
|
||||||
|
Haskoin.Crypto.Keys.ExtendedSpec
|
||||||
|
Haskoin.Crypto.Keys.MnemonicSpec
|
||||||
|
Haskoin.Crypto.KeysSpec
|
||||||
Haskoin.Crypto.SignatureSpec
|
Haskoin.Crypto.SignatureSpec
|
||||||
Haskoin.Keys.ExtendedSpec
|
|
||||||
Haskoin.Keys.MnemonicSpec
|
|
||||||
Haskoin.KeysSpec
|
|
||||||
Haskoin.NetworkSpec
|
Haskoin.NetworkSpec
|
||||||
Haskoin.ScriptSpec
|
Haskoin.ScriptSpec
|
||||||
Haskoin.Transaction.PartialSpec
|
Haskoin.Transaction.PartialSpec
|
||||||
@ -174,7 +176,7 @@ test-suite spec
|
|||||||
, network >=3.1.1.1
|
, network >=3.1.1.1
|
||||||
, safe >=0.3.18
|
, safe >=0.3.18
|
||||||
, scientific >=0.3.6.2
|
, scientific >=0.3.6.2
|
||||||
, secp256k1-haskell >=0.7.0
|
, secp256k1-haskell >=1.0.0
|
||||||
, split >=0.2.3.3
|
, split >=0.2.3.3
|
||||||
, string-conversions >=0.4.0.1
|
, string-conversions >=0.4.0.1
|
||||||
, text >=1.2.3.0
|
, 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
|
name: haskoin-core
|
||||||
version: 0.22.0
|
version: 1.0.0
|
||||||
synopsis: Bitcoin & Bitcoin Cash library for Haskell
|
synopsis: Bitcoin & Bitcoin Cash library for Haskell
|
||||||
description: Please see the README on GitHub at <https://github.com/haskoin/haskoin-core#readme>
|
description: Please see the README on GitHub at <https://github.com/haskoin/haskoin-core#readme>
|
||||||
category: Bitcoin, Finance, Network
|
category: Bitcoin, Finance, Network
|
||||||
@ -41,7 +41,7 @@ dependencies:
|
|||||||
- split >= 0.2.3.3
|
- split >= 0.2.3.3
|
||||||
- safe >= 0.3.18
|
- safe >= 0.3.18
|
||||||
- scientific >= 0.3.6.2
|
- scientific >= 0.3.6.2
|
||||||
- secp256k1-haskell >= 0.7.0
|
- secp256k1-haskell >= 1.0.0
|
||||||
- string-conversions >= 0.4.0.1
|
- string-conversions >= 0.4.0.1
|
||||||
- text >= 1.2.3.0
|
- text >= 1.2.3.0
|
||||||
- time >= 1.9.3
|
- time >= 1.9.3
|
||||||
@ -51,7 +51,7 @@ dependencies:
|
|||||||
library:
|
library:
|
||||||
source-dirs: src
|
source-dirs: src
|
||||||
other-modules:
|
other-modules:
|
||||||
Haskoin.Keys.Extended.Internal
|
Haskoin.Crypto.Keys.Extended.Internal
|
||||||
when:
|
when:
|
||||||
- condition: false
|
- condition: false
|
||||||
other-modules: Paths_haskoin_core
|
other-modules: Paths_haskoin_core
|
||||||
|
@ -1,4 +1,4 @@
|
|||||||
#!/usr/bin/env bash
|
#!/usr/bin/env bash
|
||||||
|
|
||||||
find src -type f -name "*.hs" | xargs fourmolu -i
|
find src -type f -name "*.hs" | xargs ormolu -i
|
||||||
find test -type f -name "*.hs" | xargs fourmolu -i
|
find test -type f -name "*.hs" | xargs ormolu -i
|
||||||
|
@ -1,34 +1,28 @@
|
|||||||
{- |
|
-- |
|
||||||
Module : Haskoin
|
-- Module : Haskoin
|
||||||
Description : Bitcoin (BTC/BCH) Libraries for Haskell
|
-- Description : Bitcoin (BTC/BCH) Libraries for Haskell
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
This module exports almost all of Haskoin Core, excluding only a few highly
|
-- This module exports almost all of Haskoin Core, excluding only a few highly
|
||||||
specialized address and block-related functions.
|
-- specialized address and block-related functions.
|
||||||
-}
|
module Haskoin
|
||||||
module Haskoin (
|
( module Address,
|
||||||
module Data,
|
|
||||||
module Constants,
|
|
||||||
module Address,
|
|
||||||
module Block,
|
module Block,
|
||||||
module Transaction,
|
module Transaction,
|
||||||
module Script,
|
module Script,
|
||||||
module Keys,
|
|
||||||
module Crypto,
|
module Crypto,
|
||||||
module Network,
|
module Network,
|
||||||
module Util,
|
module Util,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Haskoin.Address as Address
|
import Haskoin.Address as Address
|
||||||
import Haskoin.Block as Block
|
import Haskoin.Block as Block
|
||||||
import Haskoin.Constants as Constants
|
|
||||||
import Haskoin.Crypto as Crypto
|
import Haskoin.Crypto as Crypto
|
||||||
import Haskoin.Data as Data
|
|
||||||
import Haskoin.Keys as Keys
|
|
||||||
import Haskoin.Network as Network
|
import Haskoin.Network as Network
|
||||||
import Haskoin.Script as Script
|
import Haskoin.Script as Script
|
||||||
import Haskoin.Transaction as Transaction
|
import Haskoin.Transaction as Transaction
|
||||||
|
@ -1,22 +1,26 @@
|
|||||||
{-# LANGUAGE DeriveAnyClass #-}
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE NoFieldSelectors #-}
|
||||||
|
|
||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Address
|
-- Module : Haskoin.Address
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
Base58, CashAddr, Bech32 address and WIF private key serialization support.
|
-- Base58, CashAddr, Bech32 address and WIF private key serialization support.
|
||||||
-}
|
module Haskoin.Address
|
||||||
module Haskoin.Address (
|
( -- * Addresses
|
||||||
-- * Addresses
|
|
||||||
Address (..),
|
Address (..),
|
||||||
isPubKeyAddress,
|
isPubKeyAddress,
|
||||||
isScriptAddress,
|
isScriptAddress,
|
||||||
@ -28,9 +32,6 @@ module Haskoin.Address (
|
|||||||
bech32ToAddr,
|
bech32ToAddr,
|
||||||
cashToAddr,
|
cashToAddr,
|
||||||
base58ToAddr,
|
base58ToAddr,
|
||||||
addrToJSON,
|
|
||||||
addrToEncoding,
|
|
||||||
addrFromJSON,
|
|
||||||
pubKeyAddr,
|
pubKeyAddr,
|
||||||
pubKeyWitnessAddr,
|
pubKeyWitnessAddr,
|
||||||
pubKeyCompatWitnessAddr,
|
pubKeyCompatWitnessAddr,
|
||||||
@ -51,248 +52,241 @@ module Haskoin.Address (
|
|||||||
module Haskoin.Address.Base58,
|
module Haskoin.Address.Base58,
|
||||||
module Haskoin.Address.Bech32,
|
module Haskoin.Address.Bech32,
|
||||||
module Haskoin.Address.CashAddr,
|
module Haskoin.Address.CashAddr,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Applicative
|
import Control.Applicative (Alternative ((<|>)))
|
||||||
import Control.Arrow (second)
|
import Control.Arrow (second)
|
||||||
import Control.DeepSeq
|
import Control.DeepSeq (NFData)
|
||||||
import Control.Monad
|
import Control.Monad ((<=<))
|
||||||
import Data.Aeson as A
|
import Crypto.Secp256k1
|
||||||
import Data.Aeson.Encoding as A
|
import Data.Aeson (ToJSON (toJSON), Value, withText)
|
||||||
import Data.Aeson.Types
|
import Data.Aeson.Encoding (Encoding, null_, text)
|
||||||
|
import Data.Aeson.Types (Encoding, Parser, ToJSON (toJSON), Value, withText)
|
||||||
import Data.Binary (Binary (..))
|
import Data.Binary (Binary (..))
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
import qualified Data.ByteString as B
|
import Data.ByteString qualified as B
|
||||||
import Data.Bytes.Get
|
import Data.Bytes.Get (MonadGet (getByteString, getWord64be, getWord8), runGetS)
|
||||||
import Data.Bytes.Put
|
import Data.Bytes.Put (MonadPut (putByteString, putWord64be, putWord8), runPutS)
|
||||||
import Data.Bytes.Serial
|
import Data.Bytes.Serial (Serial (..))
|
||||||
import Data.Hashable
|
import Data.Hashable (Hashable)
|
||||||
import Data.Maybe
|
import Data.Maybe (isNothing)
|
||||||
import Data.Serialize (Serialize (..))
|
import Data.Serialize (Serialize (..))
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as T
|
import Data.Text qualified as T
|
||||||
import Data.Word (Word8)
|
import Data.Word (Word8)
|
||||||
import GHC.Generics (Generic)
|
import GHC.Generics (Generic)
|
||||||
import Haskoin.Address.Base58
|
import Haskoin.Address.Base58
|
||||||
import Haskoin.Address.Bech32
|
import Haskoin.Address.Bech32
|
||||||
import Haskoin.Address.CashAddr
|
import Haskoin.Address.CashAddr
|
||||||
import Haskoin.Crypto
|
import Haskoin.Crypto.Hash
|
||||||
import Haskoin.Data
|
import Haskoin.Crypto.Keys.Common
|
||||||
import Haskoin.Keys.Common
|
import Haskoin.Network.Data
|
||||||
import Haskoin.Script
|
import Haskoin.Script.Common
|
||||||
|
import Haskoin.Script.Standard
|
||||||
import Haskoin.Util
|
import Haskoin.Util
|
||||||
|
|
||||||
-- | Address format for Bitcoin and Bitcoin Cash.
|
-- | Address format for Bitcoin and Bitcoin Cash.
|
||||||
data Address
|
data Address
|
||||||
= -- | pay to public key hash (regular)
|
= -- | pay to public key hash (regular)
|
||||||
PubKeyAddress
|
PubKeyAddress
|
||||||
{ -- | RIPEMD160 hash of public key's SHA256 hash
|
{ -- | RIPEMD160 hash of public key's SHA256 hash
|
||||||
getAddrHash160 :: !Hash160
|
hash160 :: !Hash160
|
||||||
}
|
}
|
||||||
| -- | pay to script hash
|
| -- | pay to script hash
|
||||||
ScriptAddress
|
ScriptAddress
|
||||||
{ -- | RIPEMD160 hash of script's SHA256 hash
|
{ -- | RIPEMD160 hash of script's SHA256 hash
|
||||||
getAddrHash160 :: !Hash160
|
hash160 :: !Hash160
|
||||||
}
|
}
|
||||||
| -- | pay to witness public key hash
|
| -- | pay to witness public key hash
|
||||||
WitnessPubKeyAddress
|
WitnessPubKeyAddress
|
||||||
{ -- | RIPEMD160 hash of public key's SHA256 hash
|
{ -- | RIPEMD160 hash of public key's SHA256 hash
|
||||||
getAddrHash160 :: !Hash160
|
hash160 :: !Hash160
|
||||||
}
|
}
|
||||||
| -- | pay to witness script hash
|
| -- | pay to witness script hash
|
||||||
WitnessScriptAddress
|
WitnessScriptAddress
|
||||||
{ -- | HASH256 hash of script
|
{ -- | HASH256 hash of script
|
||||||
getAddrHash256 :: !Hash256
|
hash256 :: !Hash256
|
||||||
}
|
}
|
||||||
| -- | other witness address
|
| -- | other witness address
|
||||||
WitnessAddress
|
WitnessAddress
|
||||||
{ getAddrVersion :: !Word8
|
{ version :: !Word8,
|
||||||
, getAddrData :: !ByteString
|
bytes :: !ByteString
|
||||||
}
|
}
|
||||||
deriving
|
deriving
|
||||||
(Eq, Ord, Generic, Show, Read, Hashable, NFData)
|
(Eq, Ord, Generic, Show, Read, Hashable, NFData)
|
||||||
|
|
||||||
instance Serial Address where
|
instance Serial Address where
|
||||||
serialize (PubKeyAddress k) = do
|
serialize (PubKeyAddress k) = do
|
||||||
putWord8 0x00
|
putWord8 0x00
|
||||||
serialize k
|
serialize k
|
||||||
serialize (ScriptAddress s) = do
|
serialize (ScriptAddress s) = do
|
||||||
putWord8 0x01
|
putWord8 0x01
|
||||||
serialize s
|
serialize s
|
||||||
serialize (WitnessPubKeyAddress h) = do
|
serialize (WitnessPubKeyAddress h) = do
|
||||||
putWord8 0x02
|
putWord8 0x02
|
||||||
serialize h
|
serialize h
|
||||||
serialize (WitnessScriptAddress s) = do
|
serialize (WitnessScriptAddress s) = do
|
||||||
putWord8 0x03
|
putWord8 0x03
|
||||||
serialize s
|
serialize s
|
||||||
serialize (WitnessAddress v d) = do
|
serialize (WitnessAddress v d) = do
|
||||||
putWord8 0x04
|
putWord8 0x04
|
||||||
putWord8 v
|
putWord8 v
|
||||||
putWord64be (fromIntegral (B.length d))
|
putWord64be (fromIntegral (B.length d))
|
||||||
putByteString d
|
putByteString d
|
||||||
|
|
||||||
deserialize =
|
deserialize =
|
||||||
getWord8 >>= \case
|
getWord8 >>= \case
|
||||||
0x00 -> PubKeyAddress <$> deserialize
|
0x00 -> PubKeyAddress <$> deserialize
|
||||||
0x01 -> ScriptAddress <$> deserialize
|
0x01 -> ScriptAddress <$> deserialize
|
||||||
0x02 -> WitnessPubKeyAddress <$> deserialize
|
0x02 -> WitnessPubKeyAddress <$> deserialize
|
||||||
0x03 -> WitnessScriptAddress <$> deserialize
|
0x03 -> WitnessScriptAddress <$> deserialize
|
||||||
0x04 ->
|
0x04 ->
|
||||||
WitnessAddress <$> getWord8
|
WitnessAddress
|
||||||
<*> (getByteString . fromIntegral =<< getWord64be)
|
<$> getWord8
|
||||||
b ->
|
<*> (getByteString . fromIntegral =<< getWord64be)
|
||||||
fail . T.unpack $
|
b ->
|
||||||
"Could not decode address type byte: "
|
fail . T.unpack $
|
||||||
<> encodeHex (B.singleton b)
|
"Could not decode address type byte: "
|
||||||
|
<> encodeHex (B.singleton b)
|
||||||
|
|
||||||
instance Serialize Address where
|
instance Serialize Address where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance Binary Address where
|
instance Binary Address where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
-- | 'Address' pays to a public key hash.
|
-- | 'Address' pays to a public key hash.
|
||||||
isPubKeyAddress :: Address -> Bool
|
isPubKeyAddress :: Address -> Bool
|
||||||
isPubKeyAddress PubKeyAddress{} = True
|
isPubKeyAddress PubKeyAddress {} = True
|
||||||
isPubKeyAddress _ = False
|
isPubKeyAddress _ = False
|
||||||
|
|
||||||
-- | 'Address' pays to a script hash.
|
-- | 'Address' pays to a script hash.
|
||||||
isScriptAddress :: Address -> Bool
|
isScriptAddress :: Address -> Bool
|
||||||
isScriptAddress ScriptAddress{} = True
|
isScriptAddress ScriptAddress {} = True
|
||||||
isScriptAddress _ = False
|
isScriptAddress _ = False
|
||||||
|
|
||||||
{- | 'Address' pays to a witness public key hash. Only valid for SegWit
|
-- | 'Address' pays to a witness public key hash. Only valid for SegWit
|
||||||
networks.
|
-- networks.
|
||||||
-}
|
|
||||||
isWitnessPubKeyAddress :: Address -> Bool
|
isWitnessPubKeyAddress :: Address -> Bool
|
||||||
isWitnessPubKeyAddress WitnessPubKeyAddress{} = True
|
isWitnessPubKeyAddress WitnessPubKeyAddress {} = True
|
||||||
isWitnessPubKeyAddress _ = False
|
isWitnessPubKeyAddress _ = False
|
||||||
|
|
||||||
isWitnessScriptAddress :: Address -> Bool
|
isWitnessScriptAddress :: Address -> Bool
|
||||||
isWitnessScriptAddress WitnessScriptAddress{} = True
|
isWitnessScriptAddress WitnessScriptAddress {} = True
|
||||||
isWitnessScriptAddress _ = False
|
isWitnessScriptAddress _ = False
|
||||||
|
|
||||||
isWitnessAddress :: Address -> Bool
|
isWitnessAddress :: Address -> Bool
|
||||||
isWitnessAddress WitnessAddress{} = True
|
isWitnessAddress WitnessAddress {} = True
|
||||||
isWitnessAddress _ = False
|
isWitnessAddress _ = False
|
||||||
|
|
||||||
addrToJSON :: Network -> Address -> Value
|
instance MarshalJSON Network Address where
|
||||||
addrToJSON net a = toJSON (addrToText net a)
|
marshalValue net a = toJSON (addrToText net a)
|
||||||
|
marshalEncoding net = maybe null_ text . addrToText net
|
||||||
addrToEncoding :: Network -> Address -> Encoding
|
unmarshalValue net =
|
||||||
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 =
|
|
||||||
withText "address" $ \t ->
|
withText "address" $ \t ->
|
||||||
case textToAddr net t of
|
case textToAddr net t of
|
||||||
Nothing -> fail "could not decode address"
|
Nothing -> fail "could not decode address"
|
||||||
Just x -> return x
|
Just x -> return x
|
||||||
|
|
||||||
{- | Convert address to human-readable string. Uses 'Base58', 'Bech32', or
|
-- | Convert address to human-readable string. Uses 'Base58', 'Bech32', or
|
||||||
'CashAddr' depending on network.
|
-- 'CashAddr' depending on network.
|
||||||
-}
|
|
||||||
addrToText :: Network -> Address -> Maybe Text
|
addrToText :: Network -> Address -> Maybe Text
|
||||||
addrToText net a@PubKeyAddress{getAddrHash160 = h}
|
addrToText net a@PubKeyAddress {hash160 = h}
|
||||||
| isNothing (getCashAddrPrefix net) =
|
| isNothing net.cashAddrPrefix =
|
||||||
Just . encodeBase58Check . runPutS $ base58put net a
|
Just . encodeBase58Check . runPutS $ base58put net a
|
||||||
| otherwise = cashAddrEncode net 0 (runPutS $ serialize h)
|
| otherwise = cashAddrEncode net 0 (runPutS $ serialize h)
|
||||||
addrToText net a@ScriptAddress{getAddrHash160 = h}
|
addrToText net a@ScriptAddress {hash160 = h}
|
||||||
| isNothing (getCashAddrPrefix net) =
|
| isNothing net.cashAddrPrefix =
|
||||||
Just . encodeBase58Check . runPutS $ base58put net a
|
Just . encodeBase58Check . runPutS $ base58put net a
|
||||||
| otherwise =
|
| otherwise =
|
||||||
cashAddrEncode net 1 (runPutS $ serialize h)
|
cashAddrEncode net 1 (runPutS $ serialize h)
|
||||||
addrToText net WitnessPubKeyAddress{getAddrHash160 = h} = do
|
addrToText net WitnessPubKeyAddress {hash160 = h} = do
|
||||||
hrp <- getBech32Prefix net
|
hrp <- net.bech32Prefix
|
||||||
segwitEncode hrp 0 (B.unpack (runPutS $ serialize h))
|
segwitEncode hrp 0 (B.unpack (runPutS $ serialize h))
|
||||||
addrToText net WitnessScriptAddress{getAddrHash256 = h} = do
|
addrToText net WitnessScriptAddress {hash256 = h} = do
|
||||||
hrp <- getBech32Prefix net
|
hrp <- net.bech32Prefix
|
||||||
segwitEncode hrp 0 (B.unpack (runPutS $ serialize h))
|
segwitEncode hrp 0 (B.unpack (runPutS $ serialize h))
|
||||||
addrToText net WitnessAddress{getAddrVersion = v, getAddrData = d} = do
|
addrToText net WitnessAddress {version = v, bytes = d} = do
|
||||||
hrp <- getBech32Prefix net
|
hrp <- net.bech32Prefix
|
||||||
segwitEncode hrp v (B.unpack d)
|
segwitEncode hrp v (B.unpack d)
|
||||||
|
|
||||||
-- | Parse 'Base58', 'Bech32' or 'CashAddr' address, depending on network.
|
-- | Parse 'Base58', 'Bech32' or 'CashAddr' address, depending on network.
|
||||||
textToAddr :: Network -> Text -> Maybe Address
|
textToAddr :: Network -> Text -> Maybe Address
|
||||||
textToAddr net txt =
|
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 :: Network -> Text -> Maybe Address
|
||||||
cashToAddr net txt = do
|
cashToAddr net txt = do
|
||||||
(ver, bs) <- cashAddrDecode net txt
|
(ver, bs) <- cashAddrDecode net txt
|
||||||
case ver of
|
case ver of
|
||||||
0 -> PubKeyAddress <$> eitherToMaybe (runGetS deserialize bs)
|
0 -> PubKeyAddress <$> eitherToMaybe (runGetS deserialize bs)
|
||||||
1 -> ScriptAddress <$> eitherToMaybe (runGetS deserialize bs)
|
1 -> ScriptAddress <$> eitherToMaybe (runGetS deserialize bs)
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
bech32ToAddr :: Network -> Text -> Maybe Address
|
bech32ToAddr :: Network -> Text -> Maybe Address
|
||||||
bech32ToAddr net txt = do
|
bech32ToAddr net txt = do
|
||||||
hrp <- getBech32Prefix net
|
hrp <- net.bech32Prefix
|
||||||
(ver, bs) <- second B.pack <$> segwitDecode hrp txt
|
(ver, bs) <- second B.pack <$> segwitDecode hrp txt
|
||||||
case ver of
|
case ver of
|
||||||
0 -> case B.length bs of
|
0 -> case B.length bs of
|
||||||
20 -> WitnessPubKeyAddress <$> eitherToMaybe (runGetS deserialize bs)
|
20 -> WitnessPubKeyAddress <$> eitherToMaybe (runGetS deserialize bs)
|
||||||
32 -> WitnessScriptAddress <$> eitherToMaybe (runGetS deserialize bs)
|
32 -> WitnessScriptAddress <$> eitherToMaybe (runGetS deserialize bs)
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
_ -> Just $ WitnessAddress ver bs
|
_ -> Just $ WitnessAddress ver bs
|
||||||
|
|
||||||
base58ToAddr :: Network -> Text -> Maybe Address
|
base58ToAddr :: Network -> Text -> Maybe Address
|
||||||
base58ToAddr net txt =
|
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
|
base58get net = do
|
||||||
pfx <- getWord8
|
pfx <- getWord8
|
||||||
addr <- deserialize
|
addr <- deserialize
|
||||||
f pfx addr
|
f pfx addr
|
||||||
where
|
where
|
||||||
f x a
|
f x a
|
||||||
| x == getAddrPrefix net = return $ PubKeyAddress a
|
| x == net.addrPrefix = return $ PubKeyAddress a
|
||||||
| x == getScriptPrefix net = return $ ScriptAddress a
|
| x == net.scriptPrefix = return $ ScriptAddress a
|
||||||
| otherwise = fail "Does not recognize address prefix"
|
| otherwise = fail "Does not recognize address prefix"
|
||||||
|
|
||||||
base58put :: MonadPut m => Network -> Address -> m ()
|
base58put :: (MonadPut m) => Network -> Address -> m ()
|
||||||
base58put net (PubKeyAddress h) = do
|
base58put net (PubKeyAddress h) = do
|
||||||
putWord8 (getAddrPrefix net)
|
putWord8 net.addrPrefix
|
||||||
serialize h
|
serialize h
|
||||||
base58put net (ScriptAddress h) = do
|
base58put net (ScriptAddress h) = do
|
||||||
putWord8 (getScriptPrefix net)
|
putWord8 net.scriptPrefix
|
||||||
serialize h
|
serialize h
|
||||||
base58put _ _ = error "Cannot serialize this address as Base58"
|
base58put _ _ = error "Cannot serialize this address as Base58"
|
||||||
|
|
||||||
-- | Obtain a standard pay-to-public-key-hash address from a public key.
|
-- | Obtain a standard pay-to-public-key-hash address from a public key.
|
||||||
pubKeyAddr :: PubKeyI -> Address
|
pubKeyAddr :: Ctx -> PublicKey -> Address
|
||||||
pubKeyAddr = PubKeyAddress . addressHash . runPutS . serialize
|
pubKeyAddr ctx = PubKeyAddress . addressHash . marshal ctx
|
||||||
|
|
||||||
-- | Obtain a standard pay-to-public-key-hash (P2PKH) address from a 'Hash160'.
|
-- | Obtain a standard pay-to-public-key-hash (P2PKH) address from a 'Hash160'.
|
||||||
p2pkhAddr :: Hash160 -> Address
|
p2pkhAddr :: Hash160 -> Address
|
||||||
p2pkhAddr = PubKeyAddress
|
p2pkhAddr = PubKeyAddress
|
||||||
|
|
||||||
{- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a
|
-- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a
|
||||||
public key.
|
-- public key.
|
||||||
-}
|
pubKeyWitnessAddr :: Ctx -> PublicKey -> Address
|
||||||
pubKeyWitnessAddr :: PubKeyI -> Address
|
pubKeyWitnessAddr ctx =
|
||||||
pubKeyWitnessAddr = WitnessPubKeyAddress . addressHash . runPutS . serialize
|
WitnessPubKeyAddress . addressHash . marshal ctx
|
||||||
|
|
||||||
-- | Obtain a backwards-compatible SegWit P2SH-P2WPKH address from a public key.
|
-- | Obtain a backwards-compatible SegWit P2SH-P2WPKH address from a public key.
|
||||||
pubKeyCompatWitnessAddr :: PubKeyI -> Address
|
pubKeyCompatWitnessAddr :: Ctx -> PublicKey -> Address
|
||||||
pubKeyCompatWitnessAddr =
|
pubKeyCompatWitnessAddr ctx =
|
||||||
p2shAddr
|
p2shAddr
|
||||||
. addressHash
|
. addressHash
|
||||||
. encodeOutputBS
|
. marshal ctx
|
||||||
. PayWitnessPKHash
|
. PayWitnessPKHash
|
||||||
. addressHash
|
. addressHash
|
||||||
. runPutS
|
. marshal ctx
|
||||||
. serialize
|
|
||||||
|
|
||||||
{- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a
|
-- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a
|
||||||
'Hash160'.
|
-- 'Hash160'.
|
||||||
-}
|
|
||||||
p2wpkhAddr :: Hash160 -> Address
|
p2wpkhAddr :: Hash160 -> Address
|
||||||
p2wpkhAddr = WitnessPubKeyAddress
|
p2wpkhAddr = WitnessPubKeyAddress
|
||||||
|
|
||||||
@ -305,66 +299,68 @@ p2wshAddr :: Hash256 -> Address
|
|||||||
p2wshAddr = WitnessScriptAddress
|
p2wshAddr = WitnessScriptAddress
|
||||||
|
|
||||||
-- | Compute a standard pay-to-script-hash (P2SH) address for an output script.
|
-- | Compute a standard pay-to-script-hash (P2SH) address for an output script.
|
||||||
payToScriptAddress :: ScriptOutput -> Address
|
payToScriptAddress :: Ctx -> ScriptOutput -> Address
|
||||||
payToScriptAddress = p2shAddr . addressHash . encodeOutputBS
|
payToScriptAddress ctx = p2shAddr . addressHash . marshal ctx
|
||||||
|
|
||||||
{- | Compute a SegWit pay-to-witness-script-hash (P2WSH) address for an output
|
-- | Compute a SegWit pay-to-witness-script-hash (P2WSH) address for an output
|
||||||
script.
|
-- script.
|
||||||
-}
|
payToWitnessScriptAddress :: Ctx -> ScriptOutput -> Address
|
||||||
payToWitnessScriptAddress :: ScriptOutput -> Address
|
payToWitnessScriptAddress ctx = p2wshAddr . sha256 . marshal ctx
|
||||||
payToWitnessScriptAddress = p2wshAddr . sha256 . encodeOutputBS
|
|
||||||
|
|
||||||
-- | Compute a backwards-compatible SegWit P2SH-P2WSH address.
|
-- | Compute a backwards-compatible SegWit P2SH-P2WSH address.
|
||||||
payToNestedScriptAddress :: ScriptOutput -> Address
|
payToNestedScriptAddress :: Ctx -> ScriptOutput -> Address
|
||||||
payToNestedScriptAddress =
|
payToNestedScriptAddress ctx =
|
||||||
p2shAddr . addressHash . encodeOutputBS . toP2WSH . encodeOutput
|
p2shAddr . addressHash . marshal ctx . toP2WSH . encodeOutput ctx
|
||||||
|
|
||||||
{- | Encode an output script from an address. Will fail if using a
|
-- | Encode an output script from an address. Will fail if using a
|
||||||
pay-to-witness address on a non-SegWit network.
|
-- pay-to-witness address on a non-SegWit network.
|
||||||
-}
|
|
||||||
addressToOutput :: Address -> ScriptOutput
|
addressToOutput :: Address -> ScriptOutput
|
||||||
addressToOutput =
|
addressToOutput =
|
||||||
\case
|
\case
|
||||||
PubKeyAddress h -> PayPKHash h
|
PubKeyAddress h -> PayPKHash h
|
||||||
ScriptAddress h -> PayScriptHash h
|
ScriptAddress h -> PayScriptHash h
|
||||||
WitnessPubKeyAddress h -> PayWitnessPKHash h
|
WitnessPubKeyAddress h -> PayWitnessPKHash h
|
||||||
WitnessScriptAddress h -> PayWitnessScriptHash h
|
WitnessScriptAddress h -> PayWitnessScriptHash h
|
||||||
WitnessAddress v d -> PayWitness v d
|
WitnessAddress v d -> PayWitness v d
|
||||||
|
|
||||||
-- | Get output script AST for an 'Address'.
|
-- | Get output script AST for an 'Address'.
|
||||||
addressToScript :: Address -> Script
|
addressToScript :: Ctx -> Address -> Script
|
||||||
addressToScript = encodeOutput . addressToOutput
|
addressToScript ctx = encodeOutput ctx . addressToOutput
|
||||||
|
|
||||||
-- | Encode address as output script in 'ByteString' form.
|
-- | Encode address as output script in 'ByteString' form.
|
||||||
addressToScriptBS :: Address -> ByteString
|
addressToScriptBS :: Ctx -> Address -> ByteString
|
||||||
addressToScriptBS = runPutS . serialize . addressToScript
|
addressToScriptBS ctx = runPutS . serialize . addressToScript ctx
|
||||||
|
|
||||||
-- | Decode an output script into an 'Address' if it has such representation.
|
-- | Decode an output script into an 'Address' if it has such representation.
|
||||||
scriptToAddress :: Script -> Either String Address
|
scriptToAddress :: Ctx -> Script -> Either String Address
|
||||||
scriptToAddress =
|
scriptToAddress ctx =
|
||||||
maybeToEither "Could not decode address" . outputAddress <=< decodeOutput
|
maybeToEither e . outputAddress ctx <=< decodeOutput ctx
|
||||||
|
where
|
||||||
|
e = "Could not decode address"
|
||||||
|
|
||||||
-- | Decode a serialized script into an 'Address'.
|
-- | Decode a serialized script into an 'Address'.
|
||||||
scriptToAddressBS :: ByteString -> Either String Address
|
scriptToAddressBS :: Ctx -> ByteString -> Either String Address
|
||||||
scriptToAddressBS =
|
scriptToAddressBS ctx =
|
||||||
maybeToEither "Could not decode address" . outputAddress <=< decodeOutputBS
|
maybeToEither e . outputAddress ctx <=< unmarshal ctx
|
||||||
|
where
|
||||||
|
e = "Could not decode address"
|
||||||
|
|
||||||
-- | Get the 'Address' of a 'ScriptOutput'.
|
-- | Get the 'Address' of a 'ScriptOutput'.
|
||||||
outputAddress :: ScriptOutput -> Maybe Address
|
outputAddress :: Ctx -> ScriptOutput -> Maybe Address
|
||||||
outputAddress =
|
outputAddress ctx =
|
||||||
\case
|
\case
|
||||||
PayPKHash h -> Just $ PubKeyAddress h
|
PayPKHash h -> Just $ PubKeyAddress h
|
||||||
PayScriptHash h -> Just $ ScriptAddress h
|
PayScriptHash h -> Just $ ScriptAddress h
|
||||||
PayPK k -> Just $ pubKeyAddr k
|
PayPK k -> Just $ pubKeyAddr ctx k
|
||||||
PayWitnessPKHash h -> Just $ WitnessPubKeyAddress h
|
PayWitnessPKHash h -> Just $ WitnessPubKeyAddress h
|
||||||
PayWitnessScriptHash h -> Just $ WitnessScriptAddress h
|
PayWitnessScriptHash h -> Just $ WitnessScriptAddress h
|
||||||
PayWitness v d -> Just $ WitnessAddress v d
|
PayWitness v d -> Just $ WitnessAddress v d
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
-- | Infer the 'Address' of a 'ScriptInput'.
|
-- | Infer the 'Address' of a 'ScriptInput'.
|
||||||
inputAddress :: ScriptInput -> Maybe Address
|
inputAddress :: Ctx -> ScriptInput -> Maybe Address
|
||||||
inputAddress =
|
inputAddress ctx =
|
||||||
\case
|
\case
|
||||||
(RegularInput (SpendPKHash _ key)) -> Just $ pubKeyAddr key
|
(RegularInput (SpendPKHash _ key)) -> Just $ pubKeyAddr ctx key
|
||||||
(ScriptHashInput _ rdm) -> Just $ payToScriptAddress rdm
|
(ScriptHashInput _ rdm) -> Just $ payToScriptAddress ctx rdm
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
@ -1,41 +1,43 @@
|
|||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE NoFieldSelectors #-}
|
||||||
|
|
||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Address.Base58
|
-- Module : Haskoin.Address.Base58
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
Support for legacy 'Base58' addresses. Superseded by Bech32 for Bitcoin SegWit
|
-- Support for legacy 'Base58' addresses. Superseded by Bech32 for Bitcoin SegWit
|
||||||
(BTC) and CashAddr for Bitcoin Cash (BCH).
|
-- (BTC) and CashAddr for Bitcoin Cash (BCH).
|
||||||
-}
|
module Haskoin.Address.Base58
|
||||||
module Haskoin.Address.Base58 (
|
( -- * Base58
|
||||||
-- * Base58
|
|
||||||
Base58,
|
Base58,
|
||||||
encodeBase58,
|
encodeBase58,
|
||||||
decodeBase58,
|
decodeBase58,
|
||||||
encodeBase58Check,
|
encodeBase58Check,
|
||||||
decodeBase58Check,
|
decodeBase58Check,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad (guard)
|
||||||
import Data.Array
|
import Data.Array (Array, assocs, listArray, (!), (//))
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
import qualified Data.ByteString as BS
|
import Data.ByteString qualified as B
|
||||||
import qualified Data.ByteString.Char8 as C
|
import Data.ByteString.Char8 qualified as C
|
||||||
import Data.Bytes.Get
|
import Data.Bytes.Get ()
|
||||||
import Data.Bytes.Put
|
import Data.Bytes.Put (runPutS)
|
||||||
import Data.Bytes.Serial
|
import Data.Bytes.Serial (Serial (serialize))
|
||||||
import Data.Char
|
import Data.Char (chr, ord)
|
||||||
import Data.Maybe (fromMaybe, isJust, listToMaybe)
|
import Data.Maybe (fromMaybe, isJust, listToMaybe)
|
||||||
import Data.String.Conversions (cs)
|
import Data.String.Conversions (cs)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as T
|
import Data.Text qualified as T
|
||||||
import Data.Word
|
import Data.Word (Word8)
|
||||||
import Haskoin.Crypto.Hash
|
import Haskoin.Crypto.Hash (checkSum32)
|
||||||
import Haskoin.Util
|
import Haskoin.Util.Helpers (bsToInteger, integerToBS)
|
||||||
import Numeric (readInt, showIntAtBase)
|
import Numeric (readInt, showIntAtBase)
|
||||||
|
|
||||||
-- | 'Base58' classic Bitcoin address format.
|
-- | 'Base58' classic Bitcoin address format.
|
||||||
@ -46,16 +48,19 @@ b58Data :: ByteString
|
|||||||
b58Data = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
|
b58Data = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
|
||||||
|
|
||||||
b58Array :: Array Int Word8
|
b58Array :: Array Int Word8
|
||||||
b58Array = listArray (0, 57) (BS.unpack b58Data)
|
b58Array = listArray (0, 57) (B.unpack b58Data)
|
||||||
|
|
||||||
b58InvArray :: Array Word8 (Maybe Int)
|
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
|
where
|
||||||
swap (i, c) = (c, Just i)
|
swap (i, c) = (c, Just i)
|
||||||
|
|
||||||
{- | Convert a number less than or equal to provided integer into a 'Base58'
|
-- | Convert a number less than or equal to provided integer into a 'Base58'
|
||||||
character.
|
-- character.
|
||||||
-}
|
|
||||||
b58 :: Int -> Word8
|
b58 :: Int -> Word8
|
||||||
b58 = (b58Array !)
|
b58 = (b58Array !)
|
||||||
|
|
||||||
@ -63,62 +68,58 @@ b58 = (b58Array !)
|
|||||||
b58' :: Word8 -> Maybe Int
|
b58' :: Word8 -> Maybe Int
|
||||||
b58' = (b58InvArray !)
|
b58' = (b58InvArray !)
|
||||||
|
|
||||||
{- | Encode an arbitrary-length 'Integer' into a 'Base58' string. Leading zeroes
|
-- | Encode an arbitrary-length 'Integer' into a 'Base58' string. Leading zeroes
|
||||||
will not be part of the resulting string.
|
-- will not be part of the resulting string.
|
||||||
-}
|
|
||||||
encodeBase58I :: Integer -> Base58
|
encodeBase58I :: Integer -> Base58
|
||||||
encodeBase58I i = cs $ showIntAtBase 58 (chr . fromIntegral . b58) i ""
|
encodeBase58I i = cs $ showIntAtBase 58 (chr . fromIntegral . b58) i ""
|
||||||
|
|
||||||
-- | Decode a 'Base58' string into an arbitrary-length 'Integer'.
|
-- | Decode a 'Base58' string into an arbitrary-length 'Integer'.
|
||||||
decodeBase58I :: Base58 -> Maybe Integer
|
decodeBase58I :: Base58 -> Maybe Integer
|
||||||
decodeBase58I s =
|
decodeBase58I s =
|
||||||
case go of
|
case go of
|
||||||
Just (r, []) -> Just r
|
Just (r, []) -> Just r
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
where
|
where
|
||||||
p = isJust . b58' . fromIntegral . ord
|
p = isJust . b58' . fromIntegral . ord
|
||||||
f = fromMaybe e . b58' . fromIntegral . ord
|
f = fromMaybe e . b58' . fromIntegral . ord
|
||||||
go = listToMaybe $ readInt 58 p f (cs s)
|
go = listToMaybe $ readInt 58 p f (cs s)
|
||||||
e = error "Could not decode base58"
|
e = error "Could not decode base58"
|
||||||
|
|
||||||
{- | Encode an arbitrary 'ByteString' into a its 'Base58' representation,
|
-- | Encode an arbitrary 'ByteString' into a its 'Base58' representation,
|
||||||
preserving leading zeroes.
|
-- preserving leading zeroes.
|
||||||
-}
|
|
||||||
encodeBase58 :: ByteString -> Base58
|
encodeBase58 :: ByteString -> Base58
|
||||||
encodeBase58 bs =
|
encodeBase58 bs =
|
||||||
l <> r
|
l <> r
|
||||||
where
|
where
|
||||||
(z, b) = BS.span (== 0) bs
|
(z, b) = B.span (== 0) bs
|
||||||
l = cs $ BS.replicate (BS.length z) (b58 0) -- preserve leading 0's
|
l = cs $ B.replicate (B.length z) (b58 0) -- preserve leading 0's
|
||||||
r
|
r
|
||||||
| BS.null b = T.empty
|
| B.null b = T.empty
|
||||||
| otherwise = encodeBase58I $ bsToInteger b
|
| otherwise = encodeBase58I $ bsToInteger b
|
||||||
|
|
||||||
-- | Decode a 'Base58'-encoded 'Text' to a 'ByteString'.
|
-- | Decode a 'Base58'-encoded 'Text' to a 'ByteString'.
|
||||||
decodeBase58 :: Base58 -> Maybe ByteString
|
decodeBase58 :: Base58 -> Maybe ByteString
|
||||||
decodeBase58 t =
|
decodeBase58 t =
|
||||||
BS.append prefix <$> r
|
B.append prefix <$> r
|
||||||
where
|
where
|
||||||
(z, b) = BS.span (== b58 0) (cs t)
|
(z, b) = B.span (== b58 0) (cs t)
|
||||||
prefix = BS.replicate (BS.length z) 0 -- preserve leading 1's
|
prefix = B.replicate (B.length z) 0 -- preserve leading 1's
|
||||||
r
|
r
|
||||||
| BS.null b = Just BS.empty
|
| B.null b = Just B.empty
|
||||||
| otherwise = integerToBS <$> decodeBase58I (cs b)
|
| otherwise = integerToBS <$> decodeBase58I (cs b)
|
||||||
|
|
||||||
{- | Computes a checksum for the input 'ByteString' and encodes the input and
|
-- | Computes a checksum for the input 'ByteString' and encodes the input and
|
||||||
the checksum as 'Base58'.
|
-- the checksum as 'Base58'.
|
||||||
-}
|
|
||||||
encodeBase58Check :: ByteString -> Base58
|
encodeBase58Check :: ByteString -> Base58
|
||||||
encodeBase58Check bs =
|
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
|
-- | Decode a 'Base58'-encoded string that contains a checksum. This function
|
||||||
returns 'Nothing' if the input string contains invalid 'Base58' characters or
|
-- returns 'Nothing' if the input string contains invalid 'Base58' characters or
|
||||||
if the checksum fails.
|
-- if the checksum fails.
|
||||||
-}
|
|
||||||
decodeBase58Check :: Base58 -> Maybe ByteString
|
decodeBase58Check :: Base58 -> Maybe ByteString
|
||||||
decodeBase58Check bs = do
|
decodeBase58Check bs = do
|
||||||
rs <- decodeBase58 bs
|
rs <- decodeBase58 bs
|
||||||
let (res, chk) = BS.splitAt (BS.length rs - 4) rs
|
let (res, chk) = B.splitAt (B.length rs - 4) rs
|
||||||
guard $ chk == runPutS (serialize (checkSum32 res))
|
guard $ chk == (runPutS . serialize . checkSum32) res
|
||||||
return res
|
return res
|
||||||
|
@ -1,19 +1,20 @@
|
|||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
{-# LANGUAGE MultiWayIf #-}
|
{-# LANGUAGE MultiWayIf #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE NoFieldSelectors #-}
|
||||||
|
|
||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Address.Base58
|
-- Module : Haskoin.Address.Base58
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
Support for Bitcoin SegWit (BTC) Bech32 addresses. This module is a modified
|
-- Support for Bitcoin SegWit (BTC) Bech32 addresses. This module is a modified
|
||||||
version of Marko Bencun's reference implementation.
|
-- version of Marko Bencun's reference implementation.
|
||||||
-}
|
module Haskoin.Address.Bech32
|
||||||
module Haskoin.Address.Bech32 (
|
( -- * Bech32
|
||||||
-- * Bech32
|
|
||||||
HRP,
|
HRP,
|
||||||
Bech32,
|
Bech32,
|
||||||
Bech32Encoding (..),
|
Bech32Encoding (..),
|
||||||
@ -28,38 +29,39 @@ module Haskoin.Address.Bech32 (
|
|||||||
Word5 (..),
|
Word5 (..),
|
||||||
word5,
|
word5,
|
||||||
fromWord5,
|
fromWord5,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Monad (guard)
|
import Control.Monad (guard)
|
||||||
import Data.Array (
|
import Data.Array
|
||||||
Array,
|
( Array,
|
||||||
assocs,
|
assocs,
|
||||||
bounds,
|
bounds,
|
||||||
listArray,
|
listArray,
|
||||||
(!),
|
(!),
|
||||||
(//),
|
(//),
|
||||||
)
|
)
|
||||||
import Data.Bits (
|
import Data.Bits
|
||||||
Bits,
|
( Bits,
|
||||||
testBit,
|
testBit,
|
||||||
unsafeShiftL,
|
unsafeShiftL,
|
||||||
unsafeShiftR,
|
unsafeShiftR,
|
||||||
xor,
|
xor,
|
||||||
(.&.),
|
(.&.),
|
||||||
(.|.),
|
(.|.),
|
||||||
)
|
)
|
||||||
import qualified Data.ByteString as B
|
import Data.ByteString qualified as B
|
||||||
import Data.Char (toUpper)
|
import Data.Char (toUpper)
|
||||||
import Data.Foldable (foldl')
|
import Data.Foldable (foldl')
|
||||||
import Data.Functor.Identity (Identity, runIdentity)
|
import Data.Functor.Identity (Identity, runIdentity)
|
||||||
import Data.Ix (Ix (..))
|
import Data.Ix (Ix (..))
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as T
|
import Data.Text qualified as T
|
||||||
import qualified Data.Text.Encoding as E
|
import Data.Text.Encoding qualified as E
|
||||||
import Data.Word (Word8)
|
import Data.Word (Word8)
|
||||||
|
|
||||||
data Bech32Encoding = Bech32 | Bech32m
|
data Bech32Encoding = Bech32 | Bech32m
|
||||||
deriving (Eq, Show, Ord, Enum)
|
deriving (Eq, Show, Ord, Enum)
|
||||||
|
|
||||||
-- | Bech32 human-readable string.
|
-- | Bech32 human-readable string.
|
||||||
type Bech32 = Text
|
type Bech32 = Text
|
||||||
@ -70,28 +72,28 @@ type HRP = Text
|
|||||||
-- | Data part of 'Bech32' address.
|
-- | Data part of 'Bech32' address.
|
||||||
type Data = [Word8]
|
type Data = [Word8]
|
||||||
|
|
||||||
(.>>.), (.<<.) :: Bits a => a -> Int -> a
|
(.>>.), (.<<.) :: (Bits a) => a -> Int -> a
|
||||||
(.>>.) = unsafeShiftR
|
(.>>.) = unsafeShiftR
|
||||||
(.<<.) = unsafeShiftL
|
(.<<.) = unsafeShiftL
|
||||||
|
|
||||||
-- | Five-bit word for Bech32.
|
-- | Five-bit word for Bech32.
|
||||||
newtype Word5
|
newtype Word5
|
||||||
= UnsafeWord5 Word8
|
= UnsafeWord5 Word8
|
||||||
deriving (Eq, Ord)
|
deriving (Eq, Ord)
|
||||||
|
|
||||||
instance Ix Word5 where
|
instance Ix Word5 where
|
||||||
range (UnsafeWord5 m, UnsafeWord5 n) = map UnsafeWord5 $ range (m, n)
|
range (UnsafeWord5 m, UnsafeWord5 n) = map UnsafeWord5 $ range (m, n)
|
||||||
index (UnsafeWord5 m, UnsafeWord5 n) (UnsafeWord5 i) = index (m, n) i
|
index (UnsafeWord5 m, UnsafeWord5 n) (UnsafeWord5 i) = index (m, n) i
|
||||||
inRange (m, n) i = m <= i && i <= n
|
inRange (m, n) i = m <= i && i <= n
|
||||||
|
|
||||||
-- | Convert an integer number into a five-bit word.
|
-- | 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)
|
word5 x = UnsafeWord5 (fromIntegral x .&. 31)
|
||||||
{-# INLINE word5 #-}
|
{-# INLINE word5 #-}
|
||||||
{-# SPECIALIZE INLINE word5 :: Word8 -> Word5 #-}
|
{-# SPECIALIZE INLINE word5 :: Word8 -> Word5 #-}
|
||||||
|
|
||||||
-- | Convert a five-bit word into a number.
|
-- | Convert a five-bit word into a number.
|
||||||
fromWord5 :: Num a => Word5 -> a
|
fromWord5 :: (Num a) => Word5 -> a
|
||||||
fromWord5 (UnsafeWord5 x) = fromIntegral x
|
fromWord5 (UnsafeWord5 x) = fromIntegral x
|
||||||
{-# INLINE fromWord5 #-}
|
{-# INLINE fromWord5 #-}
|
||||||
{-# SPECIALIZE INLINE fromWord5 :: Word5 -> Word8 #-}
|
{-# 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.
|
-- | 'Bech32' character map as array of five-bit integers to character.
|
||||||
charset :: Array Word5 Char
|
charset :: Array Word5 Char
|
||||||
charset =
|
charset =
|
||||||
listArray (UnsafeWord5 0, UnsafeWord5 31) "qpzry9x8gf2tvdw0s3jn54khce6mua7l"
|
listArray (UnsafeWord5 0, UnsafeWord5 31) "qpzry9x8gf2tvdw0s3jn54khce6mua7l"
|
||||||
|
|
||||||
-- | Convert a character to its five-bit value from 'Bech32' 'charset'.
|
-- | Convert a character to its five-bit value from 'Bech32' 'charset'.
|
||||||
charsetMap :: Char -> Maybe Word5
|
charsetMap :: Char -> Maybe Word5
|
||||||
charsetMap c
|
charsetMap c
|
||||||
| inRange (bounds inv) upperC = inv ! upperC
|
| inRange (bounds inv) upperC = inv ! upperC
|
||||||
| otherwise = Nothing
|
| otherwise = Nothing
|
||||||
where
|
where
|
||||||
upperC = toUpper c
|
upperC = toUpper c
|
||||||
inv = listArray ('0', 'Z') (repeat Nothing) // map swap (assocs charset)
|
inv = listArray ('0', 'Z') (repeat Nothing) // map swap (assocs charset)
|
||||||
@ -116,19 +118,18 @@ bech32Polymod :: [Word5] -> Word
|
|||||||
bech32Polymod values = foldl' go 1 values .&. 0x3fffffff
|
bech32Polymod values = foldl' go 1 values .&. 0x3fffffff
|
||||||
where
|
where
|
||||||
go chk value =
|
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
|
where
|
||||||
generator = [0x3b6a57b2, 0x26508e6d, 0x1ea119fa, 0x3d4233dd, 0x2a1462b3]
|
generator = [0x3b6a57b2, 0x26508e6d, 0x1ea119fa, 0x3d4233dd, 0x2a1462b3]
|
||||||
chk' = chk .<<. 5 `xor` fromWord5 value
|
chk' = chk .<<. 5 `xor` fromWord5 value
|
||||||
|
|
||||||
{- | Convert human-readable part of 'Bech32' string into a list of five-bit
|
-- | Convert human-readable part of 'Bech32' string into a list of five-bit
|
||||||
words.
|
-- words.
|
||||||
-}
|
|
||||||
bech32HRPExpand :: HRP -> [Word5]
|
bech32HRPExpand :: HRP -> [Word5]
|
||||||
bech32HRPExpand hrp =
|
bech32HRPExpand hrp =
|
||||||
map (UnsafeWord5 . (.>>. 5)) hrpBytes
|
map (UnsafeWord5 . (.>>. 5)) hrpBytes
|
||||||
++ [UnsafeWord5 0]
|
++ [UnsafeWord5 0]
|
||||||
++ map word5 hrpBytes
|
++ map word5 hrpBytes
|
||||||
where
|
where
|
||||||
hrpBytes = B.unpack $ E.encodeUtf8 hrp
|
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.
|
-- | Verify Bech32 checksum for a human-readable part and string of five-bit words.
|
||||||
bech32VerifyChecksum :: HRP -> [Word5] -> Maybe Bech32Encoding
|
bech32VerifyChecksum :: HRP -> [Word5] -> Maybe Bech32Encoding
|
||||||
bech32VerifyChecksum hrp dat =
|
bech32VerifyChecksum hrp dat =
|
||||||
let poly = bech32Polymod (bech32HRPExpand hrp ++ dat)
|
let poly = bech32Polymod (bech32HRPExpand hrp ++ dat)
|
||||||
in if
|
in if
|
||||||
| poly == bech32Const Bech32 -> Just Bech32
|
| poly == bech32Const Bech32 -> Just Bech32
|
||||||
| poly == bech32Const Bech32m -> Just Bech32m
|
| poly == bech32Const Bech32m -> Just Bech32m
|
||||||
| otherwise -> Nothing
|
| otherwise -> Nothing
|
||||||
|
|
||||||
-- | Maximum length of a Bech32 result.
|
-- | Maximum length of a Bech32 result.
|
||||||
maxBech32Length :: Int
|
maxBech32Length :: Int
|
||||||
maxBech32Length = 90
|
maxBech32Length = 90
|
||||||
|
|
||||||
{- | Encode string of five-bit words into 'Bech32' using a provided
|
-- | 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
|
-- human-readable part. Can fail if 'HRP' is invalid or result would be longer
|
||||||
than 90 characters.
|
-- than 90 characters.
|
||||||
-}
|
|
||||||
bech32Encode :: Bech32Encoding -> HRP -> [Word5] -> Maybe Bech32
|
bech32Encode :: Bech32Encoding -> HRP -> [Word5] -> Maybe Bech32
|
||||||
bech32Encode enc hrp dat = do
|
bech32Encode enc hrp dat = do
|
||||||
guard $ checkHRP hrp
|
guard $ checkHRP hrp
|
||||||
let dat' = dat ++ bech32CreateChecksum enc (T.toLower hrp) dat
|
let dat' = dat ++ bech32CreateChecksum enc (T.toLower hrp) dat
|
||||||
rest = map (charset !) dat'
|
rest = map (charset !) dat'
|
||||||
result = T.concat [T.toLower hrp, T.pack "1", T.pack rest]
|
result = T.concat [T.toLower hrp, T.pack "1", T.pack rest]
|
||||||
guard $ T.length result <= maxBech32Length
|
guard $ T.length result <= maxBech32Length
|
||||||
return result
|
return result
|
||||||
|
|
||||||
-- | Check that human-readable part is valid for a 'Bech32' string.
|
-- | Check that human-readable part is valid for a 'Bech32' string.
|
||||||
checkHRP :: HRP -> Bool
|
checkHRP :: HRP -> Bool
|
||||||
checkHRP hrp =
|
checkHRP hrp =
|
||||||
not (T.null hrp)
|
not (T.null hrp)
|
||||||
&& T.all (\char -> char >= '\x21' && char <= '\x7e') hrp
|
&& T.all (\char -> char >= '\x21' && char <= '\x7e') hrp
|
||||||
|
|
||||||
{- | Decode human-readable 'Bech32' string into a human-readable part and a
|
-- | Decode human-readable 'Bech32' string into a human-readable part and a
|
||||||
string of five-bit words.
|
-- string of five-bit words.
|
||||||
-}
|
|
||||||
bech32Decode :: Bech32 -> Maybe (Bech32Encoding, HRP, [Word5])
|
bech32Decode :: Bech32 -> Maybe (Bech32Encoding, HRP, [Word5])
|
||||||
bech32Decode bech32 = do
|
bech32Decode bech32 = do
|
||||||
guard $ T.length bech32 <= maxBech32Length
|
guard $ T.length bech32 <= maxBech32Length
|
||||||
guard $ T.toUpper bech32 == bech32 || lowerBech32 == bech32
|
guard $ T.toUpper bech32 == bech32 || lowerBech32 == bech32
|
||||||
let (hrp, dat) = T.breakOnEnd "1" lowerBech32
|
let (hrp, dat) = T.breakOnEnd "1" lowerBech32
|
||||||
guard $ T.length dat >= 6
|
guard $ T.length dat >= 6
|
||||||
hrp' <- T.stripSuffix "1" hrp
|
hrp' <- T.stripSuffix "1" hrp
|
||||||
guard $ checkHRP hrp'
|
guard $ checkHRP hrp'
|
||||||
dat' <- mapM charsetMap $ T.unpack dat
|
dat' <- mapM charsetMap $ T.unpack dat
|
||||||
enc <- bech32VerifyChecksum hrp' dat'
|
enc <- bech32VerifyChecksum hrp' dat'
|
||||||
return (enc, hrp', take (T.length dat - 6) dat')
|
return (enc, hrp', take (T.length dat - 6) dat')
|
||||||
where
|
where
|
||||||
lowerBech32 = T.toLower bech32
|
lowerBech32 = T.toLower bech32
|
||||||
|
|
||||||
@ -202,67 +201,65 @@ yesPadding _ _ padValue result = return $ [padValue] : result
|
|||||||
|
|
||||||
noPadding :: Pad Maybe
|
noPadding :: Pad Maybe
|
||||||
noPadding frombits bits padValue result = do
|
noPadding frombits bits padValue result = do
|
||||||
guard $ bits < frombits && padValue == 0
|
guard $ bits < frombits && padValue == 0
|
||||||
return result
|
return result
|
||||||
{-# INLINE noPadding #-}
|
{-# INLINE noPadding #-}
|
||||||
|
|
||||||
{- | Big endian conversion of a bytestring from base \(2^{frombits}\) to base
|
-- | Big endian conversion of a bytestring from base \(2^{frombits}\) to base
|
||||||
\(2^{tobits}\). {frombits} and {twobits} must be positive and
|
-- \(2^{tobits}\). {frombits} and {twobits} must be positive and
|
||||||
\(2^{frombits}\) and \(2^{tobits}\) must be smaller than the size of Word.
|
-- \(2^{frombits}\) and \(2^{tobits}\) must be smaller than the size of Word.
|
||||||
Every value in 'dat' must be strictly smaller than \(2^{frombits}\).
|
-- Every value in 'dat' must be strictly smaller than \(2^{frombits}\).
|
||||||
-}
|
convertBits :: (Functor f) => [Word] -> Int -> Int -> Pad f -> f [Word]
|
||||||
convertBits :: Functor f => [Word] -> Int -> Int -> Pad f -> f [Word]
|
|
||||||
convertBits dat frombits tobits pad = concat . reverse <$> go dat 0 0 []
|
convertBits dat frombits tobits pad = concat . reverse <$> go dat 0 0 []
|
||||||
where
|
where
|
||||||
go [] acc bits result =
|
go [] acc bits result =
|
||||||
let padValue = (acc .<<. (tobits - bits)) .&. maxv
|
let padValue = (acc .<<. (tobits - bits)) .&. maxv
|
||||||
in pad frombits bits padValue result
|
in pad frombits bits padValue result
|
||||||
go (value : dat') acc bits result =
|
go (value : dat') acc bits result =
|
||||||
go dat' acc' (bits' `rem` tobits) (result' : result)
|
go dat' acc' (bits' `rem` tobits) (result' : result)
|
||||||
where
|
where
|
||||||
acc' = (acc .<<. frombits) .|. fromIntegral value
|
acc' = (acc .<<. frombits) .|. fromIntegral value
|
||||||
bits' = bits + frombits
|
bits' = bits + frombits
|
||||||
result' =
|
result' =
|
||||||
[ (acc' .>>. b) .&. maxv
|
[ (acc' .>>. b) .&. maxv
|
||||||
| b <- [bits' - tobits, bits' - 2 * tobits .. 0]
|
| b <- [bits' - tobits, bits' - 2 * tobits .. 0]
|
||||||
]
|
]
|
||||||
maxv = (1 .<<. tobits) - 1
|
maxv = (1 .<<. tobits) - 1
|
||||||
{-# INLINE convertBits #-}
|
{-# INLINE convertBits #-}
|
||||||
|
|
||||||
-- | Convert from eight-bit to five-bit word string, adding padding as required.
|
-- | Convert from eight-bit to five-bit word string, adding padding as required.
|
||||||
toBase32 :: [Word8] -> [Word5]
|
toBase32 :: [Word8] -> [Word5]
|
||||||
toBase32 dat =
|
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.
|
-- | Convert from five-bit word string to eight-bit word string, ignoring padding.
|
||||||
toBase256 :: [Word5] -> Maybe [Word8]
|
toBase256 :: [Word5] -> Maybe [Word8]
|
||||||
toBase256 dat =
|
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.
|
-- | Check if witness version and program are valid.
|
||||||
segwitCheck :: Bech32Encoding -> Word8 -> Data -> Bool
|
segwitCheck :: Bech32Encoding -> Word8 -> Data -> Bool
|
||||||
segwitCheck enc witver witprog =
|
segwitCheck enc witver witprog =
|
||||||
witver <= 16
|
witver <= 16
|
||||||
&& if witver == 0
|
&& if witver == 0
|
||||||
then enc == Bech32 && (length witprog == 20 || length witprog == 32)
|
then enc == Bech32 && (length witprog == 20 || length witprog == 32)
|
||||||
else enc == Bech32m && (length witprog >= 2 && length witprog <= 40)
|
else enc == Bech32m && (length witprog >= 2 && length witprog <= 40)
|
||||||
|
|
||||||
-- | Decode SegWit 'Bech32' address from a string and expected human-readable part.
|
-- | Decode SegWit 'Bech32' address from a string and expected human-readable part.
|
||||||
segwitDecode :: HRP -> Bech32 -> Maybe (Word8, Data)
|
segwitDecode :: HRP -> Bech32 -> Maybe (Word8, Data)
|
||||||
segwitDecode hrp addr = do
|
segwitDecode hrp addr = do
|
||||||
(enc, hrp', dat) <- bech32Decode addr
|
(enc, hrp', dat) <- bech32Decode addr
|
||||||
guard $ (hrp == hrp') && not (null dat)
|
guard $ (hrp == hrp') && not (null dat)
|
||||||
let (UnsafeWord5 witver : datBase32) = dat
|
let (UnsafeWord5 witver : datBase32) = dat
|
||||||
decoded <- toBase256 datBase32
|
decoded <- toBase256 datBase32
|
||||||
guard $ segwitCheck enc witver decoded
|
guard $ segwitCheck enc witver decoded
|
||||||
return (witver, decoded)
|
return (witver, decoded)
|
||||||
|
|
||||||
{- | Encode 'Data' as a SegWit 'Bech32' address. Needs human-readable part and
|
-- | Encode 'Data' as a SegWit 'Bech32' address. Needs human-readable part and
|
||||||
witness program version.
|
-- witness program version.
|
||||||
-}
|
|
||||||
segwitEncode :: HRP -> Word8 -> Data -> Maybe Text
|
segwitEncode :: HRP -> Word8 -> Data -> Maybe Text
|
||||||
segwitEncode hrp witver witprog = do
|
segwitEncode hrp witver witprog = do
|
||||||
guard $ segwitCheck enc witver witprog
|
guard $ segwitCheck enc witver witprog
|
||||||
bech32Encode enc hrp $ UnsafeWord5 witver : toBase32 witprog
|
bech32Encode enc hrp $ UnsafeWord5 witver : toBase32 witprog
|
||||||
where
|
where
|
||||||
enc = if witver == 0 then Bech32 else Bech32m
|
enc = if witver == 0 then Bech32 else Bech32m
|
||||||
|
@ -1,17 +1,20 @@
|
|||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE NoFieldSelectors #-}
|
||||||
|
|
||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Address.CashAddr
|
-- Module : Haskoin.Address.CashAddr
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
Support for Bitcoin Cash (BCH) CashAddr format.
|
-- Support for Bitcoin Cash (BCH) CashAddr format.
|
||||||
-}
|
module Haskoin.Address.CashAddr
|
||||||
module Haskoin.Address.CashAddr (
|
( -- * CashAddr
|
||||||
-- * CashAddr
|
|
||||||
CashPrefix,
|
CashPrefix,
|
||||||
CashVersion,
|
CashVersion,
|
||||||
CashAddr,
|
CashAddr,
|
||||||
@ -22,26 +25,35 @@ module Haskoin.Address.CashAddr (
|
|||||||
cash32encodeType,
|
cash32encodeType,
|
||||||
cash32decode,
|
cash32decode,
|
||||||
cash32encode,
|
cash32encode,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad (guard)
|
||||||
import Data.Bits
|
import Data.Bits
|
||||||
|
( Bits
|
||||||
|
( shiftL,
|
||||||
|
shiftR,
|
||||||
|
testBit,
|
||||||
|
xor,
|
||||||
|
(.&.),
|
||||||
|
(.|.)
|
||||||
|
),
|
||||||
|
)
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
import qualified Data.ByteString as B
|
import Data.ByteString qualified as B
|
||||||
import qualified Data.ByteString.Char8 as C
|
import Data.ByteString.Char8 qualified as C
|
||||||
import Data.Char
|
import Data.Char (ord, toLower, toUpper)
|
||||||
import Data.List
|
import Data.List (elemIndex, foldl')
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as T
|
import Data.Text qualified as T
|
||||||
import qualified Data.Text.Encoding as E
|
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
||||||
import Data.Word
|
import Data.Word (Word64, Word8)
|
||||||
import Haskoin.Data
|
import Haskoin.Network.Data (Network (cashAddrPrefix))
|
||||||
import Haskoin.Util
|
import Haskoin.Util.Helpers (convertBits)
|
||||||
|
|
||||||
{- | 'CashAddr' prefix, usually shown before the colon in addresses, but sometimes
|
-- | 'CashAddr' prefix, usually shown before the colon in addresses, but sometimes
|
||||||
omitted. It is used in the checksum calculation to avoid parsing an address
|
-- omitted. It is used in the checksum calculation to avoid parsing an address
|
||||||
from the wrong network.
|
-- from the wrong network.
|
||||||
-}
|
|
||||||
type CashPrefix = Text
|
type CashPrefix = Text
|
||||||
|
|
||||||
-- | 'CashAddr' version, until new address schemes appear it will be zero.
|
-- | '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.
|
-- | High level 'CashAddr' human-reabale string, with explicit or implicit prefix.
|
||||||
type CashAddr = Text
|
type CashAddr = Text
|
||||||
|
|
||||||
{- | Low level 'Cash32' is the human-readable low-level encoding used by 'CashAddr'. It
|
-- | Low level 'Cash32' is the human-readable low-level encoding used by 'CashAddr'.
|
||||||
need not encode a valid address but any binary data.
|
-- It need not encode a valid address but any binary data.
|
||||||
-}
|
|
||||||
type Cash32 = Text
|
type Cash32 = Text
|
||||||
|
|
||||||
-- | Symbols for encoding 'Cash32' data in human-readable strings.
|
-- | Symbols for encoding 'Cash32' data in human-readable strings.
|
||||||
@ -63,156 +74,147 @@ charset = "qpzry9x8gf2tvdw0s3jn54khce6mua7l"
|
|||||||
base32char :: Char -> Maybe Word8
|
base32char :: Char -> Maybe Word8
|
||||||
base32char = fmap fromIntegral . (`elemIndex` charset)
|
base32char = fmap fromIntegral . (`elemIndex` charset)
|
||||||
|
|
||||||
{- | High-Level: decode 'CashAddr' string if it is valid for the
|
-- | High-Level: decode 'CashAddr' string if it is valid for the
|
||||||
provided 'Network'. Prefix may be omitted from the string.
|
-- provided 'Network'. Prefix may be omitted from the string.
|
||||||
-}
|
|
||||||
cashAddrDecode :: Network -> CashAddr -> Maybe (CashVersion, ByteString)
|
cashAddrDecode :: Network -> CashAddr -> Maybe (CashVersion, ByteString)
|
||||||
cashAddrDecode net ca = do
|
cashAddrDecode net ca = do
|
||||||
epfx <- getCashAddrPrefix net
|
epfx <- net.cashAddrPrefix
|
||||||
let (cpfx, cdat) = T.breakOnEnd ":" (T.toLower ca)
|
let (cpfx, cdat) = T.breakOnEnd ":" (T.toLower ca)
|
||||||
guard (T.null cpfx || T.init cpfx == epfx)
|
guard (T.null cpfx || T.init cpfx == epfx)
|
||||||
(dpfx, ver, bs) <- cash32decodeType (epfx <> ":" <> cdat)
|
(dpfx, ver, bs) <- cash32decodeType (epfx <> ":" <> cdat)
|
||||||
guard (dpfx == epfx)
|
guard (dpfx == epfx)
|
||||||
return (ver, bs)
|
return (ver, bs)
|
||||||
|
|
||||||
{- | High-Level: encode 'CashAddr' string for the provided network and hash.
|
-- | High-Level: encode 'CashAddr' string for the provided network and hash.
|
||||||
Fails if the 'CashVersion' or length of hash 'ByteString' is invalid.
|
-- Fails if the 'CashVersion' or length of hash 'ByteString' is invalid.
|
||||||
-}
|
|
||||||
cashAddrEncode :: Network -> CashVersion -> ByteString -> Maybe CashAddr
|
cashAddrEncode :: Network -> CashVersion -> ByteString -> Maybe CashAddr
|
||||||
cashAddrEncode net cv bs = do
|
cashAddrEncode net cv bs = do
|
||||||
pfx <- getCashAddrPrefix net
|
pfx <- net.cashAddrPrefix
|
||||||
cash32encodeType pfx cv bs
|
cash32encodeType pfx cv bs
|
||||||
|
|
||||||
{- | Mid-Level: decode 'CashAddr' string containing arbitrary prefix, plus a
|
-- | Mid-Level: decode 'CashAddr' string containing arbitrary prefix, plus a
|
||||||
version byte before the 'ByteString' that encodes type and length.
|
-- version byte before the 'ByteString' that encodes type and length.
|
||||||
-}
|
|
||||||
cash32decodeType :: Cash32 -> Maybe (CashPrefix, CashVersion, ByteString)
|
cash32decodeType :: Cash32 -> Maybe (CashPrefix, CashVersion, ByteString)
|
||||||
cash32decodeType ca' = do
|
cash32decodeType ca' = do
|
||||||
guard (T.toUpper ca' == ca' || ca == ca')
|
guard (T.toUpper ca' == ca' || ca == ca')
|
||||||
(dpfx, bs) <- cash32decode ca
|
(dpfx, bs) <- cash32decode ca
|
||||||
guard (not (B.null bs))
|
guard (not (B.null bs))
|
||||||
let vb = B.head bs
|
let vb = B.head bs
|
||||||
pay = B.tail bs
|
pay = B.tail bs
|
||||||
(ver, len) <- decodeVersionByte vb
|
(ver, len) <- decodeVersionByte vb
|
||||||
guard (B.length pay == len)
|
guard (B.length pay == len)
|
||||||
return (dpfx, ver, pay)
|
return (dpfx, ver, pay)
|
||||||
where
|
where
|
||||||
ca = T.toLower ca'
|
ca = T.toLower ca'
|
||||||
|
|
||||||
{- | Mid-Level: encode 'CashAddr' string containing arbitrary prefix and
|
-- | Mid-Level: encode 'CashAddr' string containing arbitrary prefix and
|
||||||
'CashVersion'. Length must be among those allowed by the standard.
|
-- 'CashVersion'. Length must be among those allowed by the standard.
|
||||||
-}
|
|
||||||
cash32encodeType :: CashPrefix -> CashVersion -> ByteString -> Maybe Cash32
|
cash32encodeType :: CashPrefix -> CashVersion -> ByteString -> Maybe Cash32
|
||||||
cash32encodeType pfx cv bs = do
|
cash32encodeType pfx cv bs = do
|
||||||
let len = B.length bs
|
let len = B.length bs
|
||||||
vb <- encodeVersionByte cv len
|
vb <- encodeVersionByte cv len
|
||||||
let pl = vb `B.cons` bs
|
let pl = vb `B.cons` bs
|
||||||
return (cash32encode pfx pl)
|
return (cash32encode pfx pl)
|
||||||
|
|
||||||
{- | Low-Level: decode 'Cash32' string. 'CashPrefix' must be part of the string.
|
-- | Low-Level: decode 'Cash32' string. 'CashPrefix' must be part of the string.
|
||||||
No version or hash length validation is performed.
|
-- No version or hash length validation is performed.
|
||||||
-}
|
|
||||||
cash32decode :: Cash32 -> Maybe (CashPrefix, ByteString)
|
cash32decode :: Cash32 -> Maybe (CashPrefix, ByteString)
|
||||||
cash32decode text = do
|
cash32decode text = do
|
||||||
let bs = C.map toLower bs'
|
let bs = C.map toLower bs'
|
||||||
guard (C.map toUpper bs' == bs' || bs == bs')
|
guard (C.map toUpper bs' == bs' || bs == bs')
|
||||||
let (pfx', dat) = C.breakEnd (== ':') bs
|
let (pfx', dat) = C.breakEnd (== ':') bs
|
||||||
pfx <-
|
pfx <-
|
||||||
if B.null pfx' || pfx' == C.singleton ':'
|
if B.null pfx' || pfx' == C.singleton ':'
|
||||||
then Nothing
|
then Nothing
|
||||||
else Just (B.init pfx')
|
else Just (B.init pfx')
|
||||||
b32 <- B.pack <$> mapM base32char (C.unpack dat)
|
b32 <- B.pack <$> mapM base32char (C.unpack dat)
|
||||||
let px = B.map (.&. 0x1f) pfx
|
let px = B.map (.&. 0x1f) pfx
|
||||||
pd = px <> B.singleton 0 <> b32
|
pd = px <> B.singleton 0 <> b32
|
||||||
cs = cash32Polymod pd
|
cs = cash32Polymod pd
|
||||||
bb = B.take (B.length b32 - 8) b32
|
bb = B.take (B.length b32 - 8) b32
|
||||||
guard (verifyCash32Polymod cs)
|
guard (verifyCash32Polymod cs)
|
||||||
let out = toBase256 bb
|
let out = toBase256 bb
|
||||||
return (E.decodeUtf8 pfx, out)
|
return (decodeUtf8 pfx, out)
|
||||||
where
|
where
|
||||||
bs' = E.encodeUtf8 text
|
bs' = encodeUtf8 text
|
||||||
|
|
||||||
{- | Low-Level: encode 'Cash32' string for 'CashPrefix' provided. Can encode
|
-- | Low-Level: encode 'Cash32' string for 'CashPrefix' provided. Can encode
|
||||||
arbitrary data. No prefix or length validation is performed.
|
-- arbitrary data. No prefix or length validation is performed.
|
||||||
-}
|
|
||||||
cash32encode :: CashPrefix -> ByteString -> Cash32
|
cash32encode :: CashPrefix -> ByteString -> Cash32
|
||||||
cash32encode pfx bs =
|
cash32encode pfx bs =
|
||||||
let b32 = toBase32 bs
|
let b32 = toBase32 bs
|
||||||
px = B.map (.&. 0x1f) (E.encodeUtf8 pfx)
|
px = B.map (.&. 0x1f) (encodeUtf8 pfx)
|
||||||
pd = px <> B.singleton 0 <> b32 <> B.replicate 8 0
|
pd = px <> B.singleton 0 <> b32 <> B.replicate 8 0
|
||||||
cs = cash32Polymod pd
|
cs = cash32Polymod pd
|
||||||
c32 = B.map f (b32 <> cs)
|
c32 = B.map f (b32 <> cs)
|
||||||
f = fromIntegral . ord . (charset !!) . fromIntegral
|
f = fromIntegral . ord . (charset !!) . fromIntegral
|
||||||
in pfx <> ":" <> E.decodeUtf8 c32
|
in pfx <> ":" <> decodeUtf8 c32
|
||||||
|
|
||||||
{- | Convert base of 'ByteString' from eight bits per byte to five bits per
|
-- | Convert base of 'ByteString' from eight bits per byte to five bits per
|
||||||
byte, adding padding as necessary.
|
-- byte, adding padding as necessary.
|
||||||
-}
|
|
||||||
toBase32 :: ByteString -> ByteString
|
toBase32 :: ByteString -> ByteString
|
||||||
toBase32 =
|
toBase32 =
|
||||||
B.pack
|
B.pack
|
||||||
. map fromIntegral
|
. map fromIntegral
|
||||||
. fst
|
. fst
|
||||||
. convertBits True 8 5
|
. convertBits True 8 5
|
||||||
. map fromIntegral
|
. map fromIntegral
|
||||||
. B.unpack
|
. B.unpack
|
||||||
|
|
||||||
{- | Convert base of 'ByteString' from five to eight bits per byte. Ignore
|
-- | Convert base of 'ByteString' from five to eight bits per byte. Ignore
|
||||||
padding to be symmetric with respect to 'toBase32' function.
|
-- padding to be symmetric with respect to 'toBase32' function.
|
||||||
-}
|
|
||||||
toBase256 :: ByteString -> ByteString
|
toBase256 :: ByteString -> ByteString
|
||||||
toBase256 =
|
toBase256 =
|
||||||
B.pack
|
B.pack
|
||||||
. map fromIntegral
|
. map fromIntegral
|
||||||
. fst
|
. fst
|
||||||
. convertBits False 5 8
|
. convertBits False 5 8
|
||||||
. map fromIntegral
|
. map fromIntegral
|
||||||
. B.unpack
|
. B.unpack
|
||||||
|
|
||||||
-- | Obtain 'CashVersion' and payload length from 'CashAddr' version byte.
|
-- | Obtain 'CashVersion' and payload length from 'CashAddr' version byte.
|
||||||
decodeVersionByte :: Word8 -> Maybe (CashVersion, Int)
|
decodeVersionByte :: Word8 -> Maybe (CashVersion, Int)
|
||||||
decodeVersionByte vb = do
|
decodeVersionByte vb = do
|
||||||
guard (vb .&. 0x80 == 0)
|
guard (vb .&. 0x80 == 0)
|
||||||
return (ver, len)
|
return (ver, len)
|
||||||
where
|
where
|
||||||
ver = vb `shiftR` 3
|
ver = vb `shiftR` 3
|
||||||
len = ls !! fromIntegral (vb .&. 0x07)
|
len = ls !! fromIntegral (vb .&. 0x07)
|
||||||
ls = [20, 24, 28, 32, 40, 48, 56, 64]
|
ls = [20, 24, 28, 32, 40, 48, 56, 64]
|
||||||
|
|
||||||
{- | Encode 'CashVersion' and length into version byte. Fail if version is
|
-- | Encode 'CashVersion' and length into version byte. Fail if version is
|
||||||
larger than five bits, or length incorrect, since that is invalid.
|
-- larger than five bits, or length incorrect, since that is invalid.
|
||||||
-}
|
|
||||||
encodeVersionByte :: CashVersion -> Int -> Maybe Word8
|
encodeVersionByte :: CashVersion -> Int -> Maybe Word8
|
||||||
encodeVersionByte ver len = do
|
encodeVersionByte ver len = do
|
||||||
guard (ver == ver .&. 0x0f)
|
guard (ver == ver .&. 0x0f)
|
||||||
l <- case len of
|
l <- case len of
|
||||||
20 -> Just 0
|
20 -> Just 0
|
||||||
24 -> Just 1
|
24 -> Just 1
|
||||||
28 -> Just 2
|
28 -> Just 2
|
||||||
32 -> Just 3
|
32 -> Just 3
|
||||||
40 -> Just 4
|
40 -> Just 4
|
||||||
48 -> Just 5
|
48 -> Just 5
|
||||||
56 -> Just 6
|
56 -> Just 6
|
||||||
64 -> Just 7
|
64 -> Just 7
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
return ((ver `shiftL` 3) .|. l)
|
return ((ver `shiftL` 3) .|. l)
|
||||||
|
|
||||||
-- | Calculate or validate checksum from base32 'ByteString' (excluding prefix).
|
-- | Calculate or validate checksum from base32 'ByteString' (excluding prefix).
|
||||||
cash32Polymod :: ByteString -> ByteString
|
cash32Polymod :: ByteString -> ByteString
|
||||||
cash32Polymod v =
|
cash32Polymod v =
|
||||||
B.pack
|
B.pack
|
||||||
[fromIntegral (polymod `shiftR` (5 * (7 - i))) .&. 0x1f | i <- [0 .. 7]]
|
[fromIntegral (polymod `shiftR` (5 * (7 - i))) .&. 0x1f | i <- [0 .. 7]]
|
||||||
where
|
where
|
||||||
polymod = B.foldl' outer (1 :: Word64) v `xor` 1
|
polymod = B.foldl' outer (1 :: Word64) v `xor` 1
|
||||||
outer c d =
|
outer c d =
|
||||||
let c0 = (fromIntegral (c `shiftR` 35) :: Word8)
|
let c0 = (fromIntegral (c `shiftR` 35) :: Word8)
|
||||||
c' = ((c .&. 0x07ffffffff) `shiftL` 5) `xor` fromIntegral d
|
c' = ((c .&. 0x07ffffffff) `shiftL` 5) `xor` fromIntegral d
|
||||||
in foldl' (inner c0) c' (zip [0 ..] generator)
|
in foldl' (inner c0) c' (zip [0 ..] generator)
|
||||||
generator =
|
generator =
|
||||||
[0x98f2bc8e61, 0x79b76d99e2, 0xf33e5fb3c4, 0xae2eabe2a8, 0x1e4f43e470]
|
[0x98f2bc8e61, 0x79b76d99e2, 0xf33e5fb3c4, 0xae2eabe2a8, 0x1e4f43e470]
|
||||||
inner c0 c (b, g)
|
inner c0 c (b, g)
|
||||||
| c0 `testBit` b = c `xor` g
|
| c0 `testBit` b = c `xor` g
|
||||||
| otherwise = c
|
| otherwise = c
|
||||||
|
|
||||||
-- | Validate that polymod 'ByteString' (eight bytes) is equal to zero.
|
-- | Validate that polymod 'ByteString' (eight bytes) is equal to zero.
|
||||||
verifyCash32Polymod :: ByteString -> Bool
|
verifyCash32Polymod :: ByteString -> Bool
|
||||||
|
@ -1,18 +1,18 @@
|
|||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Block
|
-- Module : Haskoin.Block
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
Most functions relating to blocks are exported by this module.
|
-- Most functions relating to blocks are exported by this module.
|
||||||
-}
|
module Haskoin.Block
|
||||||
module Haskoin.Block (
|
( module Haskoin.Block.Common,
|
||||||
module Haskoin.Block.Common,
|
|
||||||
module Haskoin.Block.Headers,
|
module Haskoin.Block.Headers,
|
||||||
module Haskoin.Block.Merkle,
|
module Haskoin.Block.Merkle,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Haskoin.Block.Common
|
import Haskoin.Block.Common
|
||||||
import Haskoin.Block.Headers
|
import Haskoin.Block.Headers
|
||||||
|
@ -1,19 +1,21 @@
|
|||||||
{-# LANGUAGE DeriveAnyClass #-}
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE NoFieldSelectors #-}
|
||||||
|
|
||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Block.Common
|
-- Module : Haskoin.Block.Common
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
Common data types and functions to handle blocks from the block chain.
|
-- Common data types and functions to handle blocks from the block chain.
|
||||||
-}
|
module Haskoin.Block.Common
|
||||||
module Haskoin.Block.Common (
|
( -- * Blocks
|
||||||
-- * Blocks
|
|
||||||
Block (..),
|
Block (..),
|
||||||
BlockHeight,
|
BlockHeight,
|
||||||
Timestamp,
|
Timestamp,
|
||||||
@ -29,53 +31,34 @@ module Haskoin.Block.Common (
|
|||||||
Headers (..),
|
Headers (..),
|
||||||
decodeCompact,
|
decodeCompact,
|
||||||
encodeCompact,
|
encodeCompact,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.DeepSeq
|
import Control.DeepSeq
|
||||||
import Control.Monad (forM_, liftM2, mzero, replicateM, (<=<))
|
import Control.Monad
|
||||||
import Data.Aeson (
|
import Data.Aeson
|
||||||
FromJSON (..),
|
import Data.Aeson.Encoding
|
||||||
ToJSON (..),
|
|
||||||
Value (..),
|
|
||||||
object,
|
|
||||||
toJSON,
|
|
||||||
withObject,
|
|
||||||
withText,
|
|
||||||
(.:),
|
|
||||||
(.=),
|
|
||||||
)
|
|
||||||
import Data.Aeson.Encoding (pairs, unsafeToEncoding)
|
|
||||||
import Data.Binary (Binary (..))
|
import Data.Binary (Binary (..))
|
||||||
import Data.Bits (shiftL, shiftR, (.&.), (.|.))
|
import Data.Bits
|
||||||
import qualified Data.ByteString as B
|
import Data.ByteString qualified as B
|
||||||
import Data.ByteString.Builder (char7)
|
import Data.ByteString.Builder (char7)
|
||||||
import qualified Data.ByteString.Lazy as BL
|
import Data.ByteString.Lazy qualified as L
|
||||||
import Data.Bytes.Get (
|
import Data.Bytes.Get
|
||||||
MonadGet,
|
import Data.Bytes.Put
|
||||||
getWord32le,
|
import Data.Bytes.Serial
|
||||||
runGetL,
|
import Data.Hashable
|
||||||
runGetS,
|
import Data.Maybe
|
||||||
)
|
|
||||||
import Data.Bytes.Put (
|
|
||||||
MonadPut,
|
|
||||||
putWord32le,
|
|
||||||
runPutL,
|
|
||||||
runPutS,
|
|
||||||
)
|
|
||||||
import Data.Bytes.Serial (Serial (..))
|
|
||||||
import Data.Hashable (Hashable)
|
|
||||||
import Data.Maybe (fromMaybe)
|
|
||||||
import Data.Serialize (Serialize (..))
|
import Data.Serialize (Serialize (..))
|
||||||
import Data.String (IsString, fromString)
|
import Data.String
|
||||||
import Data.String.Conversions (cs)
|
import Data.String.Conversions
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Word (Word32)
|
import Data.Word
|
||||||
import GHC.Generics (Generic)
|
import GHC.Generics
|
||||||
import Haskoin.Crypto.Hash
|
import Haskoin.Crypto.Hash
|
||||||
import Haskoin.Network.Common
|
import Haskoin.Network.Common
|
||||||
import Haskoin.Transaction.Common
|
import Haskoin.Transaction.Common
|
||||||
import Haskoin.Util
|
import Haskoin.Util.Helpers
|
||||||
import qualified Text.Read as R
|
import Text.Read qualified as R
|
||||||
|
|
||||||
-- | Height of a block in the block chain, starting at 0 for Genesis.
|
-- | Height of a block in the block chain, starting at 0 for Genesis.
|
||||||
type BlockHeight = Word32
|
type BlockHeight = Word32
|
||||||
@ -85,311 +68,312 @@ type Timestamp = Word32
|
|||||||
|
|
||||||
-- | Block header and transactions.
|
-- | Block header and transactions.
|
||||||
data Block = Block
|
data Block = Block
|
||||||
{ blockHeader :: !BlockHeader
|
{ header :: !BlockHeader,
|
||||||
, blockTxns :: ![Tx]
|
txs :: ![Tx]
|
||||||
}
|
}
|
||||||
deriving (Eq, Show, Read, Generic, Hashable, NFData)
|
deriving (Eq, Show, Read, Generic, Hashable, NFData)
|
||||||
|
|
||||||
instance Serial Block where
|
instance Serial Block where
|
||||||
deserialize = do
|
deserialize = do
|
||||||
header <- deserialize
|
header <- deserialize
|
||||||
(VarInt c) <- deserialize
|
(VarInt c) <- deserialize
|
||||||
txs <- replicateM (fromIntegral c) deserialize
|
txs <- replicateM (fromIntegral c) deserialize
|
||||||
return $ Block header txs
|
return $ Block header txs
|
||||||
serialize (Block h txs) = do
|
serialize (Block h txs) = do
|
||||||
serialize h
|
serialize h
|
||||||
putVarInt $ length txs
|
putVarInt $ length txs
|
||||||
forM_ txs serialize
|
forM_ txs serialize
|
||||||
|
|
||||||
instance Serialize Block where
|
instance Serialize Block where
|
||||||
get = deserialize
|
get = deserialize
|
||||||
put = serialize
|
put = serialize
|
||||||
|
|
||||||
instance Binary Block where
|
instance Binary Block where
|
||||||
get = deserialize
|
get = deserialize
|
||||||
put = serialize
|
put = serialize
|
||||||
|
|
||||||
instance ToJSON Block where
|
instance ToJSON Block where
|
||||||
toJSON (Block h t) = object ["header" .= h, "transactions" .= t]
|
toJSON (Block h t) =
|
||||||
toEncoding (Block h t) = pairs $ "header" .= h <> "transactions" .= 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
|
instance FromJSON Block where
|
||||||
parseJSON =
|
parseJSON =
|
||||||
withObject "Block" $ \o ->
|
withObject "Block" $ \o ->
|
||||||
Block <$> o .: "header" <*> o .: "transactions"
|
Block <$> o .: "header" <*> o .: "transactions"
|
||||||
|
|
||||||
-- | Block header hash. To be serialized reversed for display purposes.
|
-- | Block header hash. To be serialized reversed for display purposes.
|
||||||
newtype BlockHash = BlockHash
|
newtype BlockHash = BlockHash {get :: Hash256}
|
||||||
{ getBlockHash :: Hash256
|
deriving (Eq, Ord, Generic, Hashable, Serial, NFData)
|
||||||
}
|
|
||||||
deriving (Eq, Ord, Generic, Hashable, Serial, NFData)
|
|
||||||
|
|
||||||
instance Serialize BlockHash where
|
instance Serialize BlockHash where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance Binary BlockHash where
|
instance Binary BlockHash where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance Show BlockHash where
|
instance Show BlockHash where
|
||||||
showsPrec _ = shows . blockHashToHex
|
showsPrec _ = shows . blockHashToHex
|
||||||
|
|
||||||
instance Read BlockHash where
|
instance Read BlockHash where
|
||||||
readPrec = do
|
readPrec = do
|
||||||
R.String str <- R.lexP
|
R.String str <- R.lexP
|
||||||
maybe R.pfail return $ hexToBlockHash $ cs str
|
maybe R.pfail return $ hexToBlockHash $ cs str
|
||||||
|
|
||||||
instance IsString BlockHash where
|
instance IsString BlockHash where
|
||||||
fromString s =
|
fromString s =
|
||||||
let e = error "Could not read block hash from hex string"
|
fromMaybe (error "Could not read block hash from hex string") $
|
||||||
in fromMaybe e $ hexToBlockHash $ cs s
|
hexToBlockHash $
|
||||||
|
cs s
|
||||||
|
|
||||||
instance FromJSON BlockHash where
|
instance FromJSON BlockHash where
|
||||||
parseJSON =
|
parseJSON =
|
||||||
withText "BlockHash" $
|
withText "BlockHash" $
|
||||||
maybe mzero return . hexToBlockHash
|
maybe mzero return . hexToBlockHash
|
||||||
|
|
||||||
instance ToJSON BlockHash where
|
instance ToJSON BlockHash where
|
||||||
toJSON = String . blockHashToHex
|
toJSON = String . blockHashToHex
|
||||||
toEncoding h =
|
toEncoding = hexEncoding . L.reverse . runPutL . serialize
|
||||||
unsafeToEncoding $
|
|
||||||
char7 '"'
|
|
||||||
<> hexBuilder (BL.reverse (runPutL (serialize h)))
|
|
||||||
<> char7 '"'
|
|
||||||
|
|
||||||
{- | Block hashes are reversed with respect to the in-memory byte order in a
|
-- | Block hashes are reversed with respect to the in-memory byte order in a
|
||||||
block hash when displayed.
|
-- block hash when displayed.
|
||||||
-}
|
|
||||||
blockHashToHex :: BlockHash -> Text
|
blockHashToHex :: BlockHash -> Text
|
||||||
blockHashToHex (BlockHash h) = encodeHex (B.reverse (runPutS (serialize h)))
|
blockHashToHex (BlockHash h) = encodeHex (B.reverse (runPutS (serialize h)))
|
||||||
|
|
||||||
{- | Convert a human-readable hex block hash into a 'BlockHash'. Bytes are
|
-- | Convert a human-readable hex block hash into a 'BlockHash'. Bytes are
|
||||||
reversed as normal.
|
-- reversed as normal.
|
||||||
-}
|
|
||||||
hexToBlockHash :: Text -> Maybe BlockHash
|
hexToBlockHash :: Text -> Maybe BlockHash
|
||||||
hexToBlockHash hex = do
|
hexToBlockHash hex = do
|
||||||
bs <- B.reverse <$> decodeHex hex
|
bs <- B.reverse <$> decodeHex hex
|
||||||
h <- eitherToMaybe (runGetS deserialize bs)
|
h <- eitherToMaybe (runGetS deserialize bs)
|
||||||
return $ BlockHash h
|
return $ BlockHash h
|
||||||
|
|
||||||
{- | Data type recording information of a 'Block'. The hash of a block is
|
-- | 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
|
-- 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
|
-- process involves finding a partial hash collision by varying the nonce in the
|
||||||
'BlockHeader' and/or additional entropy in the coinbase 'Transaction' of this
|
-- 'BlockHeader' and/or additional entropy in the coinbase 'Transaction' of this
|
||||||
'Block'. Variations in the coinbase will result in different merkle roots in
|
-- 'Block'. Variations in the coinbase will result in different merkle roots in
|
||||||
the 'BlockHeader'.
|
-- the 'BlockHeader'.
|
||||||
-}
|
|
||||||
data BlockHeader = BlockHeader
|
data BlockHeader = BlockHeader
|
||||||
{ blockVersion :: !Word32 -- 4 bytes
|
{ version :: !Word32, -- 4 bytes
|
||||||
, -- | hash of the previous block (parent)
|
|
||||||
prevBlock :: !BlockHash -- 32 bytes
|
-- | hash of the previous block (parent)
|
||||||
, -- | root of the merkle tree of transactions
|
prev :: !BlockHash, -- 32 bytes
|
||||||
merkleRoot :: !Hash256 -- 32 bytes
|
|
||||||
, -- | unix timestamp
|
-- | root of the merkle tree of transactions
|
||||||
blockTimestamp :: !Timestamp -- 4 bytes
|
merkle :: !Hash256, -- 32 bytes
|
||||||
, -- | difficulty target
|
|
||||||
blockBits :: !Word32 -- 4 bytes
|
-- | unix timestamp
|
||||||
, -- | random nonce
|
timestamp :: !Timestamp, -- 4 bytes
|
||||||
bhNonce :: !Word32 -- 4 bytes
|
|
||||||
}
|
-- | difficulty target
|
||||||
deriving (Eq, Ord, Show, Read, Generic, Hashable, NFData)
|
bits :: !Word32, -- 4 bytes
|
||||||
|
|
||||||
|
-- | random nonce
|
||||||
|
nonce :: !Word32 -- 4 bytes
|
||||||
|
}
|
||||||
|
deriving (Eq, Ord, Show, Read, Generic, Hashable, NFData)
|
||||||
|
|
||||||
-- 80 bytes
|
-- 80 bytes
|
||||||
|
|
||||||
instance ToJSON BlockHeader where
|
instance ToJSON BlockHeader where
|
||||||
toJSON (BlockHeader v p m t b n) =
|
toJSON (BlockHeader v p m t b n) =
|
||||||
object
|
object
|
||||||
[ "version" .= v
|
[ "version" .= v,
|
||||||
, "prevblock" .= p
|
"prevblock" .= p,
|
||||||
, "merkleroot" .= encodeHex (runPutS (serialize m))
|
"merkleroot" .= encodeHex (runPutS $ serialize m),
|
||||||
, "timestamp" .= t
|
"timestamp" .= t,
|
||||||
, "bits" .= b
|
"bits" .= b,
|
||||||
, "nonce" .= n
|
"nonce" .= n
|
||||||
]
|
]
|
||||||
toEncoding (BlockHeader v p m t b n) =
|
toEncoding (BlockHeader v p m t b n) =
|
||||||
pairs
|
pairs $
|
||||||
( "version" .= v
|
mconcat
|
||||||
<> "prevblock" .= p
|
[ "version" `pair` word32 v,
|
||||||
<> "merkleroot" .= encodeHex (runPutS (serialize m))
|
"prevblock" `pair` toEncoding p,
|
||||||
<> "timestamp" .= t
|
"merkleroot" `pair` hexEncoding (runPutL $ serialize m),
|
||||||
<> "bits" .= b
|
"timestamp" `pair` toEncoding t,
|
||||||
<> "nonce" .= n
|
"bits" `pair` toEncoding b,
|
||||||
)
|
"nonce" `pair` toEncoding n
|
||||||
|
]
|
||||||
|
|
||||||
instance FromJSON BlockHeader where
|
instance FromJSON BlockHeader where
|
||||||
parseJSON =
|
parseJSON =
|
||||||
withObject "BlockHeader" $ \o ->
|
withObject "BlockHeader" $ \o ->
|
||||||
BlockHeader <$> o .: "version"
|
BlockHeader
|
||||||
<*> o .: "prevblock"
|
<$> o .: "version"
|
||||||
<*> (f =<< o .: "merkleroot")
|
<*> o .: "prevblock"
|
||||||
<*> o .: "timestamp"
|
<*> (f =<< o .: "merkleroot")
|
||||||
<*> o .: "bits"
|
<*> o .: "timestamp"
|
||||||
<*> o .: "nonce"
|
<*> o .: "bits"
|
||||||
where
|
<*> o .: "nonce"
|
||||||
f = maybe mzero return . (eitherToMaybe . runGetS deserialize <=< decodeHex)
|
where
|
||||||
|
f = maybe mzero return . (eitherToMaybe . runGetS deserialize <=< decodeHex)
|
||||||
|
|
||||||
instance Serial BlockHeader where
|
instance Serial BlockHeader where
|
||||||
deserialize = do
|
deserialize = do
|
||||||
v <- getWord32le
|
v <- getWord32le
|
||||||
p <- deserialize
|
p <- deserialize
|
||||||
m <- deserialize
|
m <- deserialize
|
||||||
t <- getWord32le
|
t <- getWord32le
|
||||||
b <- getWord32le
|
b <- getWord32le
|
||||||
n <- getWord32le
|
n <- getWord32le
|
||||||
return
|
return
|
||||||
BlockHeader
|
BlockHeader
|
||||||
{ blockVersion = v
|
{ version = v,
|
||||||
, prevBlock = p
|
prev = p,
|
||||||
, merkleRoot = m
|
merkle = m,
|
||||||
, blockTimestamp = t
|
timestamp = t,
|
||||||
, blockBits = b
|
bits = b,
|
||||||
, bhNonce = n
|
nonce = n
|
||||||
}
|
}
|
||||||
serialize (BlockHeader v p m bt bb n) = do
|
serialize (BlockHeader v p m bt bb n) = do
|
||||||
putWord32le v
|
putWord32le v
|
||||||
serialize p
|
serialize p
|
||||||
serialize m
|
serialize m
|
||||||
putWord32le bt
|
putWord32le bt
|
||||||
putWord32le bb
|
putWord32le bb
|
||||||
putWord32le n
|
putWord32le n
|
||||||
|
|
||||||
instance Binary BlockHeader where
|
instance Binary BlockHeader where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance Serialize BlockHeader where
|
instance Serialize BlockHeader where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
-- | Compute hash of 'BlockHeader'.
|
-- | Compute hash of 'BlockHeader'.
|
||||||
headerHash :: BlockHeader -> BlockHash
|
headerHash :: BlockHeader -> BlockHash
|
||||||
headerHash = BlockHash . doubleSHA256 . runPutS . serialize
|
headerHash = BlockHash . doubleSHA256 . runPutS . serialize
|
||||||
|
|
||||||
{- | A block locator is a set of block headers, denser towards the best block
|
-- | 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.
|
-- 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
|
-- 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
|
-- provided to a peer, it will send back block hashes starting from the first
|
||||||
block in the locator that it recognizes.
|
-- block in the locator that it recognizes.
|
||||||
-}
|
|
||||||
type BlockLocator = [BlockHash]
|
type BlockLocator = [BlockHash]
|
||||||
|
|
||||||
{- | Data type representing a getblocks message request. It is used in the
|
-- | Data type representing a getblocks message request. It is used in the
|
||||||
bitcoin protocol to retrieve blocks from a peer by providing it a
|
-- bitcoin protocol to retrieve blocks from a peer by providing it a
|
||||||
'BlockLocator' object. The response to a 'GetBlocks' message is an 'Inv'
|
-- '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
|
-- 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
|
-- 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
|
-- block hash, at at the tip of the chain, or after 500 entries, whichever comes
|
||||||
earlier.
|
-- earlier.
|
||||||
-}
|
|
||||||
data GetBlocks = GetBlocks
|
data GetBlocks = GetBlocks
|
||||||
{ getBlocksVersion :: !Word32
|
{ version :: !Word32,
|
||||||
, -- | block locator object
|
-- | block locator object
|
||||||
getBlocksLocator :: !BlockLocator
|
locator :: !BlockLocator,
|
||||||
, -- | hash of the last desired block
|
-- | hash of the last desired block
|
||||||
getBlocksHashStop :: !BlockHash
|
stop :: !BlockHash
|
||||||
}
|
}
|
||||||
deriving (Eq, Show, Read, Generic, NFData)
|
deriving (Eq, Show, Read, Generic, NFData)
|
||||||
|
|
||||||
instance Serial GetBlocks where
|
instance Serial GetBlocks where
|
||||||
deserialize =
|
deserialize =
|
||||||
GetBlocks
|
GetBlocks
|
||||||
<$> getWord32le
|
<$> getWord32le
|
||||||
<*> (repList =<< deserialize)
|
<*> (repList =<< deserialize)
|
||||||
<*> deserialize
|
<*> deserialize
|
||||||
where
|
where
|
||||||
repList (VarInt c) = replicateM (fromIntegral c) deserialize
|
repList (VarInt c) = replicateM (fromIntegral c) deserialize
|
||||||
serialize (GetBlocks v xs h) = putGetBlockMsg v xs h
|
serialize (GetBlocks v xs h) = do
|
||||||
|
|
||||||
instance Serialize GetBlocks where
|
|
||||||
put = serialize
|
|
||||||
get = deserialize
|
|
||||||
|
|
||||||
putGetBlockMsg :: MonadPut m => Word32 -> BlockLocator -> BlockHash -> m ()
|
|
||||||
putGetBlockMsg v xs h = do
|
|
||||||
putWord32le v
|
putWord32le v
|
||||||
putVarInt $ length xs
|
putVarInt $ length xs
|
||||||
forM_ xs serialize
|
forM_ xs serialize
|
||||||
serialize h
|
serialize h
|
||||||
|
|
||||||
{- | Similar to the 'GetBlocks' message type but for retrieving block headers
|
instance Serialize GetBlocks where
|
||||||
only. The response to a 'GetHeaders' request is a 'Headers' message
|
put = serialize
|
||||||
containing a list of block headers. A maximum of 2000 block headers can be
|
get = deserialize
|
||||||
returned. 'GetHeaders' is used by simplified payment verification (SPV)
|
|
||||||
clients to exclude block contents when synchronizing the block chain.
|
-- | 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
|
data GetHeaders = GetHeaders
|
||||||
{ getHeadersVersion :: !Word32
|
{ version :: !Word32,
|
||||||
, -- | block locator object
|
-- | block locator object
|
||||||
getHeadersBL :: !BlockLocator
|
locator :: !BlockLocator,
|
||||||
, -- | hash of the last desired block header
|
-- | hash of the last desired block header
|
||||||
getHeadersHashStop :: !BlockHash
|
stop :: !BlockHash
|
||||||
}
|
}
|
||||||
deriving (Eq, Show, Read, Generic, NFData)
|
deriving (Eq, Show, Read, Generic, NFData)
|
||||||
|
|
||||||
instance Serial GetHeaders where
|
instance Serial GetHeaders where
|
||||||
deserialize =
|
deserialize =
|
||||||
GetHeaders
|
GetHeaders
|
||||||
<$> getWord32le
|
<$> getWord32le
|
||||||
<*> (repList =<< deserialize)
|
<*> (repList =<< deserialize)
|
||||||
<*> deserialize
|
<*> deserialize
|
||||||
where
|
where
|
||||||
repList (VarInt c) = replicateM (fromIntegral c) deserialize
|
repList (VarInt c) = replicateM (fromIntegral c) deserialize
|
||||||
serialize (GetHeaders v xs h) = putGetBlockMsg v xs h
|
serialize (GetHeaders v xs h) = do
|
||||||
|
putWord32le v
|
||||||
|
putVarInt $ length xs
|
||||||
|
forM_ xs serialize
|
||||||
|
serialize h
|
||||||
|
|
||||||
instance Serialize GetHeaders where
|
instance Serialize GetHeaders where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance Binary GetHeaders where
|
instance Binary GetHeaders where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
-- | 'BlockHeader' type with a transaction count as 'VarInt'
|
-- | 'BlockHeader' type with a transaction count as 'VarInt'
|
||||||
type BlockHeaderCount = (BlockHeader, VarInt)
|
type BlockHeaderCount = (BlockHeader, VarInt)
|
||||||
|
|
||||||
{- | The 'Headers' type is used to return a list of block headers in
|
-- | The 'Headers' type is used to return a list of block headers in
|
||||||
response to a 'GetHeaders' message.
|
-- response to a 'GetHeaders' message.
|
||||||
-}
|
|
||||||
newtype Headers = Headers
|
newtype Headers = Headers
|
||||||
{ -- | list of block headers with transaction count
|
{ -- | list of block headers with transaction count
|
||||||
headersList :: [BlockHeaderCount]
|
list :: [BlockHeaderCount]
|
||||||
}
|
}
|
||||||
deriving (Eq, Show, Read, Generic, NFData)
|
deriving (Eq, Show, Read, Generic, NFData)
|
||||||
|
|
||||||
instance Serial Headers where
|
instance Serial Headers where
|
||||||
deserialize = Headers <$> (repList =<< deserialize)
|
deserialize = Headers <$> (repList =<< deserialize)
|
||||||
where
|
where
|
||||||
repList (VarInt c) = replicateM (fromIntegral c) action
|
repList (VarInt c) = replicateM (fromIntegral c) action
|
||||||
action = liftM2 (,) deserialize deserialize
|
action = liftM2 (,) deserialize deserialize
|
||||||
serialize (Headers xs) = do
|
serialize (Headers xs) = do
|
||||||
putVarInt $ length xs
|
putVarInt $ length xs
|
||||||
forM_ xs $ \(a, b) -> serialize a >> serialize b
|
forM_ xs $ \(a, b) -> serialize a >> serialize b
|
||||||
|
|
||||||
instance Serialize Headers where
|
instance Serialize Headers where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance Binary Headers where
|
instance Binary Headers where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
{- | Decode the compact number used in the difficulty target of a block.
|
-- | 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
|
-- 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
|
-- 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
|
-- 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
|
-- 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\).
|
-- mantissa. Bit number 24 represents the sign of \(N\).
|
||||||
|
--
|
||||||
\[
|
-- \[
|
||||||
N = -1^{sign} \times mantissa \times 256^{exponent-3}
|
-- N = -1^{sign} \times mantissa \times 256^{exponent-3}
|
||||||
\]
|
-- \]
|
||||||
-}
|
|
||||||
decodeCompact ::
|
decodeCompact ::
|
||||||
Word32 ->
|
Word32 ->
|
||||||
-- | true means overflow
|
-- | true means overflow
|
||||||
(Integer, Bool)
|
(Integer, Bool)
|
||||||
decodeCompact nCompact = (if neg then res * (-1) else res, over)
|
decodeCompact nCompact = (if neg then res * (-1) else res, over)
|
||||||
where
|
where
|
||||||
nSize :: Int
|
nSize :: Int
|
||||||
@ -398,23 +382,22 @@ decodeCompact nCompact = (if neg then res * (-1) else res, over)
|
|||||||
nWord' = nCompact .&. 0x007fffff
|
nWord' = nCompact .&. 0x007fffff
|
||||||
nWord :: Word32
|
nWord :: Word32
|
||||||
nWord
|
nWord
|
||||||
| nSize <= 3 = nWord' `shiftR` (8 * (3 - nSize))
|
| nSize <= 3 = nWord' `shiftR` (8 * (3 - nSize))
|
||||||
| otherwise = nWord'
|
| otherwise = nWord'
|
||||||
res :: Integer
|
res :: Integer
|
||||||
res
|
res
|
||||||
| nSize <= 3 = fromIntegral nWord
|
| nSize <= 3 = fromIntegral nWord
|
||||||
| otherwise = fromIntegral nWord `shiftL` (8 * (nSize - 3))
|
| otherwise = fromIntegral nWord `shiftL` (8 * (nSize - 3))
|
||||||
neg = nWord /= 0 && (nCompact .&. 0x00800000) /= 0
|
neg = nWord /= 0 && (nCompact .&. 0x00800000) /= 0
|
||||||
over =
|
over =
|
||||||
nWord /= 0
|
nWord /= 0
|
||||||
&& ( nSize > 34
|
&& ( nSize > 34
|
||||||
|| nWord > 0xff && nSize > 33
|
|| nWord > 0xff && nSize > 33
|
||||||
|| nWord > 0xffff && nSize > 32
|
|| nWord > 0xffff && nSize > 32
|
||||||
)
|
)
|
||||||
|
|
||||||
{- | Encode an 'Integer' to the compact number format used in the difficulty
|
-- | Encode an 'Integer' to the compact number format used in the difficulty
|
||||||
target of a block.
|
-- target of a block.
|
||||||
-}
|
|
||||||
encodeCompact :: Integer -> Word32
|
encodeCompact :: Integer -> Word32
|
||||||
encodeCompact i = nCompact
|
encodeCompact i = nCompact
|
||||||
where
|
where
|
||||||
@ -422,23 +405,23 @@ encodeCompact i = nCompact
|
|||||||
neg = i < 0
|
neg = i < 0
|
||||||
nSize' :: Int
|
nSize' :: Int
|
||||||
nSize' =
|
nSize' =
|
||||||
let f 0 = 0
|
let f 0 = 0
|
||||||
f n = 1 + f (n `shiftR` 8)
|
f n = 1 + f (n `shiftR` 8)
|
||||||
in f i'
|
in f i'
|
||||||
nCompact''' :: Word32
|
nCompact''' :: Word32
|
||||||
nCompact'''
|
nCompact'''
|
||||||
| nSize' <= 3 = fromIntegral $ (low64 .&. i') `shiftL` (8 * (3 - nSize'))
|
| nSize' <= 3 = fromIntegral $ (low64 .&. i') `shiftL` (8 * (3 - nSize'))
|
||||||
| otherwise = fromIntegral $ low64 .&. (i' `shiftR` (8 * (nSize' - 3)))
|
| otherwise = fromIntegral $ low64 .&. (i' `shiftR` (8 * (nSize' - 3)))
|
||||||
nCompact'' :: Word32
|
nCompact'' :: Word32
|
||||||
nSize :: Int
|
nSize :: Int
|
||||||
(nCompact'', nSize)
|
(nCompact'', nSize)
|
||||||
| nCompact''' .&. 0x00800000 /= 0 = (nCompact''' `shiftR` 8, nSize' + 1)
|
| nCompact''' .&. 0x00800000 /= 0 = (nCompact''' `shiftR` 8, nSize' + 1)
|
||||||
| otherwise = (nCompact''', nSize')
|
| otherwise = (nCompact''', nSize')
|
||||||
nCompact' :: Word32
|
nCompact' :: Word32
|
||||||
nCompact' = nCompact'' .|. (fromIntegral nSize `shiftL` 24)
|
nCompact' = nCompact'' .|. (fromIntegral nSize `shiftL` 24)
|
||||||
nCompact :: Word32
|
nCompact :: Word32
|
||||||
nCompact
|
nCompact
|
||||||
| neg && (nCompact' .&. 0x007fffff /= 0) = nCompact' .|. 0x00800000
|
| neg && (nCompact' .&. 0x007fffff /= 0) = nCompact' .|. 0x00800000
|
||||||
| otherwise = nCompact'
|
| otherwise = nCompact'
|
||||||
low64 :: Integer
|
low64 :: Integer
|
||||||
low64 = 0xffffffffffffffff
|
low64 = 0xffffffffffffffff
|
||||||
|
File diff suppressed because it is too large
Load Diff
@ -1,18 +1,20 @@
|
|||||||
{-# LANGUAGE DeriveAnyClass #-}
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
|
{-# LANGUAGE NoFieldSelectors #-}
|
||||||
|
|
||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Block.Merkle
|
-- Module : Haskoin.Block.Merkle
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
Function to deal with Merkle trees inside blocks.
|
-- Function to deal with Merkle trees inside blocks.
|
||||||
-}
|
module Haskoin.Block.Merkle
|
||||||
module Haskoin.Block.Merkle (
|
( -- * Merkle Blocks
|
||||||
-- * Merkle Blocks
|
|
||||||
MerkleBlock (..),
|
MerkleBlock (..),
|
||||||
MerkleRoot,
|
MerkleRoot,
|
||||||
FlagBits,
|
FlagBits,
|
||||||
@ -32,7 +34,8 @@ module Haskoin.Block.Merkle (
|
|||||||
extractMatches,
|
extractMatches,
|
||||||
splitIn,
|
splitIn,
|
||||||
boolsToWord8,
|
boolsToWord8,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.DeepSeq
|
import Control.DeepSeq
|
||||||
import Control.Monad (forM_, replicateM, when)
|
import Control.Monad (forM_, replicateM, when)
|
||||||
@ -50,8 +53,8 @@ import Data.Word (Word32, Word8)
|
|||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
import Haskoin.Block.Common
|
import Haskoin.Block.Common
|
||||||
import Haskoin.Crypto.Hash
|
import Haskoin.Crypto.Hash
|
||||||
import Haskoin.Data
|
|
||||||
import Haskoin.Network.Common
|
import Haskoin.Network.Common
|
||||||
|
import Haskoin.Network.Data
|
||||||
import Haskoin.Transaction.Common
|
import Haskoin.Transaction.Common
|
||||||
|
|
||||||
-- | Hash of the block's Merkle root.
|
-- | Hash of the block's Merkle root.
|
||||||
@ -63,53 +66,52 @@ type FlagBits = [Bool]
|
|||||||
-- | Partial Merkle tree for a filtered block.
|
-- | Partial Merkle tree for a filtered block.
|
||||||
type PartialMerkleTree = [Hash256]
|
type PartialMerkleTree = [Hash256]
|
||||||
|
|
||||||
{- | Filtered block: a block with a partial Merkle tree that only includes the
|
-- | Filtered block: a block with a partial Merkle tree that only includes the
|
||||||
transactions that pass a bloom filter that was negotiated.
|
-- transactions that pass a bloom filter that was negotiated.
|
||||||
-}
|
|
||||||
data MerkleBlock = MerkleBlock
|
data MerkleBlock = MerkleBlock
|
||||||
{ -- | block header
|
{ -- | block header
|
||||||
merkleHeader :: !BlockHeader
|
header :: !BlockHeader,
|
||||||
, -- | total number of transactions in block
|
-- | total number of transactions in block
|
||||||
merkleTotalTxns :: !Word32
|
txn :: !Word32,
|
||||||
, -- | hashes in depth-first order
|
-- | hashes in depth-first order
|
||||||
mHashes :: !PartialMerkleTree
|
hashes :: !PartialMerkleTree,
|
||||||
, -- | bits to rebuild partial merkle tree
|
-- | bits to rebuild partial merkle tree
|
||||||
mFlags :: !FlagBits
|
flags :: !FlagBits
|
||||||
}
|
}
|
||||||
deriving (Eq, Show, Read, Generic, Hashable, NFData)
|
deriving (Eq, Show, Read, Generic, Hashable, NFData)
|
||||||
|
|
||||||
instance Serial MerkleBlock where
|
instance Serial MerkleBlock where
|
||||||
deserialize = do
|
deserialize = do
|
||||||
header <- deserialize
|
header <- deserialize
|
||||||
ntx <- getWord32le
|
ntx <- getWord32le
|
||||||
(VarInt matchLen) <- deserialize
|
(VarInt matchLen) <- deserialize
|
||||||
hashes <- replicateM (fromIntegral matchLen) deserialize
|
hashes <- replicateM (fromIntegral matchLen) deserialize
|
||||||
(VarInt flagLen) <- deserialize
|
(VarInt flagLen) <- deserialize
|
||||||
ws <- replicateM (fromIntegral flagLen) getWord8
|
ws <- replicateM (fromIntegral flagLen) getWord8
|
||||||
return $ MerkleBlock header ntx hashes (decodeMerkleFlags ws)
|
return $ MerkleBlock header ntx hashes (decodeMerkleFlags ws)
|
||||||
|
|
||||||
serialize (MerkleBlock h ntx hashes flags) = do
|
serialize (MerkleBlock h ntx hashes flags) = do
|
||||||
serialize h
|
serialize h
|
||||||
putWord32le ntx
|
putWord32le ntx
|
||||||
putVarInt $ length hashes
|
putVarInt $ length hashes
|
||||||
forM_ hashes serialize
|
forM_ hashes serialize
|
||||||
let ws = encodeMerkleFlags flags
|
let ws = encodeMerkleFlags flags
|
||||||
putVarInt $ length ws
|
putVarInt $ length ws
|
||||||
forM_ ws putWord8
|
forM_ ws putWord8
|
||||||
|
|
||||||
instance Binary MerkleBlock where
|
instance Binary MerkleBlock where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance Serialize MerkleBlock where
|
instance Serialize MerkleBlock where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
-- | Unpack Merkle flags into 'FlagBits' structure.
|
-- | Unpack Merkle flags into 'FlagBits' structure.
|
||||||
decodeMerkleFlags :: [Word8] -> FlagBits
|
decodeMerkleFlags :: [Word8] -> FlagBits
|
||||||
decodeMerkleFlags ws =
|
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'.
|
-- | Pack Merkle flags from 'FlagBits'.
|
||||||
encodeMerkleFlags :: FlagBits -> [Word8]
|
encodeMerkleFlags :: FlagBits -> [Word8]
|
||||||
@ -117,33 +119,32 @@ encodeMerkleFlags bs = map boolsToWord8 $ splitIn 8 bs
|
|||||||
|
|
||||||
-- | Computes the height of a Merkle tree.
|
-- | Computes the height of a Merkle tree.
|
||||||
calcTreeHeight ::
|
calcTreeHeight ::
|
||||||
-- | number of transactions (leaf nodes)
|
-- | number of transactions (leaf nodes)
|
||||||
Int ->
|
Int ->
|
||||||
-- | height of the merkle tree
|
-- | height of the merkle tree
|
||||||
Int
|
Int
|
||||||
calcTreeHeight ntx
|
calcTreeHeight ntx
|
||||||
| ntx < 2 = 0
|
| ntx < 2 = 0
|
||||||
| even ntx = 1 + calcTreeHeight (ntx `div` 2)
|
| even ntx = 1 + calcTreeHeight (ntx `div` 2)
|
||||||
| otherwise = calcTreeHeight $ ntx + 1
|
| otherwise = calcTreeHeight $ ntx + 1
|
||||||
|
|
||||||
{- | Computes the width of a Merkle tree at a specific height. The transactions
|
-- | Computes the width of a Merkle tree at a specific height. The transactions
|
||||||
are at height 0.
|
-- are at height 0.
|
||||||
-}
|
|
||||||
calcTreeWidth ::
|
calcTreeWidth ::
|
||||||
-- | number of transactions (leaf nodes)
|
-- | number of transactions (leaf nodes)
|
||||||
Int ->
|
Int ->
|
||||||
-- | height at which we want to compute the width
|
-- | height at which we want to compute the width
|
||||||
Int ->
|
Int ->
|
||||||
-- | width of the Merkle tree
|
-- | width of the Merkle tree
|
||||||
Int
|
Int
|
||||||
calcTreeWidth ntx h = (ntx + (1 `shiftL` h) - 1) `shiftR` h
|
calcTreeWidth ntx h = (ntx + (1 `shiftL` h) - 1) `shiftR` h
|
||||||
|
|
||||||
-- | Computes the root of a Merkle tree from a list of leaf node hashes.
|
-- | Computes the root of a Merkle tree from a list of leaf node hashes.
|
||||||
buildMerkleRoot ::
|
buildMerkleRoot ::
|
||||||
-- | transaction hashes (leaf nodes)
|
-- | transaction hashes (leaf nodes)
|
||||||
[TxHash] ->
|
[TxHash] ->
|
||||||
-- | root of the Merkle tree
|
-- | root of the Merkle tree
|
||||||
MerkleRoot
|
MerkleRoot
|
||||||
buildMerkleRoot txs = calcHash (calcTreeHeight $ length txs) 0 txs
|
buildMerkleRoot txs = calcHash (calcTreeHeight $ length txs) 0 txs
|
||||||
|
|
||||||
-- | Concatenate and compute double SHA256.
|
-- | 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.
|
-- | Computes the hash of a specific node in a Merkle tree.
|
||||||
calcHash ::
|
calcHash ::
|
||||||
-- | height of the node
|
-- | height of the node
|
||||||
Int ->
|
Int ->
|
||||||
-- | position of the node (0 for the leftmost node)
|
-- | position of the node (0 for the leftmost node)
|
||||||
Int ->
|
Int ->
|
||||||
-- | transaction hashes (leaf nodes)
|
-- | transaction hashes (leaf nodes)
|
||||||
[TxHash] ->
|
[TxHash] ->
|
||||||
-- | hash of the node at the specified position
|
-- | hash of the node at the specified position
|
||||||
Hash256
|
Hash256
|
||||||
calcHash height pos txs
|
calcHash height pos txs
|
||||||
| height < 0 || pos < 0 = error "calcHash: Invalid parameters"
|
| height < 0 || pos < 0 = error "calcHash: Invalid parameters"
|
||||||
| height == 0 = getTxHash $ txs !! pos
|
| height == 0 = (txs !! pos).get
|
||||||
| otherwise = hash2 left right
|
| otherwise = hash2 left right
|
||||||
where
|
where
|
||||||
left = calcHash (height - 1) (pos * 2) txs
|
left = calcHash (height - 1) (pos * 2) txs
|
||||||
right
|
right
|
||||||
| pos * 2 + 1 < calcTreeWidth (length txs) (height - 1) =
|
| pos * 2 + 1 < calcTreeWidth (length txs) (height - 1) =
|
||||||
calcHash (height - 1) (pos * 2 + 1) txs
|
calcHash (height - 1) (pos * 2 + 1) txs
|
||||||
| otherwise = left
|
| otherwise = left
|
||||||
|
|
||||||
{- | Build a partial Merkle tree. Provide a list of tuples with all transaction
|
-- | 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
|
-- 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
|
-- partial tree. Returns a flag bits structure and the computed partial Merkle
|
||||||
tree.
|
-- tree.
|
||||||
-}
|
|
||||||
buildPartialMerkle ::
|
buildPartialMerkle ::
|
||||||
-- | transaction hash and whether to include
|
-- | transaction hash and whether to include
|
||||||
[(TxHash, Bool)] ->
|
[(TxHash, Bool)] ->
|
||||||
-- | flag bits and partial Merkle tree
|
-- | flag bits and partial Merkle tree
|
||||||
(FlagBits, PartialMerkleTree)
|
(FlagBits, PartialMerkleTree)
|
||||||
buildPartialMerkle hs = traverseAndBuild (calcTreeHeight $ length hs) 0 hs
|
buildPartialMerkle hs = traverseAndBuild (calcTreeHeight $ length hs) 0 hs
|
||||||
|
|
||||||
{- | Helper function to build partial Merkle tree. Used by 'buildPartialMerkle'
|
-- | Helper function to build partial Merkle tree. Used by 'buildPartialMerkle'
|
||||||
above.
|
-- above.
|
||||||
-}
|
|
||||||
traverseAndBuild ::
|
traverseAndBuild ::
|
||||||
Int -> Int -> [(TxHash, Bool)] -> (FlagBits, PartialMerkleTree)
|
Int -> Int -> [(TxHash, Bool)] -> (FlagBits, PartialMerkleTree)
|
||||||
traverseAndBuild height pos txs
|
traverseAndBuild height pos txs
|
||||||
| height < 0 || pos < 0 = error "traverseAndBuild: Invalid parameters"
|
| height < 0 || pos < 0 = error "traverseAndBuild: Invalid parameters"
|
||||||
| height == 0 || not match = ([match], [calcHash height pos t])
|
| height == 0 || not match = ([match], [calcHash height pos t])
|
||||||
| otherwise = (match : lb ++ rb, lh ++ rh)
|
| otherwise = (match : lb ++ rb, lh ++ rh)
|
||||||
where
|
where
|
||||||
t = map fst txs
|
t = map fst txs
|
||||||
s = pos `shiftL` height
|
s = pos `shiftL` height
|
||||||
@ -199,88 +198,86 @@ traverseAndBuild height pos txs
|
|||||||
match = any snd $ take (e - s) $ drop s txs
|
match = any snd $ take (e - s) $ drop s txs
|
||||||
(lb, lh) = traverseAndBuild (height - 1) (pos * 2) txs
|
(lb, lh) = traverseAndBuild (height - 1) (pos * 2) txs
|
||||||
(rb, rh)
|
(rb, rh)
|
||||||
| (pos * 2 + 1) < calcTreeWidth (length txs) (height - 1) =
|
| (pos * 2 + 1) < calcTreeWidth (length txs) (height - 1) =
|
||||||
traverseAndBuild (height - 1) (pos * 2 + 1) txs
|
traverseAndBuild (height - 1) (pos * 2 + 1) txs
|
||||||
| otherwise = ([], [])
|
| otherwise = ([], [])
|
||||||
|
|
||||||
-- | Helper function to extract transaction hashes from partial Merkle tree.
|
-- | Helper function to extract transaction hashes from partial Merkle tree.
|
||||||
traverseAndExtract ::
|
traverseAndExtract ::
|
||||||
Int ->
|
Int ->
|
||||||
Int ->
|
Int ->
|
||||||
Int ->
|
Int ->
|
||||||
FlagBits ->
|
FlagBits ->
|
||||||
PartialMerkleTree ->
|
PartialMerkleTree ->
|
||||||
Maybe (MerkleRoot, [TxHash], Int, Int)
|
Maybe (MerkleRoot, [TxHash], Int, Int)
|
||||||
traverseAndExtract height pos ntx flags hashes
|
traverseAndExtract height pos ntx flags hashes
|
||||||
| null flags = Nothing
|
| null flags = Nothing
|
||||||
| height == 0 || not match = leafResult
|
| height == 0 || not match = leafResult
|
||||||
| isNothing leftM = Nothing
|
| isNothing leftM = Nothing
|
||||||
| (pos * 2 + 1) >= calcTreeWidth ntx (height - 1) =
|
| (pos * 2 + 1) >= calcTreeWidth ntx (height - 1) =
|
||||||
Just (hash2 lh lh, lm, lcf + 1, lch)
|
Just (hash2 lh lh, lm, lcf + 1, lch)
|
||||||
| isNothing rightM = Nothing
|
| isNothing rightM = Nothing
|
||||||
| otherwise =
|
| otherwise =
|
||||||
Just (hash2 lh rh, lm ++ rm, lcf + rcf + 1, lch + rch)
|
Just (hash2 lh rh, lm ++ rm, lcf + rcf + 1, lch + rch)
|
||||||
where
|
where
|
||||||
leafResult
|
leafResult
|
||||||
| null hashes = Nothing
|
| null hashes = Nothing
|
||||||
| otherwise = Just (h, [TxHash h | height == 0 && match], 1, 1)
|
| otherwise = Just (h, [TxHash h | height == 0 && match], 1, 1)
|
||||||
(match : fs) = flags
|
(match : fs) = flags
|
||||||
(h : _) = hashes
|
(h : _) = hashes
|
||||||
leftM = traverseAndExtract (height - 1) (pos * 2) ntx fs hashes
|
leftM = traverseAndExtract (height - 1) (pos * 2) ntx fs hashes
|
||||||
(lh, lm, lcf, lch) = fromMaybe e leftM
|
(lh, lm, lcf, lch) = fromMaybe e leftM
|
||||||
rightM =
|
rightM =
|
||||||
traverseAndExtract
|
traverseAndExtract
|
||||||
(height - 1)
|
(height - 1)
|
||||||
(pos * 2 + 1)
|
(pos * 2 + 1)
|
||||||
ntx
|
ntx
|
||||||
(drop lcf fs)
|
(drop lcf fs)
|
||||||
(drop lch hashes)
|
(drop lch hashes)
|
||||||
(rh, rm, rcf, rch) = fromMaybe e rightM
|
(rh, rm, rcf, rch) = fromMaybe e rightM
|
||||||
e = error "traverseAndExtract: unexpected error extracting a Maybe value"
|
e = error "traverseAndExtract: unexpected error extracting a Maybe value"
|
||||||
|
|
||||||
{- | Extracts the matching hashes from a partial merkle tree. This will return
|
-- | 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
|
-- the list of transaction hashes that have been included (set to true) in
|
||||||
a call to 'buildPartialMerkle'.
|
-- a call to 'buildPartialMerkle'.
|
||||||
-}
|
|
||||||
extractMatches ::
|
extractMatches ::
|
||||||
Network ->
|
Network ->
|
||||||
FlagBits ->
|
FlagBits ->
|
||||||
PartialMerkleTree ->
|
PartialMerkleTree ->
|
||||||
-- | number of transaction at height 0 (leaf nodes)
|
-- | number of transaction at height 0 (leaf nodes)
|
||||||
Int ->
|
Int ->
|
||||||
-- | Merkle root and list of matching transaction hashes
|
-- | Merkle root and list of matching transaction hashes
|
||||||
Either String (MerkleRoot, [TxHash])
|
Either String (MerkleRoot, [TxHash])
|
||||||
extractMatches net flags hashes ntx
|
extractMatches net flags hashes ntx
|
||||||
| ntx == 0 =
|
| ntx == 0 =
|
||||||
Left
|
Left
|
||||||
"extractMatches: number of transactions can not be 0"
|
"extractMatches: number of transactions can not be 0"
|
||||||
| ntx > getMaxBlockSize net `div` 60 =
|
| ntx > net.maxBlockSize `div` 60 =
|
||||||
Left
|
Left
|
||||||
"extractMatches: number of transactions excessively high"
|
"extractMatches: number of transactions excessively high"
|
||||||
| length hashes > ntx =
|
| length hashes > ntx =
|
||||||
Left
|
Left
|
||||||
"extractMatches: More hashes provided than the number of transactions"
|
"extractMatches: More hashes provided than the number of transactions"
|
||||||
| length flags < length hashes =
|
| length flags < length hashes =
|
||||||
Left
|
Left
|
||||||
"extractMatches: At least one bit per node and one bit per hash"
|
"extractMatches: At least one bit per node and one bit per hash"
|
||||||
| isNothing resM =
|
| isNothing resM =
|
||||||
Left
|
Left
|
||||||
"extractMatches: traverseAndExtract failed"
|
"extractMatches: traverseAndExtract failed"
|
||||||
| (nBitsUsed + 7) `div` 8 /= (length flags + 7) `div` 8 =
|
| (nBitsUsed + 7) `div` 8 /= (length flags + 7) `div` 8 =
|
||||||
Left
|
Left
|
||||||
"extractMatches: All bits were not consumed"
|
"extractMatches: All bits were not consumed"
|
||||||
| nHashUsed /= length hashes =
|
| nHashUsed /= length hashes =
|
||||||
Left $
|
Left $
|
||||||
"extractMatches: All hashes were not consumed: " ++ show nHashUsed
|
"extractMatches: All hashes were not consumed: " ++ show nHashUsed
|
||||||
| otherwise = return (merkRoot, matches)
|
| otherwise = return (merkRoot, matches)
|
||||||
where
|
where
|
||||||
resM = traverseAndExtract (calcTreeHeight ntx) 0 ntx flags hashes
|
resM = traverseAndExtract (calcTreeHeight ntx) 0 ntx flags hashes
|
||||||
(merkRoot, matches, nBitsUsed, nHashUsed) = fromMaybe e resM
|
(merkRoot, matches, nBitsUsed, nHashUsed) = fromMaybe e resM
|
||||||
e = error "extractMatches: unexpected error extracting a Maybe value"
|
e = error "extractMatches: unexpected error extracting a Maybe value"
|
||||||
|
|
||||||
{- | Helper function to split a list in chunks 'Int' length. Last chunk may be
|
-- | Helper function to split a list in chunks 'Int' length. Last chunk may be
|
||||||
smaller.
|
-- smaller.
|
||||||
-}
|
|
||||||
splitIn :: Int -> [a] -> [[a]]
|
splitIn :: Int -> [a] -> [[a]]
|
||||||
splitIn _ [] = []
|
splitIn _ [] = []
|
||||||
splitIn c xs = xs1 : splitIn c xs2
|
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.
|
-- | Get matching transactions from Merkle block.
|
||||||
merkleBlockTxs :: Network -> MerkleBlock -> Either String [TxHash]
|
merkleBlockTxs :: Network -> MerkleBlock -> Either String [TxHash]
|
||||||
merkleBlockTxs net b =
|
merkleBlockTxs net b = do
|
||||||
let flags = mFlags b
|
(root, ths) <- extractMatches net b.flags b.hashes (fromIntegral b.txn)
|
||||||
hs = mHashes b
|
when (root /= b.header.merkle) $
|
||||||
n = fromIntegral $ merkleTotalTxns b
|
Left "merkleBlockTxs: Merkle root incorrect"
|
||||||
merkle = merkleRoot $ merkleHeader b
|
return ths
|
||||||
in do
|
|
||||||
(root, ths) <- extractMatches net flags hs n
|
|
||||||
when (root /= merkle) $ Left "merkleBlockTxs: Merkle root incorrect"
|
|
||||||
return ths
|
|
||||||
|
|
||||||
-- | Check if Merkle block root is valid against the block header.
|
-- | Check if Merkle block root is valid against the block header.
|
||||||
testMerkleRoot :: Network -> MerkleBlock -> Bool
|
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
|
-- Module : Haskoin.Crypto
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
Hashing functions and ECDSA signatures.
|
-- Hashing functions and ECDSA signatures.
|
||||||
-}
|
module Haskoin.Crypto
|
||||||
module Haskoin.Crypto (
|
( module Secp256k1,
|
||||||
module Hash,
|
module Hash,
|
||||||
|
module Keys,
|
||||||
module Signature,
|
module Signature,
|
||||||
module Secp256k1,
|
)
|
||||||
) where
|
where
|
||||||
|
|
||||||
import Crypto.Secp256k1 as Secp256k1
|
import Crypto.Secp256k1 as Secp256k1
|
||||||
import Haskoin.Crypto.Hash as Hash
|
import Haskoin.Crypto.Hash as Hash
|
||||||
|
import Haskoin.Crypto.Keys as Keys
|
||||||
import Haskoin.Crypto.Signature as Signature
|
import Haskoin.Crypto.Signature as Signature
|
||||||
|
@ -1,24 +1,29 @@
|
|||||||
{-# LANGUAGE DeriveAnyClass #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE DerivingStrategies #-}
|
||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE NoFieldSelectors #-}
|
||||||
|
|
||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Crypto.Hash
|
-- Module : Haskoin.Crypto.Hash
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
Hashing functions and corresponding data types. Uses functions from the
|
-- Hashing functions and corresponding data types. Uses functions from the
|
||||||
cryptonite library.
|
-- cryptonite library.
|
||||||
-}
|
module Haskoin.Crypto.Hash
|
||||||
module Haskoin.Crypto.Hash (
|
( -- * Hashes
|
||||||
-- * Hashes
|
Hash512 (get),
|
||||||
Hash512 (getHash512),
|
Hash256 (get),
|
||||||
Hash256 (getHash256),
|
Hash160 (get),
|
||||||
Hash160 (getHash160),
|
CheckSum32 (get),
|
||||||
CheckSum32 (getCheckSum32),
|
|
||||||
sha512,
|
sha512,
|
||||||
sha256,
|
sha256,
|
||||||
ripemd160,
|
ripemd160,
|
||||||
@ -31,233 +36,232 @@ module Haskoin.Crypto.Hash (
|
|||||||
split512,
|
split512,
|
||||||
join512,
|
join512,
|
||||||
initTaggedHash,
|
initTaggedHash,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.DeepSeq
|
import Control.DeepSeq
|
||||||
import Crypto.Hash (
|
import Crypto.Hash
|
||||||
Context,
|
|
||||||
RIPEMD160 (..),
|
|
||||||
SHA1 (..),
|
|
||||||
SHA256 (..),
|
|
||||||
SHA512 (..),
|
|
||||||
hashInit,
|
|
||||||
hashUpdates,
|
|
||||||
hashWith,
|
|
||||||
)
|
|
||||||
import Crypto.MAC.HMAC (HMAC, hmac)
|
import Crypto.MAC.HMAC (HMAC, hmac)
|
||||||
import Data.Binary (Binary (..))
|
import Data.Binary (Binary (..))
|
||||||
import Data.ByteArray (ByteArrayAccess)
|
import Data.ByteArray (ByteArrayAccess, convert)
|
||||||
import qualified Data.ByteArray as BA
|
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
import qualified Data.ByteString as BS
|
import Data.ByteString qualified as B
|
||||||
import Data.ByteString.Short (ShortByteString)
|
import Data.ByteString.Short (ShortByteString, fromShort, toShort)
|
||||||
import qualified Data.ByteString.Short as BSS
|
import Data.Bytes.Get
|
||||||
import qualified Data.Bytes.Get as Get
|
import Data.Bytes.Put
|
||||||
import qualified Data.Bytes.Put as Put
|
|
||||||
import Data.Bytes.Serial (Serial (..))
|
import Data.Bytes.Serial (Serial (..))
|
||||||
import Data.Either (fromRight)
|
import Data.Either (fromRight)
|
||||||
|
import Data.Function (on)
|
||||||
import Data.Hashable (Hashable)
|
import Data.Hashable (Hashable)
|
||||||
import Data.Serialize (Serialize (..))
|
import Data.Serialize (Serialize (..))
|
||||||
import Data.String (IsString, fromString)
|
import Data.String (IsString, fromString)
|
||||||
import Data.String.Conversions (cs)
|
import Data.String.Conversions (cs)
|
||||||
|
import Data.Void (Void)
|
||||||
import Data.Word (Word32)
|
import Data.Word (Word32)
|
||||||
import GHC.Generics (Generic)
|
import GHC.Generics (Generic)
|
||||||
import Haskoin.Util
|
import Haskoin.Util.Helpers
|
||||||
|
import Haskoin.Util.Marshal
|
||||||
import Text.Read as R
|
import Text.Read as R
|
||||||
|
|
||||||
-- | 'Word32' wrapped for type-safe 32-bit checksums.
|
-- | 'Word32' wrapped for type-safe 32-bit checksums.
|
||||||
newtype CheckSum32 = CheckSum32
|
newtype CheckSum32 = CheckSum32
|
||||||
{ getCheckSum32 :: Word32
|
{ get :: Word32
|
||||||
}
|
}
|
||||||
deriving (Eq, Ord, Serial, Show, Read, Hashable, Generic, NFData)
|
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
|
instance Serialize CheckSum32 where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance Binary CheckSum32 where
|
instance Binary CheckSum32 where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
-- | Type for 512-bit hashes.
|
-- | Type for 512-bit hashes.
|
||||||
newtype Hash512 = Hash512 {getHash512 :: ShortByteString}
|
newtype Hash512 = Hash512 {get :: ShortByteString}
|
||||||
deriving (Eq, Ord, Hashable, Generic, NFData)
|
deriving (Eq, Ord, Generic)
|
||||||
|
deriving newtype (Hashable, NFData)
|
||||||
|
|
||||||
-- | Type for 256-bit hashes.
|
-- | Type for 256-bit hashes.
|
||||||
newtype Hash256 = Hash256 {getHash256 :: ShortByteString}
|
newtype Hash256 = Hash256 {get :: ShortByteString}
|
||||||
deriving (Eq, Ord, Hashable, Generic, NFData)
|
deriving (Eq, Ord, Generic)
|
||||||
|
deriving newtype (Hashable, NFData)
|
||||||
|
|
||||||
-- | Type for 160-bit hashes.
|
-- | Type for 160-bit hashes.
|
||||||
newtype Hash160 = Hash160 {getHash160 :: ShortByteString}
|
newtype Hash160 = Hash160 {get :: ShortByteString}
|
||||||
deriving (Eq, Ord, Hashable, Generic, NFData)
|
deriving (Eq, Ord, Generic)
|
||||||
|
deriving newtype (Hashable, NFData)
|
||||||
|
|
||||||
instance Show Hash512 where
|
instance Show Hash512 where
|
||||||
showsPrec _ = shows . encodeHex . BSS.fromShort . getHash512
|
showsPrec _ = shows . encodeHex . fromShort . (.get)
|
||||||
|
|
||||||
instance Read Hash512 where
|
instance Read Hash512 where
|
||||||
readPrec = do
|
readPrec = do
|
||||||
R.String str <- lexP
|
R.String str <- lexP
|
||||||
maybe pfail return $ Hash512 . BSS.toShort <$> decodeHex (cs str)
|
maybe pfail (return . Hash512 . toShort) (decodeHex (cs str))
|
||||||
|
|
||||||
instance Show Hash256 where
|
instance Show Hash256 where
|
||||||
showsPrec _ = shows . encodeHex . BSS.fromShort . getHash256
|
showsPrec _ = shows . encodeHex . fromShort . (.get)
|
||||||
|
|
||||||
instance Read Hash256 where
|
instance Read Hash256 where
|
||||||
readPrec = do
|
readPrec = do
|
||||||
R.String str <- lexP
|
R.String str <- lexP
|
||||||
maybe pfail return $ Hash256 . BSS.toShort <$> decodeHex (cs str)
|
maybe pfail (return . Hash256 . toShort) (decodeHex (cs str))
|
||||||
|
|
||||||
instance Show Hash160 where
|
instance Show Hash160 where
|
||||||
showsPrec _ = shows . encodeHex . BSS.fromShort . getHash160
|
showsPrec _ = shows . encodeHex . fromShort . (.get)
|
||||||
|
|
||||||
instance Read Hash160 where
|
instance Read Hash160 where
|
||||||
readPrec = do
|
readPrec = do
|
||||||
R.String str <- lexP
|
R.String str <- lexP
|
||||||
maybe pfail return $ Hash160 . BSS.toShort <$> decodeHex (cs str)
|
maybe pfail (return . Hash160 . toShort) (decodeHex (cs str))
|
||||||
|
|
||||||
instance IsString Hash512 where
|
instance IsString Hash512 where
|
||||||
fromString str =
|
fromString str =
|
||||||
case decodeHex $ cs str of
|
case decodeHex $ cs str of
|
||||||
Nothing -> e
|
Nothing -> e
|
||||||
Just bs ->
|
Just bs ->
|
||||||
case BS.length bs of
|
case B.length bs of
|
||||||
64 -> Hash512 (BSS.toShort bs)
|
64 -> Hash512 (toShort bs)
|
||||||
_ -> e
|
_ -> e
|
||||||
where
|
where
|
||||||
e = error "Could not decode hash from hex string"
|
e = error "Could not decode hash from hex string"
|
||||||
|
|
||||||
instance Serial Hash512 where
|
instance Serial Hash512 where
|
||||||
deserialize = Hash512 . BSS.toShort <$> Get.getByteString 64
|
deserialize = Hash512 . toShort <$> getByteString 64
|
||||||
serialize = Put.putByteString . BSS.fromShort . getHash512
|
serialize = putByteString . fromShort . (.get)
|
||||||
|
|
||||||
instance Serialize Hash512 where
|
instance Serialize Hash512 where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance Binary Hash512 where
|
instance Binary Hash512 where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance IsString Hash256 where
|
instance IsString Hash256 where
|
||||||
fromString str =
|
fromString str =
|
||||||
case decodeHex $ cs str of
|
case decodeHex $ cs str of
|
||||||
Nothing -> e
|
Nothing -> e
|
||||||
Just bs ->
|
Just bs ->
|
||||||
case BS.length bs of
|
case B.length bs of
|
||||||
32 -> Hash256 (BSS.toShort bs)
|
32 -> Hash256 (toShort bs)
|
||||||
_ -> e
|
_ -> e
|
||||||
where
|
where
|
||||||
e = error "Could not decode hash from hex string"
|
e = error "Could not decode hash from hex string"
|
||||||
|
|
||||||
instance Serial Hash256 where
|
instance Serial Hash256 where
|
||||||
deserialize = Hash256 . BSS.toShort <$> Get.getByteString 32
|
deserialize = Hash256 . toShort <$> getByteString 32
|
||||||
serialize = Put.putByteString . BSS.fromShort . getHash256
|
serialize = putByteString . fromShort . (.get)
|
||||||
|
|
||||||
instance Serialize Hash256 where
|
instance Serialize Hash256 where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance Binary Hash256 where
|
instance Binary Hash256 where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance IsString Hash160 where
|
instance IsString Hash160 where
|
||||||
fromString str =
|
fromString str =
|
||||||
case decodeHex $ cs str of
|
case decodeHex $ cs str of
|
||||||
Nothing -> e
|
Nothing -> e
|
||||||
Just bs ->
|
Just bs ->
|
||||||
case BS.length bs of
|
case B.length bs of
|
||||||
20 -> Hash160 (BSS.toShort bs)
|
20 -> Hash160 (toShort bs)
|
||||||
_ -> e
|
_ -> e
|
||||||
where
|
where
|
||||||
e = error "Could not decode hash from hex string"
|
e = error "Could not decode hash from hex string"
|
||||||
|
|
||||||
instance Serial Hash160 where
|
instance Serial Hash160 where
|
||||||
deserialize = Hash160 . BSS.toShort <$> Get.getByteString 20
|
deserialize = Hash160 . toShort <$> getByteString 20
|
||||||
serialize = Put.putByteString . BSS.fromShort . getHash160
|
serialize = putByteString . fromShort . (.get)
|
||||||
|
|
||||||
instance Serialize Hash160 where
|
instance Serialize Hash160 where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance Binary Hash160 where
|
instance Binary Hash160 where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
-- | Calculate SHA512 hash.
|
-- | Calculate SHA512 hash.
|
||||||
sha512 :: ByteArrayAccess b => b -> Hash512
|
sha512 :: (ByteArrayAccess b) => b -> Hash512
|
||||||
sha512 = Hash512 . BSS.toShort . BA.convert . hashWith SHA512
|
sha512 = Hash512 . toShort . convert . hashWith SHA512
|
||||||
|
|
||||||
-- | Calculate SHA256 hash.
|
-- | Calculate SHA256 hash.
|
||||||
sha256 :: ByteArrayAccess b => b -> Hash256
|
sha256 :: (ByteArrayAccess b) => b -> Hash256
|
||||||
sha256 = Hash256 . BSS.toShort . BA.convert . hashWith SHA256
|
sha256 = Hash256 . toShort . convert . hashWith SHA256
|
||||||
|
|
||||||
-- | Calculate RIPEMD160 hash.
|
-- | Calculate RIPEMD160 hash.
|
||||||
ripemd160 :: ByteArrayAccess b => b -> Hash160
|
ripemd160 :: (ByteArrayAccess b) => b -> Hash160
|
||||||
ripemd160 = Hash160 . BSS.toShort . BA.convert . hashWith RIPEMD160
|
ripemd160 = Hash160 . toShort . convert . hashWith RIPEMD160
|
||||||
|
|
||||||
-- | Claculate SHA1 hash.
|
-- | Claculate SHA1 hash.
|
||||||
sha1 :: ByteArrayAccess b => b -> Hash160
|
sha1 :: (ByteArrayAccess b) => b -> Hash160
|
||||||
sha1 = Hash160 . BSS.toShort . BA.convert . hashWith SHA1
|
sha1 = Hash160 . toShort . convert . hashWith SHA1
|
||||||
|
|
||||||
-- | Compute two rounds of SHA-256.
|
-- | Compute two rounds of SHA-256.
|
||||||
doubleSHA256 :: ByteArrayAccess b => b -> Hash256
|
doubleSHA256 :: (ByteArrayAccess b) => b -> Hash256
|
||||||
doubleSHA256 =
|
doubleSHA256 =
|
||||||
Hash256 . BSS.toShort . BA.convert . hashWith SHA256 . hashWith SHA256
|
Hash256 . toShort . convert . hashWith SHA256 . hashWith SHA256
|
||||||
|
|
||||||
-- | Compute SHA-256 followed by RIPMED-160.
|
-- | Compute SHA-256 followed by RIPMED-160.
|
||||||
addressHash :: ByteArrayAccess b => b -> Hash160
|
addressHash :: (ByteArrayAccess b) => b -> Hash160
|
||||||
addressHash =
|
addressHash =
|
||||||
Hash160 . BSS.toShort . BA.convert . hashWith RIPEMD160 . hashWith SHA256
|
Hash160 . toShort . convert . hashWith RIPEMD160 . hashWith SHA256
|
||||||
|
|
||||||
{- CheckSum -}
|
{- CheckSum -}
|
||||||
|
|
||||||
-- | Computes a 32 bit checksum.
|
-- | Computes a 32 bit checksum.
|
||||||
checkSum32 :: ByteArrayAccess b => b -> CheckSum32
|
checkSum32 :: (ByteArrayAccess b) => b -> CheckSum32
|
||||||
checkSum32 =
|
checkSum32 =
|
||||||
fromRight (error "Could not decode bytes as CheckSum32")
|
fromRight (error "Could not decode bytes as CheckSum32")
|
||||||
. Get.runGetS deserialize
|
. runGetS deserialize
|
||||||
. BS.take 4
|
. B.take 4
|
||||||
. BA.convert
|
. convert
|
||||||
. hashWith SHA256
|
. hashWith SHA256
|
||||||
. hashWith SHA256
|
. hashWith SHA256
|
||||||
|
|
||||||
{- HMAC -}
|
{- HMAC -}
|
||||||
|
|
||||||
-- | Computes HMAC over SHA-512.
|
-- | Computes HMAC over SHA-512.
|
||||||
hmac512 :: ByteString -> ByteString -> Hash512
|
hmac512 :: ByteString -> ByteString -> Hash512
|
||||||
hmac512 key msg =
|
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.
|
-- | Computes HMAC over SHA-256.
|
||||||
hmac256 :: (ByteArrayAccess k, ByteArrayAccess m) => k -> m -> Hash256
|
hmac256 :: (ByteArrayAccess k, ByteArrayAccess m) => k -> m -> Hash256
|
||||||
hmac256 key msg =
|
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'.
|
-- | Split a 'Hash512' into a pair of 'Hash256'.
|
||||||
split512 :: Hash512 -> (Hash256, Hash256)
|
split512 :: Hash512 -> (Hash256, Hash256)
|
||||||
split512 h =
|
split512 h =
|
||||||
(Hash256 (BSS.toShort a), Hash256 (BSS.toShort b))
|
(Hash256 (toShort a), Hash256 (toShort b))
|
||||||
where
|
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'.
|
-- | Join a pair of 'Hash256' into a 'Hash512'.
|
||||||
join512 :: (Hash256, Hash256) -> Hash512
|
join512 :: (Hash256, Hash256) -> Hash512
|
||||||
join512 (a, b) =
|
join512 (a, b) = Hash512 (toShort (a.get `app` b.get))
|
||||||
Hash512
|
where
|
||||||
. BSS.toShort
|
app = B.append `on` fromShort
|
||||||
$ BSS.fromShort (getHash256 a) `BS.append` BSS.fromShort (getHash256 b)
|
|
||||||
|
|
||||||
{- | Initialize tagged hash specified in BIP340
|
-- | Initialize tagged hash specified in BIP340
|
||||||
|
--
|
||||||
@since 0.21.0
|
-- @since 0.21.0
|
||||||
-}
|
|
||||||
initTaggedHash ::
|
initTaggedHash ::
|
||||||
-- | Hash tag
|
-- | Hash tag
|
||||||
ByteString ->
|
ByteString ->
|
||||||
Context SHA256
|
Context SHA256
|
||||||
initTaggedHash tag =
|
initTaggedHash tag =
|
||||||
(`hashUpdates` [hashedTag, hashedTag]) $
|
(`hashUpdates` [hashedTag, hashedTag]) $
|
||||||
hashInit @SHA256
|
hashInit @SHA256
|
||||||
where
|
where
|
||||||
hashedTag = hashWith SHA256 tag
|
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 #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Crypto.Signature
|
-- Module : Haskoin.Crypto.Signature
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
ECDSA signatures using secp256k1 curve. Uses functions from upstream secp256k1
|
-- ECDSA signatures using secp256k1 curve. Uses functions from upstream secp256k1
|
||||||
library.
|
-- library.
|
||||||
-}
|
module Haskoin.Crypto.Signature
|
||||||
module Haskoin.Crypto.Signature (
|
( -- * Signatures
|
||||||
-- * Signatures
|
|
||||||
putSig,
|
|
||||||
getSig,
|
|
||||||
signHash,
|
signHash,
|
||||||
verifyHashSig,
|
verifyHashSig,
|
||||||
isCanonicalHalfOrder,
|
isCanonicalHalfOrder,
|
||||||
decodeStrictSig,
|
decodeStrictSig,
|
||||||
exportSig,
|
exportSig,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Monad (guard, unless, when)
|
import Control.Monad (guard, unless, when)
|
||||||
import Crypto.Secp256k1
|
import Crypto.Secp256k1
|
||||||
|
import Data.Aeson
|
||||||
|
import Data.Aeson.Encoding
|
||||||
import Data.Binary (Binary (..))
|
import Data.Binary (Binary (..))
|
||||||
import Data.ByteString (ByteString)
|
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.Get
|
||||||
import Data.Bytes.Put
|
import Data.Bytes.Put
|
||||||
import Data.Bytes.Serial
|
import Data.Bytes.Serial
|
||||||
import Data.Maybe (fromMaybe, isNothing)
|
import Data.Maybe (fromMaybe, isNothing)
|
||||||
import Data.Serialize (Serialize (..))
|
import Data.Serialize (Serialize (..))
|
||||||
|
import Data.Text qualified as T
|
||||||
import Haskoin.Crypto.Hash
|
import Haskoin.Crypto.Hash
|
||||||
|
import Haskoin.Util.Helpers
|
||||||
|
import Haskoin.Util.Marshal
|
||||||
import Numeric (showHex)
|
import Numeric (showHex)
|
||||||
|
|
||||||
-- | Convert 256-bit hash into a 'Msg' for signing or verification.
|
-- | Convert 256-bit hash into a 'Msg' for signing or verification.
|
||||||
hashToMsg :: Hash256 -> Msg
|
hashToMsg :: Hash256 -> Msg
|
||||||
hashToMsg =
|
hashToMsg =
|
||||||
fromMaybe e . msg . runPutS . serialize
|
fromMaybe e . msg . runPutS . serialize
|
||||||
where
|
where
|
||||||
e = error "Could not convert 32-byte hash to secp256k1 message"
|
e = error "Could not convert 32-byte hash to secp256k1 message"
|
||||||
|
|
||||||
-- | Sign a 256-bit hash using secp256k1 elliptic curve.
|
-- | Sign a 256-bit hash using secp256k1 elliptic curve.
|
||||||
signHash :: SecKey -> Hash256 -> Sig
|
signHash :: Ctx -> SecKey -> Hash256 -> Sig
|
||||||
signHash k = signMsg k . hashToMsg
|
signHash ctx k = signMsg ctx k . hashToMsg
|
||||||
|
|
||||||
-- | Verify an ECDSA signature for a 256-bit hash.
|
-- | Verify an ECDSA signature for a 256-bit hash.
|
||||||
verifyHashSig :: Hash256 -> Sig -> PubKey -> Bool
|
verifyHashSig :: Ctx -> Hash256 -> Sig -> PubKey -> Bool
|
||||||
verifyHashSig h s p = verifySig p norm (hashToMsg h)
|
verifyHashSig ctx h s p = verifySig ctx p norm (hashToMsg h)
|
||||||
where
|
where
|
||||||
norm = fromMaybe s (normalizeSig s)
|
norm = fromMaybe s (normalizeSig ctx s)
|
||||||
|
|
||||||
-- | Deserialize an ECDSA signature as commonly encoded in Bitcoin.
|
instance Marshal Ctx Sig where
|
||||||
getSig :: MonadGet m => m Sig
|
marshalGet ctx = do
|
||||||
getSig = do
|
l <- lookAhead $ do
|
||||||
l <-
|
t <- getWord8
|
||||||
lookAhead $ do
|
-- 0x30 is DER sequence type
|
||||||
t <- getWord8
|
unless (t == 0x30) $
|
||||||
-- 0x30 is DER sequence type
|
fail $
|
||||||
unless (t == 0x30) $
|
"Bad DER identifier byte 0x" ++ showHex t ". Expecting 0x30"
|
||||||
fail $
|
l <- getWord8
|
||||||
"Bad DER identifier byte 0x" ++ showHex t ". Expecting 0x30"
|
when (l == 0x00) $ fail "Indeterminate form unsupported"
|
||||||
l <- getWord8
|
when (l >= 0x80) $ fail "Multi-octect length not supported"
|
||||||
when (l == 0x00) $ fail "Indeterminate form unsupported"
|
return $ fromIntegral l
|
||||||
when (l >= 0x80) $ fail "Multi-octect length not supported"
|
|
||||||
return $ fromIntegral l
|
|
||||||
bs <- getByteString $ l + 2
|
bs <- getByteString $ l + 2
|
||||||
case decodeStrictSig bs of
|
case decodeStrictSig ctx bs of
|
||||||
Just s -> return s
|
Just s -> return s
|
||||||
Nothing -> fail "Invalid signature"
|
Nothing -> fail "Invalid signature"
|
||||||
|
|
||||||
-- | Serialize an ECDSA signature for Bitcoin use.
|
marshalPut ctx s = putByteString $ exportSig ctx s
|
||||||
putSig :: MonadPut m => Sig -> m ()
|
|
||||||
putSig s = putByteString $ exportSig 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.
|
-- | Is canonical half order.
|
||||||
isCanonicalHalfOrder :: Sig -> Bool
|
isCanonicalHalfOrder :: Ctx -> Sig -> Bool
|
||||||
isCanonicalHalfOrder = isNothing . normalizeSig
|
isCanonicalHalfOrder ctx = isNothing . normalizeSig ctx
|
||||||
|
|
||||||
-- | Decode signature strictly.
|
-- | Decode signature strictly.
|
||||||
decodeStrictSig :: ByteString -> Maybe Sig
|
decodeStrictSig :: Ctx -> ByteString -> Maybe Sig
|
||||||
decodeStrictSig bs = do
|
decodeStrictSig ctx bs = do
|
||||||
g <- importSig bs
|
g <- importSig ctx bs
|
||||||
-- <http://www.secg.org/sec1-v2.pdf Section 4.1.4>
|
-- <http://www.secg.org/sec1-v2.pdf Section 4.1.4>
|
||||||
-- 4.1.4.1 (r and s can not be zero)
|
-- 4.1.4.1 (r and s can not be zero)
|
||||||
let compact = exportCompactSig g
|
let compact = exportCompactSig ctx g
|
||||||
let zero = BS.replicate 32 0
|
let zero = B.replicate 32 0
|
||||||
guard $ BS.take 32 (getCompactSig compact) /= zero
|
guard $ B.take 32 compact.get /= zero
|
||||||
guard $ BS.take 32 (BS.drop 32 (getCompactSig compact)) /= zero
|
guard $ (B.take 32 . B.drop 32) compact.get /= zero
|
||||||
guard $ isCanonicalHalfOrder g
|
guard $ isCanonicalHalfOrder ctx g
|
||||||
return 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
|
-- Module : Haskoin.Network
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
This module provides basic types used for the Bitcoin networking protocol
|
-- This module provides basic types used for the Bitcoin networking protocol
|
||||||
together with 'Data.Serialize' instances for efficiently serializing and
|
-- together with 'Data.Serialize' instances for efficiently serializing and
|
||||||
de-serializing them.
|
-- de-serializing them.
|
||||||
-}
|
module Haskoin.Network
|
||||||
module Haskoin.Network (
|
( module Data,
|
||||||
|
module Constants,
|
||||||
module Common,
|
module Common,
|
||||||
module Message,
|
module Message,
|
||||||
module Bloom,
|
module Bloom,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Haskoin.Network.Bloom as Bloom
|
import Haskoin.Network.Bloom as Bloom
|
||||||
import Haskoin.Network.Common as Common
|
import Haskoin.Network.Common as Common
|
||||||
|
import Haskoin.Network.Constants as Constants
|
||||||
|
import Haskoin.Network.Data as Data
|
||||||
import Haskoin.Network.Message as Message
|
import Haskoin.Network.Message as Message
|
||||||
|
@ -1,21 +1,27 @@
|
|||||||
{-# LANGUAGE DeriveAnyClass #-}
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE DerivingStrategies #-}
|
||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE NoFieldSelectors #-}
|
||||||
|
|
||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Network.Bloom
|
-- Module : Haskoin.Network.Bloom
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
Bloom filters are used to reduce data transfer when synchronizing thin cients.
|
-- 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
|
-- When bloom filters are used a client will obtain filtered blocks that only
|
||||||
contain transactions that pass the bloom filter. Transactions announced via inv
|
-- contain transactions that pass the bloom filter. Transactions announced via inv
|
||||||
messages also pass the filter.
|
-- messages also pass the filter.
|
||||||
-}
|
module Haskoin.Network.Bloom
|
||||||
module Haskoin.Network.Bloom (
|
( -- * Bloom Filters
|
||||||
-- * Bloom Filters
|
|
||||||
BloomFlags (..),
|
BloomFlags (..),
|
||||||
BloomFilter (..),
|
BloomFilter (..),
|
||||||
FilterLoad (..),
|
FilterLoad (..),
|
||||||
@ -28,27 +34,30 @@ module Haskoin.Network.Bloom (
|
|||||||
isBloomFull,
|
isBloomFull,
|
||||||
acceptsFilters,
|
acceptsFilters,
|
||||||
bloomRelevantUpdate,
|
bloomRelevantUpdate,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.DeepSeq
|
import Control.DeepSeq
|
||||||
import Control.Monad (forM_, replicateM)
|
import Control.Monad (forM_, replicateM)
|
||||||
|
import Crypto.Secp256k1 (Ctx)
|
||||||
import Data.Binary (Binary (..))
|
import Data.Binary (Binary (..))
|
||||||
import Data.Bits
|
import Data.Bits
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
import qualified Data.ByteString as BS
|
import Data.ByteString qualified as BS
|
||||||
import Data.Bytes.Get
|
import Data.Bytes.Get
|
||||||
import Data.Bytes.Put
|
import Data.Bytes.Put
|
||||||
import Data.Bytes.Serial
|
import Data.Bytes.Serial
|
||||||
import qualified Data.Foldable as F
|
import Data.Foldable qualified as F
|
||||||
import Data.Hash.Murmur (murmur3)
|
import Data.Hash.Murmur (murmur3)
|
||||||
import Data.List (foldl')
|
import Data.List (foldl')
|
||||||
import qualified Data.Sequence as S
|
import Data.Sequence qualified as S
|
||||||
import Data.Serialize (Serialize (..))
|
import Data.Serialize (Serialize (..))
|
||||||
import Data.Word
|
import Data.Word
|
||||||
import GHC.Generics (Generic)
|
import GHC.Generics (Generic)
|
||||||
import Haskoin.Network.Common
|
import Haskoin.Network.Common
|
||||||
import Haskoin.Script.Standard
|
import Haskoin.Script.Standard
|
||||||
import Haskoin.Transaction.Common
|
import Haskoin.Transaction.Common
|
||||||
|
import Haskoin.Util.Marshal
|
||||||
|
|
||||||
-- | 20,000 items with fp rate < 0.1% or 10,000 items and <0.0001%
|
-- | 20,000 items with fp rate < 0.1% or 10,000 items and <0.0001%
|
||||||
maxBloomSize :: Int
|
maxBloomSize :: Int
|
||||||
@ -66,139 +75,137 @@ ln2 = 0.6931471805599453094172321214581765680755001343602552
|
|||||||
bitMask :: [Word8]
|
bitMask :: [Word8]
|
||||||
bitMask = [0x01, 0x02, 0x04, 0x08, 0x10, 0x20, 0x40, 0x80]
|
bitMask = [0x01, 0x02, 0x04, 0x08, 0x10, 0x20, 0x40, 0x80]
|
||||||
|
|
||||||
{- | The bloom flags are used to tell the remote peer how to auto-update
|
-- | The bloom flags are used to tell the remote peer how to auto-update
|
||||||
the provided bloom filter.
|
-- the provided bloom filter.
|
||||||
-}
|
|
||||||
data BloomFlags
|
data BloomFlags
|
||||||
= -- | never update
|
= -- | never update
|
||||||
BloomUpdateNone
|
BloomUpdateNone
|
||||||
| -- | auto-update on all outputs
|
| -- | auto-update on all outputs
|
||||||
BloomUpdateAll
|
BloomUpdateAll
|
||||||
| -- | auto-update on pay-to-pubkey or pay-to-multisig (default)
|
| -- | auto-update on pay-to-pubkey or pay-to-multisig (default)
|
||||||
BloomUpdateP2PubKeyOnly
|
BloomUpdateP2PubKeyOnly
|
||||||
deriving (Eq, Show, Read, Generic, NFData)
|
deriving (Eq, Show, Read, Generic, NFData)
|
||||||
|
|
||||||
instance Serial BloomFlags where
|
instance Serial BloomFlags where
|
||||||
deserialize = go =<< getWord8
|
deserialize = go =<< getWord8
|
||||||
where
|
where
|
||||||
go 0 = return BloomUpdateNone
|
go 0 = return BloomUpdateNone
|
||||||
go 1 = return BloomUpdateAll
|
go 1 = return BloomUpdateAll
|
||||||
go 2 = return BloomUpdateP2PubKeyOnly
|
go 2 = return BloomUpdateP2PubKeyOnly
|
||||||
go _ = fail "BloomFlags get: Invalid bloom flag"
|
go _ = fail "BloomFlags get: Invalid bloom flag"
|
||||||
|
|
||||||
serialize f = putWord8 $ case f of
|
serialize f = putWord8 $ case f of
|
||||||
BloomUpdateNone -> 0
|
BloomUpdateNone -> 0
|
||||||
BloomUpdateAll -> 1
|
BloomUpdateAll -> 1
|
||||||
BloomUpdateP2PubKeyOnly -> 2
|
BloomUpdateP2PubKeyOnly -> 2
|
||||||
|
|
||||||
instance Binary BloomFlags where
|
instance Binary BloomFlags where
|
||||||
get = deserialize
|
get = deserialize
|
||||||
put = serialize
|
put = serialize
|
||||||
|
|
||||||
instance Serialize BloomFlags where
|
instance Serialize BloomFlags where
|
||||||
get = deserialize
|
get = deserialize
|
||||||
put = serialize
|
put = serialize
|
||||||
|
|
||||||
{- | A bloom filter is a probabilistic data structure that SPV clients send to
|
-- | 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
|
-- other peers to filter the set of transactions received from them. Bloom
|
||||||
filters can have false positives but not false negatives. Some transactions
|
-- filters can have false positives but not false negatives. Some transactions
|
||||||
that pass the filter may not be relevant to the receiving peer. By
|
-- that pass the filter may not be relevant to the receiving peer. By
|
||||||
controlling the false positive rate, SPV nodes can trade off bandwidth
|
-- controlling the false positive rate, SPV nodes can trade off bandwidth
|
||||||
versus privacy.
|
-- versus privacy.
|
||||||
-}
|
|
||||||
data BloomFilter = BloomFilter
|
data BloomFilter = BloomFilter
|
||||||
{ -- | bloom filter data
|
{ -- | bloom filter data
|
||||||
bloomData :: !(S.Seq Word8)
|
array :: !(S.Seq Word8),
|
||||||
, -- | number of hash functions for this filter
|
-- | number of hash functions for this filter
|
||||||
bloomHashFuncs :: !Word32
|
functions :: !Word32,
|
||||||
, -- | hash function random nonce
|
-- | hash function random nonce
|
||||||
bloomTweak :: !Word32
|
tweak :: !Word32,
|
||||||
, -- | bloom filter auto-update flags
|
-- | bloom filter auto-update flags
|
||||||
bloomFlags :: !BloomFlags
|
flags :: !BloomFlags
|
||||||
}
|
}
|
||||||
deriving (Eq, Show, Read, Generic, NFData)
|
deriving (Eq, Show, Read, Generic, NFData)
|
||||||
|
|
||||||
instance Serial BloomFilter where
|
instance Serial BloomFilter where
|
||||||
deserialize =
|
deserialize =
|
||||||
BloomFilter
|
BloomFilter
|
||||||
<$> (S.fromList <$> (readDat =<< deserialize))
|
<$> (S.fromList <$> (readDat =<< deserialize))
|
||||||
<*> getWord32le
|
<*> getWord32le
|
||||||
<*> getWord32le
|
<*> getWord32le
|
||||||
<*> deserialize
|
<*> deserialize
|
||||||
where
|
where
|
||||||
readDat (VarInt len) = replicateM (fromIntegral len) getWord8
|
readDat (VarInt len) = replicateM (fromIntegral len) getWord8
|
||||||
|
|
||||||
serialize (BloomFilter dat hashFuncs tweak flags) = do
|
serialize BloomFilter {..} = do
|
||||||
putVarInt $ S.length dat
|
putVarInt $ S.length array
|
||||||
forM_ (F.toList dat) putWord8
|
mapM_ putWord8 (F.toList array)
|
||||||
putWord32le hashFuncs
|
putWord32le functions
|
||||||
putWord32le tweak
|
putWord32le tweak
|
||||||
serialize flags
|
serialize flags
|
||||||
|
|
||||||
instance Binary BloomFilter where
|
instance Binary BloomFilter where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance Serialize BloomFilter where
|
instance Serialize BloomFilter where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
-- | Set a new bloom filter on the peer connection.
|
-- | Set a new bloom filter on the peer connection.
|
||||||
newtype FilterLoad = FilterLoad {filterLoadBloomFilter :: BloomFilter}
|
newtype FilterLoad = FilterLoad {filter :: BloomFilter}
|
||||||
deriving (Eq, Show, Read, Generic, NFData)
|
deriving (Eq, Show, Read, Generic)
|
||||||
|
deriving newtype (NFData)
|
||||||
|
|
||||||
instance Serial FilterLoad where
|
instance Serial FilterLoad where
|
||||||
deserialize = FilterLoad <$> deserialize
|
deserialize = FilterLoad <$> deserialize
|
||||||
serialize (FilterLoad f) = serialize f
|
serialize (FilterLoad f) = serialize f
|
||||||
|
|
||||||
instance Binary FilterLoad where
|
instance Binary FilterLoad where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance Serialize FilterLoad where
|
instance Serialize FilterLoad where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
{- | Add the given data element to the connections current filter without
|
-- | Add the given data element to the connections current filter without
|
||||||
requiring a completely new one to be set.
|
-- requiring a completely new one to be set.
|
||||||
-}
|
newtype FilterAdd = FilterAdd {get :: ByteString}
|
||||||
newtype FilterAdd = FilterAdd {getFilterData :: ByteString}
|
deriving (Eq, Show, Read, Generic)
|
||||||
deriving (Eq, Show, Read, Generic, NFData)
|
deriving newtype (NFData)
|
||||||
|
|
||||||
instance Serial FilterAdd where
|
instance Serial FilterAdd where
|
||||||
deserialize = do
|
deserialize = do
|
||||||
(VarInt len) <- deserialize
|
(VarInt len) <- deserialize
|
||||||
dat <- getByteString $ fromIntegral len
|
dat <- getByteString $ fromIntegral len
|
||||||
return $ FilterAdd dat
|
return $ FilterAdd dat
|
||||||
|
|
||||||
serialize (FilterAdd bs) = do
|
serialize (FilterAdd bs) = do
|
||||||
putVarInt $ BS.length bs
|
putVarInt $ BS.length bs
|
||||||
putByteString bs
|
putByteString bs
|
||||||
|
|
||||||
instance Binary FilterAdd where
|
instance Binary FilterAdd where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance Serialize FilterAdd where
|
instance Serialize FilterAdd where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
{- | Build a bloom filter that will provide the given false positive rate when
|
-- | Build a bloom filter that will provide the given false positive rate when
|
||||||
the given number of elements have been inserted.
|
-- the given number of elements have been inserted.
|
||||||
-}
|
|
||||||
bloomCreate ::
|
bloomCreate ::
|
||||||
-- | number of elements
|
-- | number of elements
|
||||||
Int ->
|
Int ->
|
||||||
-- | false positive rate
|
-- | false positive rate
|
||||||
Double ->
|
Double ->
|
||||||
-- | random nonce (tweak) for the hash function
|
-- | random nonce (tweak) for the hash function
|
||||||
Word32 ->
|
Word32 ->
|
||||||
-- | bloom filter flags
|
-- | bloom filter flags
|
||||||
BloomFlags ->
|
BloomFlags ->
|
||||||
-- | bloom filter
|
-- | bloom filter
|
||||||
BloomFilter
|
BloomFilter
|
||||||
bloomCreate numElem fpRate =
|
bloomCreate numElem fpRate =
|
||||||
BloomFilter (S.replicate bloomSize 0) numHashF
|
BloomFilter (S.replicate bloomSize 0) numHashF
|
||||||
where
|
where
|
||||||
-- Bloom filter size in bytes
|
-- Bloom filter size in bytes
|
||||||
bloomSize = truncate $ min a b / 8
|
bloomSize = truncate $ min a b / 8
|
||||||
@ -211,117 +218,127 @@ bloomCreate numElem fpRate =
|
|||||||
c = fromIntegral bloomSize * 8 / fromIntegral numElem * ln2
|
c = fromIntegral bloomSize * 8 / fromIntegral numElem * ln2
|
||||||
|
|
||||||
bloomHash :: BloomFilter -> Word32 -> ByteString -> Word32
|
bloomHash :: BloomFilter -> Word32 -> ByteString -> Word32
|
||||||
bloomHash bfilter hashNum bs =
|
bloomHash b hashNum bs =
|
||||||
murmur3 seed bs `mod` (fromIntegral (S.length (bloomData bfilter)) * 8)
|
murmur3 seed bs `mod` (fromIntegral (S.length (b.array)) * 8)
|
||||||
where
|
where
|
||||||
seed = hashNum * 0xfba4c795 + bloomTweak bfilter
|
seed = hashNum * 0xfba4c795 + b.tweak
|
||||||
|
|
||||||
{- | Insert arbitrary data into a bloom filter. Returns the new bloom filter
|
-- | Insert arbitrary data into a bloom filter. Returns the new bloom filter
|
||||||
containing the new data.
|
-- containing the new data.
|
||||||
-}
|
|
||||||
bloomInsert ::
|
bloomInsert ::
|
||||||
-- | Original bloom filter
|
-- | Original bloom filter
|
||||||
BloomFilter ->
|
BloomFilter ->
|
||||||
-- | New data to insert
|
-- | New data to insert
|
||||||
ByteString ->
|
ByteString ->
|
||||||
-- | Bloom filter containing the new data
|
-- | Bloom filter containing the new data
|
||||||
BloomFilter
|
BloomFilter
|
||||||
bloomInsert bfilter bs
|
bloomInsert b bs
|
||||||
| isBloomFull bfilter = bfilter
|
| isBloomFull b = b
|
||||||
| otherwise = bfilter{bloomData = newData}
|
| otherwise = b {array = dat}
|
||||||
where
|
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 =
|
upd s i =
|
||||||
S.adjust
|
S.adjust
|
||||||
(.|. bitMask !! fromIntegral (7 .&. i))
|
(.|. bitMask !! fromIntegral (7 .&. i))
|
||||||
(fromIntegral $ i `shiftR` 3)
|
(fromIntegral $ i `shiftR` 3)
|
||||||
s
|
s
|
||||||
newData = foldl upd (bloomData bfilter) idxs
|
dat = foldl upd b.array idxs
|
||||||
|
|
||||||
{- | Tests if some arbitrary data matches the filter. This can be either because
|
-- | 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.
|
-- the data was inserted into the filter or because it is a false positive.
|
||||||
-}
|
|
||||||
bloomContains ::
|
bloomContains ::
|
||||||
-- | Bloom filter
|
-- | Bloom filter
|
||||||
BloomFilter ->
|
BloomFilter ->
|
||||||
-- | Data that will be checked against the given bloom filter
|
-- | Data that will be checked against the given bloom filter
|
||||||
ByteString ->
|
ByteString ->
|
||||||
-- | Returns True if the data matches the filter
|
-- | Returns True if the data matches the filter
|
||||||
Bool
|
Bool
|
||||||
bloomContains bfilter bs
|
bloomContains b bs
|
||||||
| isBloomFull bfilter = True
|
| isBloomFull b = True
|
||||||
| isBloomEmpty bfilter = False
|
| isBloomEmpty b = False
|
||||||
| otherwise = all isSet idxs
|
| otherwise = all isSet idxs
|
||||||
where
|
where
|
||||||
s = bloomData bfilter
|
s = b.array
|
||||||
idxs = map (\i -> bloomHash bfilter i bs) [0 .. bloomHashFuncs bfilter - 1]
|
idxs = map (\i -> bloomHash b i bs) [0 .. b.functions - 1]
|
||||||
isSet i =
|
isSet i =
|
||||||
S.index s (fromIntegral $ i `shiftR` 3)
|
S.index s (fromIntegral $ i `shiftR` 3)
|
||||||
.&. (bitMask !! fromIntegral (7 .&. i)) /= 0
|
.&. (bitMask !! fromIntegral (7 .&. i))
|
||||||
|
/= 0
|
||||||
|
|
||||||
{- | Checks if any of the outputs of a tx is in the current bloom filter.
|
-- | 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
|
-- 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).
|
-- a future tx that spends the output won't be missed).
|
||||||
-}
|
|
||||||
bloomRelevantUpdate ::
|
bloomRelevantUpdate ::
|
||||||
-- | Bloom filter
|
Ctx ->
|
||||||
BloomFilter ->
|
-- | Bloom filter
|
||||||
-- | Tx that may (or may not) have relevant outputs
|
BloomFilter ->
|
||||||
Tx ->
|
-- | Tx that may (or may not) have relevant outputs
|
||||||
-- | Returns an updated bloom filter adding relevant output
|
Tx ->
|
||||||
Maybe BloomFilter
|
-- | Returns an updated bloom filter adding relevant output
|
||||||
bloomRelevantUpdate bfilter tx
|
Maybe BloomFilter
|
||||||
| isBloomFull bfilter || isBloomEmpty bfilter = Nothing
|
bloomRelevantUpdate ctx b tx
|
||||||
| bloomFlags bfilter == BloomUpdateNone = Nothing
|
| isBloomFull b || isBloomEmpty b = Nothing
|
||||||
| not (null matchOuts) = Just $ foldl' addRelevant bfilter matchOuts
|
| b.flags == BloomUpdateNone = Nothing
|
||||||
| otherwise = Nothing
|
| not (null matchOuts) = Just $ foldl' addRelevant b matchOuts
|
||||||
|
| otherwise = Nothing
|
||||||
where
|
where
|
||||||
-- TxHash if we end up inserting an outpoint
|
-- TxHash if we end up inserting an outpoint
|
||||||
|
|
||||||
h = txHash tx
|
h = txHash tx
|
||||||
-- Decode the scriptOutpus and add vOuts in case we make them outpoints
|
-- 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"
|
err = error "Error Decoding output script"
|
||||||
idxOutputScripts = either (const err) (zip [0 ..]) decodedOutputScripts
|
idxOutputScripts = either (const err) (zip [0 ..]) decodedOutputScripts
|
||||||
-- Check if any txOuts were contained in the bloom filter
|
-- Check if any txOuts were contained in the bloom filter
|
||||||
matchFilter =
|
matchFilter =
|
||||||
filter (\(_, op) -> bloomContains bfilter $ encodeScriptOut op)
|
filter (\(_, op) -> any (bloomContains b) (encodeScriptOut op))
|
||||||
matchOuts = matchFilter idxOutputScripts
|
matchOuts = matchFilter idxOutputScripts
|
||||||
addRelevant :: BloomFilter -> (Word32, ScriptOutput) -> BloomFilter
|
addRelevant :: BloomFilter -> (Word32, ScriptOutput) -> BloomFilter
|
||||||
addRelevant bf (id', scriptOut) =
|
addRelevant bf (id', scriptOut) =
|
||||||
case (bloomFlags bfilter, scriptType) of
|
case (b.flags, scriptType) of
|
||||||
-- We filtered out BloomUpdateNone so we insert any PayPk or PayMulSig
|
-- We filtered out BloomUpdateNone so we insert any PayPk or PayMulSig
|
||||||
|
|
||||||
(_, True) -> bloomInsert bf outpoint
|
(_, True) -> bloomInsert bf outpoint
|
||||||
(BloomUpdateAll, _) -> bloomInsert bf outpoint
|
(BloomUpdateAll, _) -> bloomInsert bf outpoint
|
||||||
_ -> error "Error Updating Bloom Filter with relevant outpoint"
|
_ -> error "Error Updating Bloom Filter with relevant outpoint"
|
||||||
where
|
where
|
||||||
outpoint = runPutS $ serialize $ OutPoint{outPointHash = h, outPointIndex = id'}
|
outpoint = runPutS $ serialize $ OutPoint {hash = h, index = id'}
|
||||||
scriptType = (\s -> isPayPK s || isPayMulSig s) scriptOut
|
scriptType = (\s -> isPayPK s || isPayMulSig s) scriptOut
|
||||||
-- Encodes a scriptOutput so it can be checked agains the Bloom Filter
|
-- Encodes a scriptOutput so it can be checked agains the Bloom Filter
|
||||||
encodeScriptOut :: ScriptOutput -> ByteString
|
encodeScriptOut :: ScriptOutput -> [ByteString]
|
||||||
encodeScriptOut (PayMulSig outputMuSig _) = runPutS $ serialize outputMuSig
|
encodeScriptOut (PayPK pk) =
|
||||||
encodeScriptOut (PayWitnessScriptHash scriptHash) = runPutS $ serialize scriptHash
|
return $ marshal ctx pk
|
||||||
encodeScriptOut (DataCarrier getOutputDat) = runPutS $ serialize getOutputDat
|
encodeScriptOut (PayPKHash ph) =
|
||||||
encodeScriptOut outputHash = (runPutS . serialize . getOutputHash) outputHash
|
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)
|
-- | Returns True if the filter is empty (all bytes set to 0x00)
|
||||||
isBloomEmpty :: BloomFilter -> Bool
|
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)
|
-- | Returns True if the filter is full (all bytes set to 0xff)
|
||||||
isBloomFull :: BloomFilter -> Bool
|
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.
|
-- | Tests if a given bloom filter is valid.
|
||||||
isBloomValid ::
|
isBloomValid ::
|
||||||
-- | Bloom filter to test
|
-- | Bloom filter to test
|
||||||
BloomFilter ->
|
BloomFilter ->
|
||||||
-- | True if the given filter is valid
|
-- | True if the given filter is valid
|
||||||
Bool
|
Bool
|
||||||
isBloomValid bfilter =
|
isBloomValid BloomFilter {..} =
|
||||||
S.length (bloomData bfilter) <= maxBloomSize
|
S.length array <= maxBloomSize && functions <= maxHashFuncs
|
||||||
&& bloomHashFuncs bfilter <= maxHashFuncs
|
|
||||||
|
|
||||||
-- | Does the peer with these version services accept bloom filters?
|
-- | Does the peer with these version services accept bloom filters?
|
||||||
acceptsFilters :: Word64 -> Bool
|
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 DeriveAnyClass #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
|
{-# LANGUAGE NoFieldSelectors #-}
|
||||||
|
|
||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Network.Message
|
-- Module : Haskoin.Network.Message
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
Peer-to-peer network message serialization.
|
-- Peer-to-peer network message serialization.
|
||||||
-}
|
module Haskoin.Network.Message
|
||||||
module Haskoin.Network.Message (
|
( -- * Network Message
|
||||||
-- * Network Message
|
|
||||||
Message (..),
|
Message (..),
|
||||||
MessageHeader (..),
|
MessageHeader (..),
|
||||||
msgType,
|
msgType,
|
||||||
putMessage,
|
putMessage,
|
||||||
getMessage,
|
getMessage,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.DeepSeq
|
import Control.DeepSeq
|
||||||
import Control.Monad (unless)
|
import Control.Monad (unless)
|
||||||
import Data.Binary (Binary (..))
|
import Data.Binary (Binary (..))
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
import qualified Data.ByteString as BS
|
import Data.ByteString qualified as B
|
||||||
import Data.Bytes.Get
|
import Data.Bytes.Get
|
||||||
import Data.Bytes.Put
|
import Data.Bytes.Put
|
||||||
import Data.Bytes.Serial
|
import Data.Bytes.Serial
|
||||||
@ -34,80 +38,78 @@ import GHC.Generics (Generic)
|
|||||||
import Haskoin.Block.Common
|
import Haskoin.Block.Common
|
||||||
import Haskoin.Block.Merkle
|
import Haskoin.Block.Merkle
|
||||||
import Haskoin.Crypto.Hash
|
import Haskoin.Crypto.Hash
|
||||||
import Haskoin.Data
|
|
||||||
import Haskoin.Network.Bloom
|
import Haskoin.Network.Bloom
|
||||||
import Haskoin.Network.Common
|
import Haskoin.Network.Common
|
||||||
|
import Haskoin.Network.Data
|
||||||
import Haskoin.Transaction.Common
|
import Haskoin.Transaction.Common
|
||||||
|
|
||||||
{- | Data type representing the header of a 'Message'. All messages sent between
|
-- | Data type representing the header of a 'Message'. All messages sent between
|
||||||
nodes contain a message header.
|
-- nodes contain a message header.
|
||||||
-}
|
|
||||||
data MessageHeader = MessageHeader
|
data MessageHeader = MessageHeader
|
||||||
{ -- | magic bytes identify network
|
{ -- | magic bytes identify network
|
||||||
headMagic :: !Word32
|
magic :: !Word32,
|
||||||
, -- | message type
|
-- | message type
|
||||||
headCmd :: !MessageCommand
|
cmd :: !MessageCommand,
|
||||||
, -- | length of payload
|
-- | length of payload
|
||||||
headPayloadSize :: !Word32
|
size :: !Word32,
|
||||||
, -- | checksum of payload
|
-- | checksum of payload
|
||||||
headChecksum :: !CheckSum32
|
checksum :: !CheckSum32
|
||||||
}
|
}
|
||||||
deriving (Eq, Show, Generic, NFData)
|
deriving (Eq, Show, Generic, NFData)
|
||||||
|
|
||||||
instance Serial MessageHeader where
|
instance Serial MessageHeader where
|
||||||
deserialize =
|
deserialize =
|
||||||
MessageHeader
|
MessageHeader
|
||||||
<$> getWord32be
|
<$> getWord32be
|
||||||
<*> deserialize
|
<*> deserialize
|
||||||
<*> getWord32le
|
<*> getWord32le
|
||||||
<*> deserialize
|
<*> deserialize
|
||||||
|
|
||||||
serialize (MessageHeader m c l chk) = do
|
serialize (MessageHeader m c l chk) = do
|
||||||
putWord32be m
|
putWord32be m
|
||||||
serialize c
|
serialize c
|
||||||
putWord32le l
|
putWord32le l
|
||||||
serialize chk
|
serialize chk
|
||||||
|
|
||||||
instance Binary MessageHeader where
|
instance Binary MessageHeader where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance Serialize MessageHeader where
|
instance Serialize MessageHeader where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
{- | The 'Message' type is used to identify all the valid messages that can be
|
-- | 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
|
-- sent between bitcoin peers. Only values of type 'Message' will be accepted
|
||||||
by other bitcoin peers as bitcoin protocol messages need to be correctly
|
-- by other bitcoin peers as bitcoin protocol messages need to be correctly
|
||||||
serialized with message headers. Serializing a 'Message' value will
|
-- serialized with message headers. Serializing a 'Message' value will
|
||||||
include the 'MessageHeader' with the correct checksum value automatically.
|
-- include the 'MessageHeader' with the correct checksum value automatically.
|
||||||
No need to add the 'MessageHeader' separately.
|
-- No need to add the 'MessageHeader' separately.
|
||||||
-}
|
|
||||||
data Message
|
data Message
|
||||||
= MVersion !Version
|
= MVersion !Version
|
||||||
| MVerAck
|
| MVerAck
|
||||||
| MAddr !Addr
|
| MAddr !Addr
|
||||||
| MInv !Inv
|
| MInv !Inv
|
||||||
| MGetData !GetData
|
| MGetData !GetData
|
||||||
| MNotFound !NotFound
|
| MNotFound !NotFound
|
||||||
| MGetBlocks !GetBlocks
|
| MGetBlocks !GetBlocks
|
||||||
| MGetHeaders !GetHeaders
|
| MGetHeaders !GetHeaders
|
||||||
| MTx !Tx
|
| MTx !Tx
|
||||||
| MBlock !Block
|
| MBlock !Block
|
||||||
| MMerkleBlock !MerkleBlock
|
| MMerkleBlock !MerkleBlock
|
||||||
| MHeaders !Headers
|
| MHeaders !Headers
|
||||||
| MGetAddr
|
| MGetAddr
|
||||||
| MFilterLoad !FilterLoad
|
| MFilterLoad !FilterLoad
|
||||||
| MFilterAdd !FilterAdd
|
| MFilterAdd !FilterAdd
|
||||||
| MFilterClear
|
| MFilterClear
|
||||||
| MPing !Ping
|
| MPing !Ping
|
||||||
| MPong !Pong
|
| MPong !Pong
|
||||||
| MAlert !Alert
|
| MAlert !Alert
|
||||||
| MMempool
|
| MMempool
|
||||||
| MReject !Reject
|
| MReject !Reject
|
||||||
| MSendHeaders
|
| MSendHeaders
|
||||||
| MOther !ByteString !ByteString
|
| MOther !ByteString !ByteString
|
||||||
deriving (Eq, Show, Generic, NFData)
|
deriving (Eq, Show, Generic, NFData)
|
||||||
|
|
||||||
-- | Get 'MessageCommand' assocated with a message.
|
-- | Get 'MessageCommand' assocated with a message.
|
||||||
msgType :: Message -> MessageCommand
|
msgType :: Message -> MessageCommand
|
||||||
@ -136,85 +138,87 @@ msgType MGetAddr = MCGetAddr
|
|||||||
msgType (MOther c _) = MCOther c
|
msgType (MOther c _) = MCOther c
|
||||||
|
|
||||||
-- | Deserializer for network messages.
|
-- | Deserializer for network messages.
|
||||||
getMessage :: MonadGet m => Network -> m Message
|
getMessage :: (MonadGet m) => Network -> m Message
|
||||||
getMessage net = do
|
getMessage net = do
|
||||||
(MessageHeader mgc cmd len chk) <- deserialize
|
(MessageHeader mgc cmd len chk) <- deserialize
|
||||||
bs <- lookAhead $ getByteString $ fromIntegral len
|
bs <- lookAhead $ getByteString $ fromIntegral len
|
||||||
unless
|
unless
|
||||||
(mgc == getNetworkMagic net)
|
(mgc == net.magic)
|
||||||
(fail $ "get: Invalid network magic bytes: " ++ show mgc)
|
(fail $ "get: Invalid network magic bytes: " ++ show mgc)
|
||||||
unless
|
unless
|
||||||
(checkSum32 bs == chk)
|
(checkSum32 bs == chk)
|
||||||
(fail $ "get: Invalid message checksum: " ++ show chk)
|
(fail $ "get: Invalid message checksum: " ++ show chk)
|
||||||
if len > 0
|
if len > 0
|
||||||
then do
|
then do
|
||||||
bs <- ensure (fromIntegral len)
|
bs <- ensure (fromIntegral len)
|
||||||
let f = case cmd of
|
let f = case cmd of
|
||||||
MCVersion -> MVersion <$> deserialize
|
MCVersion -> MVersion <$> deserialize
|
||||||
MCAddr -> MAddr <$> deserialize
|
MCAddr -> MAddr <$> deserialize
|
||||||
MCInv -> MInv <$> deserialize
|
MCInv -> MInv <$> deserialize
|
||||||
MCGetData -> MGetData <$> deserialize
|
MCGetData -> MGetData <$> deserialize
|
||||||
MCNotFound -> MNotFound <$> deserialize
|
MCNotFound -> MNotFound <$> deserialize
|
||||||
MCGetBlocks -> MGetBlocks <$> deserialize
|
MCGetBlocks -> MGetBlocks <$> deserialize
|
||||||
MCGetHeaders -> MGetHeaders <$> deserialize
|
MCGetHeaders -> MGetHeaders <$> deserialize
|
||||||
MCTx -> MTx <$> deserialize
|
MCTx -> MTx <$> deserialize
|
||||||
MCBlock -> MBlock <$> deserialize
|
MCBlock -> MBlock <$> deserialize
|
||||||
MCMerkleBlock -> MMerkleBlock <$> deserialize
|
MCMerkleBlock -> MMerkleBlock <$> deserialize
|
||||||
MCHeaders -> MHeaders <$> deserialize
|
MCHeaders -> MHeaders <$> deserialize
|
||||||
MCFilterLoad -> MFilterLoad <$> deserialize
|
MCFilterLoad -> MFilterLoad <$> deserialize
|
||||||
MCFilterAdd -> MFilterAdd <$> deserialize
|
MCFilterAdd -> MFilterAdd <$> deserialize
|
||||||
MCPing -> MPing <$> deserialize
|
MCPing -> MPing <$> deserialize
|
||||||
MCPong -> MPong <$> deserialize
|
MCPong -> MPong <$> deserialize
|
||||||
MCAlert -> MAlert <$> deserialize
|
MCAlert -> MAlert <$> deserialize
|
||||||
MCReject -> MReject <$> deserialize
|
MCReject -> MReject <$> deserialize
|
||||||
MCOther c -> MOther c <$> getByteString (fromIntegral len)
|
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)
|
|
||||||
_ ->
|
_ ->
|
||||||
fail $
|
fail $
|
||||||
"get: command " ++ show cmd
|
"get: command "
|
||||||
++ " is expected to carry a payload"
|
++ 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.
|
-- | Serializer for network messages.
|
||||||
putMessage :: MonadPut m => Network -> Message -> m ()
|
putMessage :: (MonadPut m) => Network -> Message -> m ()
|
||||||
putMessage net msg = do
|
putMessage net msg = do
|
||||||
let (cmd, payload) =
|
let (cmd, payload) =
|
||||||
case msg of
|
case msg of
|
||||||
MVersion m -> (MCVersion, runPutS $ serialize m)
|
MVersion m -> (MCVersion, runPutS $ serialize m)
|
||||||
MVerAck -> (MCVerAck, BS.empty)
|
MVerAck -> (MCVerAck, B.empty)
|
||||||
MAddr m -> (MCAddr, runPutS $ serialize m)
|
MAddr m -> (MCAddr, runPutS $ serialize m)
|
||||||
MInv m -> (MCInv, runPutS $ serialize m)
|
MInv m -> (MCInv, runPutS $ serialize m)
|
||||||
MGetData m -> (MCGetData, runPutS $ serialize m)
|
MGetData m -> (MCGetData, runPutS $ serialize m)
|
||||||
MNotFound m -> (MCNotFound, runPutS $ serialize m)
|
MNotFound m -> (MCNotFound, runPutS $ serialize m)
|
||||||
MGetBlocks m -> (MCGetBlocks, runPutS $ serialize m)
|
MGetBlocks m -> (MCGetBlocks, runPutS $ serialize m)
|
||||||
MGetHeaders m -> (MCGetHeaders, runPutS $ serialize m)
|
MGetHeaders m -> (MCGetHeaders, runPutS $ serialize m)
|
||||||
MTx m -> (MCTx, runPutS $ serialize m)
|
MTx m -> (MCTx, runPutS $ serialize m)
|
||||||
MBlock m -> (MCBlock, runPutS $ serialize m)
|
MBlock m -> (MCBlock, runPutS $ serialize m)
|
||||||
MMerkleBlock m -> (MCMerkleBlock, runPutS $ serialize m)
|
MMerkleBlock m -> (MCMerkleBlock, runPutS $ serialize m)
|
||||||
MHeaders m -> (MCHeaders, runPutS $ serialize m)
|
MHeaders m -> (MCHeaders, runPutS $ serialize m)
|
||||||
MGetAddr -> (MCGetAddr, BS.empty)
|
MGetAddr -> (MCGetAddr, B.empty)
|
||||||
MFilterLoad m -> (MCFilterLoad, runPutS $ serialize m)
|
MFilterLoad m -> (MCFilterLoad, runPutS $ serialize m)
|
||||||
MFilterAdd m -> (MCFilterAdd, runPutS $ serialize m)
|
MFilterAdd m -> (MCFilterAdd, runPutS $ serialize m)
|
||||||
MFilterClear -> (MCFilterClear, BS.empty)
|
MFilterClear -> (MCFilterClear, B.empty)
|
||||||
MPing m -> (MCPing, runPutS $ serialize m)
|
MPing m -> (MCPing, runPutS $ serialize m)
|
||||||
MPong m -> (MCPong, runPutS $ serialize m)
|
MPong m -> (MCPong, runPutS $ serialize m)
|
||||||
MAlert m -> (MCAlert, runPutS $ serialize m)
|
MAlert m -> (MCAlert, runPutS $ serialize m)
|
||||||
MMempool -> (MCMempool, BS.empty)
|
MMempool -> (MCMempool, B.empty)
|
||||||
MReject m -> (MCReject, runPutS $ serialize m)
|
MReject m -> (MCReject, runPutS $ serialize m)
|
||||||
MSendHeaders -> (MCSendHeaders, BS.empty)
|
MSendHeaders -> (MCSendHeaders, B.empty)
|
||||||
MOther c p -> (MCOther c, p)
|
MOther c p -> (MCOther c, p)
|
||||||
chk = checkSum32 payload
|
chk = checkSum32 payload
|
||||||
len = fromIntegral $ BS.length payload
|
len = fromIntegral $ B.length payload
|
||||||
header = MessageHeader (getNetworkMagic net) cmd len chk
|
header = MessageHeader net.magic cmd len chk
|
||||||
serialize header
|
serialize header
|
||||||
putByteString payload
|
putByteString payload
|
||||||
|
@ -1,20 +1,20 @@
|
|||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Script
|
-- Module : Haskoin.Script
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
This module provides functions for parsing and evaluating bitcoin
|
-- This module provides functions for parsing and evaluating bitcoin
|
||||||
transaction scripts. Data types are provided for building and
|
-- transaction scripts. Data types are provided for building and
|
||||||
deconstructing all of the standard input and output script types.
|
-- deconstructing all of the standard input and output script types.
|
||||||
-}
|
module Haskoin.Script
|
||||||
module Haskoin.Script (
|
( module Common,
|
||||||
module Common,
|
|
||||||
module Standard,
|
module Standard,
|
||||||
module SigHash,
|
module SigHash,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Haskoin.Script.Common as Common
|
import Haskoin.Script.Common as Common
|
||||||
import Haskoin.Script.SigHash as SigHash
|
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 DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE DerivingStrategies #-}
|
||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE NoFieldSelectors #-}
|
||||||
|
|
||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Script.SigHash
|
-- Module : Haskoin.Script.SigHash
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
Transaction signatures and related functions.
|
-- Transaction signatures and related functions.
|
||||||
-}
|
module Haskoin.Script.SigHash
|
||||||
module Haskoin.Script.SigHash (
|
( -- * Script Signatures
|
||||||
-- * Script Signatures
|
|
||||||
SigHash (..),
|
SigHash (..),
|
||||||
SigHashFlag (..),
|
SigHashFlag (..),
|
||||||
sigHashAll,
|
sigHashAll,
|
||||||
sigHashNone,
|
sigHashNone,
|
||||||
sigHashSingle,
|
sigHashSingle,
|
||||||
hasAnyoneCanPayFlag,
|
anyoneCanPay,
|
||||||
hasForkIdFlag,
|
hasForkIdFlag,
|
||||||
setAnyoneCanPayFlag,
|
setAnyoneCanPay,
|
||||||
setForkIdFlag,
|
setForkIdFlag,
|
||||||
isSigHashAll,
|
isSigHashAll,
|
||||||
isSigHashNone,
|
isSigHashNone,
|
||||||
@ -33,15 +41,19 @@ module Haskoin.Script.SigHash (
|
|||||||
txSigHash,
|
txSigHash,
|
||||||
txSigHashForkId,
|
txSigHashForkId,
|
||||||
TxSignature (..),
|
TxSignature (..),
|
||||||
encodeTxSig,
|
|
||||||
decodeTxSig,
|
decodeTxSig,
|
||||||
) where
|
encodeTxSig,
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.DeepSeq
|
import Control.DeepSeq
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import qualified Data.Aeson as J
|
import Crypto.Secp256k1
|
||||||
|
import Data.Aeson
|
||||||
import Data.Bits
|
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.Get
|
||||||
import Data.Bytes.Put
|
import Data.Bytes.Put
|
||||||
import Data.Bytes.Serial
|
import Data.Bytes.Serial
|
||||||
@ -50,82 +62,69 @@ import Data.Maybe
|
|||||||
import Data.Scientific
|
import Data.Scientific
|
||||||
import Data.Word
|
import Data.Word
|
||||||
import GHC.Generics (Generic)
|
import GHC.Generics (Generic)
|
||||||
import Haskoin.Crypto
|
|
||||||
import Haskoin.Crypto.Hash
|
import Haskoin.Crypto.Hash
|
||||||
import Haskoin.Data
|
import Haskoin.Crypto.Signature
|
||||||
import Haskoin.Network.Common
|
import Haskoin.Network.Common
|
||||||
|
import Haskoin.Network.Data
|
||||||
import Haskoin.Script.Common
|
import Haskoin.Script.Common
|
||||||
import Haskoin.Transaction.Common
|
import Haskoin.Transaction.Common
|
||||||
import Haskoin.Util
|
import Haskoin.Util
|
||||||
|
|
||||||
-- | Constant representing a SIGHASH flag that controls what is being signed.
|
-- | Constant representing a SIGHASH flag that controls what is being signed.
|
||||||
data SigHashFlag
|
data SigHashFlag
|
||||||
= -- | sign all outputs
|
= -- | sign all outputs
|
||||||
SIGHASH_ALL
|
SIGHASH_ALL
|
||||||
| -- | sign no outputs
|
| -- | sign no outputs
|
||||||
SIGHASH_NONE
|
SIGHASH_NONE
|
||||||
| -- | sign the output index corresponding to the input
|
| -- | sign the output index corresponding to the input
|
||||||
SIGHASH_SINGLE
|
SIGHASH_SINGLE
|
||||||
| -- | replay protection for Bitcoin Cash transactions
|
| -- | replay protection for Bitcoin Cash transactions
|
||||||
SIGHASH_FORKID
|
SIGHASH_FORKID
|
||||||
| -- | new inputs can be added
|
| -- | new inputs can be added
|
||||||
SIGHASH_ANYONECANPAY
|
SIGHASH_ANYONECANPAY
|
||||||
deriving (Eq, Ord, Show, Read, Generic)
|
deriving (Eq, Ord, Show, Read, Generic)
|
||||||
|
|
||||||
instance NFData SigHashFlag
|
instance NFData SigHashFlag
|
||||||
|
|
||||||
instance Hashable SigHashFlag
|
instance Hashable SigHashFlag
|
||||||
|
|
||||||
instance Enum SigHashFlag where
|
instance Enum SigHashFlag where
|
||||||
fromEnum SIGHASH_ALL = 0x01
|
fromEnum SIGHASH_ALL = 0x01
|
||||||
fromEnum SIGHASH_NONE = 0x02
|
fromEnum SIGHASH_NONE = 0x02
|
||||||
fromEnum SIGHASH_SINGLE = 0x03
|
fromEnum SIGHASH_SINGLE = 0x03
|
||||||
fromEnum SIGHASH_FORKID = 0x40
|
fromEnum SIGHASH_FORKID = 0x40
|
||||||
fromEnum SIGHASH_ANYONECANPAY = 0x80
|
fromEnum SIGHASH_ANYONECANPAY = 0x80
|
||||||
toEnum 0x01 = SIGHASH_ALL
|
toEnum 0x01 = SIGHASH_ALL
|
||||||
toEnum 0x02 = SIGHASH_NONE
|
toEnum 0x02 = SIGHASH_NONE
|
||||||
toEnum 0x03 = SIGHASH_SINGLE
|
toEnum 0x03 = SIGHASH_SINGLE
|
||||||
toEnum 0x40 = SIGHASH_FORKID
|
toEnum 0x40 = SIGHASH_FORKID
|
||||||
toEnum 0x80 = SIGHASH_ANYONECANPAY
|
toEnum 0x80 = SIGHASH_ANYONECANPAY
|
||||||
toEnum _ = error "Not a valid sighash flag"
|
toEnum _ = error "Not a valid sighash flag"
|
||||||
|
|
||||||
{- | Data type representing the different ways a transaction can be signed.
|
-- | 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
|
-- 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
|
-- to be signed. The 'SigHash' parameter controls which parts of the
|
||||||
transaction are used or ignored to produce the transaction hash. The idea is
|
-- 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
|
-- 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
|
-- hash, then you can change that part of the transaction after producing a
|
||||||
signature without invalidating that signature.
|
-- signature without invalidating that signature.
|
||||||
|
--
|
||||||
If the 'SIGHASH_ANYONECANPAY' flag is set (true), then only the current input
|
-- 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
|
-- is signed. Otherwise, all of the inputs of a transaction are signed. The
|
||||||
default value for 'SIGHASH_ANYONECANPAY' is unset (false).
|
-- default value for 'SIGHASH_ANYONECANPAY' is unset (false).
|
||||||
-}
|
|
||||||
newtype SigHash
|
newtype SigHash
|
||||||
= SigHash Word32
|
= SigHash Word32
|
||||||
deriving
|
deriving (Eq, Ord, Enum, Show, Read, Generic)
|
||||||
( Eq
|
deriving newtype (Bits, Integral, Num, Real, Hashable, NFData)
|
||||||
, Ord
|
|
||||||
, Bits
|
|
||||||
, Enum
|
|
||||||
, Integral
|
|
||||||
, Num
|
|
||||||
, Real
|
|
||||||
, Show
|
|
||||||
, Read
|
|
||||||
, Generic
|
|
||||||
, Hashable
|
|
||||||
, NFData
|
|
||||||
)
|
|
||||||
|
|
||||||
instance J.FromJSON SigHash where
|
instance FromJSON SigHash where
|
||||||
parseJSON =
|
parseJSON =
|
||||||
J.withScientific "sighash" $
|
withScientific "sighash" $
|
||||||
maybe mzero (return . SigHash) . toBoundedInteger
|
maybe mzero (return . SigHash) . toBoundedInteger
|
||||||
|
|
||||||
instance J.ToJSON SigHash where
|
instance ToJSON SigHash where
|
||||||
toJSON = J.Number . fromIntegral
|
toJSON = Number . fromIntegral
|
||||||
toEncoding (SigHash n) = J.toEncoding n
|
toEncoding (SigHash n) = toEncoding n
|
||||||
|
|
||||||
-- | SIGHASH_NONE as a byte.
|
-- | SIGHASH_NONE as a byte.
|
||||||
sigHashNone :: SigHash
|
sigHashNone :: SigHash
|
||||||
@ -152,16 +151,16 @@ setForkIdFlag :: SigHash -> SigHash
|
|||||||
setForkIdFlag = (.|. sigHashForkId)
|
setForkIdFlag = (.|. sigHashForkId)
|
||||||
|
|
||||||
-- | Set SIGHASH_ANYONECANPAY flag.
|
-- | Set SIGHASH_ANYONECANPAY flag.
|
||||||
setAnyoneCanPayFlag :: SigHash -> SigHash
|
setAnyoneCanPay :: SigHash -> SigHash
|
||||||
setAnyoneCanPayFlag = (.|. sigHashAnyoneCanPay)
|
setAnyoneCanPay = (.|. sigHashAnyoneCanPay)
|
||||||
|
|
||||||
-- | Is the SIGHASH_FORKID flag set?
|
-- | Is the SIGHASH_FORKID flag set?
|
||||||
hasForkIdFlag :: SigHash -> Bool
|
hasForkIdFlag :: SigHash -> Bool
|
||||||
hasForkIdFlag = (/= 0) . (.&. sigHashForkId)
|
hasForkIdFlag = (/= 0) . (.&. sigHashForkId)
|
||||||
|
|
||||||
-- | Is the SIGHASH_ANYONECANPAY flag set?
|
-- | Is the SIGHASH_ANYONECANPAY flag set?
|
||||||
hasAnyoneCanPayFlag :: SigHash -> Bool
|
anyoneCanPay :: SigHash -> Bool
|
||||||
hasAnyoneCanPayFlag = (/= 0) . (.&. sigHashAnyoneCanPay)
|
anyoneCanPay = (/= 0) . (.&. sigHashAnyoneCanPay)
|
||||||
|
|
||||||
-- | Returns 'True' if the 'SigHash' has the value 'SIGHASH_ALL'.
|
-- | Returns 'True' if the 'SigHash' has the value 'SIGHASH_ALL'.
|
||||||
isSigHashAll :: SigHash -> Bool
|
isSigHashAll :: SigHash -> Bool
|
||||||
@ -178,7 +177,7 @@ isSigHashSingle = (== sigHashSingle) . (.&. 0x1f)
|
|||||||
-- | Returns 'True' if the 'SigHash' has the value 'SIGHASH_UNKNOWN'.
|
-- | Returns 'True' if the 'SigHash' has the value 'SIGHASH_UNKNOWN'.
|
||||||
isSigHashUnknown :: SigHash -> Bool
|
isSigHashUnknown :: SigHash -> Bool
|
||||||
isSigHashUnknown =
|
isSigHashUnknown =
|
||||||
(`notElem` [sigHashAll, sigHashNone, sigHashSingle]) . (.&. 0x1f)
|
(`notElem` [sigHashAll, sigHashNone, sigHashSingle]) . (.&. 0x1f)
|
||||||
|
|
||||||
-- | Add a fork id to a 'SigHash'.
|
-- | Add a fork id to a 'SigHash'.
|
||||||
sigHashAddForkId :: SigHash -> Word32 -> 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'.
|
-- | Add fork id of a particular network to a 'SigHash'.
|
||||||
sigHashAddNetworkId :: Network -> SigHash -> SigHash
|
sigHashAddNetworkId :: Network -> SigHash -> SigHash
|
||||||
sigHashAddNetworkId net =
|
sigHashAddNetworkId net =
|
||||||
(`sigHashAddForkId` fromMaybe 0 (getSigHashForkId net))
|
(`sigHashAddForkId` fromMaybe 0 net.sigHashForkId)
|
||||||
|
|
||||||
-- | Get fork id from 'SigHash'.
|
-- | Get fork id from 'SigHash'.
|
||||||
sigHashGetForkId :: SigHash -> Word32
|
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.
|
-- | Computes the hash that will be used for signing a transaction.
|
||||||
txSigHash ::
|
txSigHash ::
|
||||||
Network ->
|
Network ->
|
||||||
-- | transaction to sign
|
-- | transaction to sign
|
||||||
Tx ->
|
Tx ->
|
||||||
-- | script from output being spent
|
-- | script from output being spent
|
||||||
Script ->
|
Script ->
|
||||||
-- | value of output being spent
|
-- | value of output being spent
|
||||||
Word64 ->
|
Word64 ->
|
||||||
-- | index of input being signed
|
-- | index of input being signed
|
||||||
Int ->
|
Int ->
|
||||||
-- | what to sign
|
-- | what to sign
|
||||||
SigHash ->
|
SigHash ->
|
||||||
-- | hash to be signed
|
-- | hash to be signed
|
||||||
Hash256
|
Hash256
|
||||||
txSigHash net tx out v i sh
|
txSigHash net tx out v i sh
|
||||||
| hasForkIdFlag sh && isJust (getSigHashForkId net) =
|
| hasForkIdFlag sh && isJust net.sigHashForkId =
|
||||||
txSigHashForkId net tx out v i sh
|
txSigHashForkId net tx out v i sh
|
||||||
| otherwise = do
|
| otherwise = do
|
||||||
let newIn = buildInputs (txIn tx) fout i sh
|
let newIn = buildInputs tx.inputs fout i sh
|
||||||
-- When SigSingle and input index > outputs, then sign integer 1
|
-- When SigSingle and input index > outputs, then sign integer 1
|
||||||
fromMaybe one $ do
|
fromMaybe one $ do
|
||||||
newOut <- buildOutputs (txOut tx) i sh
|
newOut <- buildOutputs tx.outputs i sh
|
||||||
let newTx = Tx (txVersion tx) newIn newOut [] (txLockTime tx)
|
let newTx = Tx tx.version newIn newOut [] tx.locktime
|
||||||
return $
|
return . doubleSHA256 . runPutS $ do
|
||||||
doubleSHA256 $
|
serialize newTx
|
||||||
runPutS $ do
|
putWord32le $ fromIntegral sh
|
||||||
serialize newTx
|
|
||||||
putWord32le $ fromIntegral sh
|
|
||||||
where
|
where
|
||||||
fout = Script $ filter (/= OP_CODESEPARATOR) $ scriptOps out
|
fout = Script $ filter (/= OP_CODESEPARATOR) out.ops
|
||||||
one = "0100000000000000000000000000000000000000000000000000000000000000"
|
one = "0100000000000000000000000000000000000000000000000000000000000000"
|
||||||
|
|
||||||
-- | Build transaction inputs for computing sighashes.
|
-- | Build transaction inputs for computing sighashes.
|
||||||
buildInputs :: [TxIn] -> Script -> Int -> SigHash -> [TxIn]
|
buildInputs :: [TxIn] -> Script -> Int -> SigHash -> [TxIn]
|
||||||
buildInputs txins out i sh
|
buildInputs txins out i sh
|
||||||
| hasAnyoneCanPayFlag sh =
|
| anyoneCanPay sh = [serialOut (txins !! i)]
|
||||||
[(txins !! i){scriptInput = runPutS $ serialize out}]
|
| isSigHashAll sh || isSigHashUnknown sh = single
|
||||||
| isSigHashAll sh || isSigHashUnknown sh = single
|
| otherwise = zipWith noSeq single [0 ..]
|
||||||
| otherwise = zipWith noSeq single [0 ..]
|
|
||||||
where
|
where
|
||||||
emptyIn = map (\ti -> ti{scriptInput = BS.empty}) txins
|
serialOut TxIn {..} = TxIn {script = runPutS $ serialize out, ..}
|
||||||
single =
|
emptyIn TxIn {..} = TxIn {script = B.empty, ..}
|
||||||
updateIndex i emptyIn $ \ti -> ti{scriptInput = runPutS $ serialize out}
|
emptyIns = map emptyIn txins
|
||||||
noSeq ti j =
|
single = updateIndex i emptyIns serialOut
|
||||||
if i == j
|
noSeq TxIn {..} j = TxIn {sequence = if i == j then sequence else 0, ..}
|
||||||
then ti
|
|
||||||
else ti{txInSequence = 0}
|
|
||||||
|
|
||||||
-- | Build transaction outputs for computing sighashes.
|
-- | Build transaction outputs for computing sighashes.
|
||||||
buildOutputs :: [TxOut] -> Int -> SigHash -> Maybe [TxOut]
|
buildOutputs :: [TxOut] -> Int -> SigHash -> Maybe [TxOut]
|
||||||
buildOutputs txos i sh
|
buildOutputs txos i sh
|
||||||
| isSigHashAll sh || isSigHashUnknown sh = return txos
|
| isSigHashAll sh || isSigHashUnknown sh = return txos
|
||||||
| isSigHashNone sh = return []
|
| isSigHashNone sh = return []
|
||||||
| i >= length txos = Nothing
|
| i >= length txos = Nothing
|
||||||
| otherwise = return $ buffer ++ [txos !! i]
|
| otherwise = return $ buffer ++ [txos !! i]
|
||||||
where
|
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
|
-- | Compute the hash that will be used for signing a transaction. This
|
||||||
function is used when the 'SIGHASH_FORKID' flag is set.
|
-- function is used when the 'SIGHASH_FORKID' flag is set.
|
||||||
-}
|
|
||||||
txSigHashForkId ::
|
txSigHashForkId ::
|
||||||
Network ->
|
Network ->
|
||||||
-- | transaction to sign
|
-- | transaction to sign
|
||||||
Tx ->
|
Tx ->
|
||||||
-- | script from output being spent
|
-- | script from output being spent
|
||||||
Script ->
|
Script ->
|
||||||
-- | value of output being spent
|
-- | value of output being spent
|
||||||
Word64 ->
|
Word64 ->
|
||||||
-- | index of input being signed
|
-- | index of input being signed
|
||||||
Int ->
|
Int ->
|
||||||
-- | what to sign
|
-- | what to sign
|
||||||
SigHash ->
|
SigHash ->
|
||||||
-- | hash to be signed
|
-- | hash to be signed
|
||||||
Hash256
|
Hash256
|
||||||
txSigHashForkId net tx out v i sh =
|
txSigHashForkId net tx out v i sh =
|
||||||
doubleSHA256 . runPutS $ do
|
doubleSHA256 . runPutS $ do
|
||||||
putWord32le $ txVersion tx
|
putWord32le tx.version
|
||||||
serialize hashPrevouts
|
serialize hashPrevouts
|
||||||
serialize hashSequence
|
serialize hashSequence
|
||||||
serialize $ prevOutput $ txIn tx !! i
|
serialize (tx.inputs !! i).outpoint
|
||||||
putScript out
|
putScript out
|
||||||
putWord64le v
|
putWord64le v
|
||||||
putWord32le $ txInSequence $ txIn tx !! i
|
putWord32le (tx.inputs !! i).sequence
|
||||||
serialize hashOutputs
|
serialize hashOutputs
|
||||||
putWord32le $ txLockTime tx
|
putWord32le tx.locktime
|
||||||
putWord32le $ fromIntegral $ sigHashAddNetworkId net sh
|
putWord32le $ fromIntegral $ sigHashAddNetworkId net sh
|
||||||
where
|
where
|
||||||
hashPrevouts
|
hashPrevouts
|
||||||
| not $ hasAnyoneCanPayFlag sh =
|
| not (anyoneCanPay sh) =
|
||||||
doubleSHA256 $ runPutS $ mapM_ (serialize . prevOutput) $ txIn tx
|
doubleSHA256 . runPutS $ mapM_ (serialize . (.outpoint)) tx.inputs
|
||||||
| otherwise = zeros
|
| otherwise = zeros
|
||||||
hashSequence
|
hashSequence
|
||||||
| not (hasAnyoneCanPayFlag sh)
|
| not (anyoneCanPay sh || isSigHashSingle sh || isSigHashNone sh) =
|
||||||
&& not (isSigHashSingle sh)
|
doubleSHA256 . runPutS $ mapM_ (putWord32le . (.sequence)) tx.inputs
|
||||||
&& not (isSigHashNone sh) =
|
| otherwise = zeros
|
||||||
doubleSHA256 $ runPutS $ mapM_ (putWord32le . txInSequence) $ txIn tx
|
|
||||||
| otherwise = zeros
|
|
||||||
hashOutputs
|
hashOutputs
|
||||||
| not (isSigHashSingle sh) && not (isSigHashNone sh) =
|
| not (isSigHashSingle sh || isSigHashNone sh) =
|
||||||
doubleSHA256 $ runPutS $ mapM_ serialize $ txOut tx
|
doubleSHA256 . runPutS $ mapM_ serialize tx.outputs
|
||||||
| isSigHashSingle sh && i < length (txOut tx) =
|
| isSigHashSingle sh && i < length tx.outputs =
|
||||||
doubleSHA256 $ runPutS $ serialize $ txOut tx !! i
|
doubleSHA256 . runPutS $ serialize $ tx.outputs !! i
|
||||||
| otherwise = zeros
|
| otherwise = zeros
|
||||||
putScript s = do
|
putScript s = do
|
||||||
let encodedScript = runPutS $ serialize s
|
let encodedScript = runPutS $ serialize s
|
||||||
putVarInt $ BS.length encodedScript
|
putVarInt $ B.length encodedScript
|
||||||
putByteString encodedScript
|
putByteString encodedScript
|
||||||
zeros :: Hash256
|
zeros :: Hash256
|
||||||
zeros = "0000000000000000000000000000000000000000000000000000000000000000"
|
zeros = "0000000000000000000000000000000000000000000000000000000000000000"
|
||||||
|
|
||||||
{- | Data type representing a signature together with a 'SigHash'. The 'SigHash'
|
-- | 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
|
-- is serialized as one byte at the end of an ECDSA 'Sig'. All signatures in
|
||||||
transaction inputs are of type 'TxSignature'.
|
-- transaction inputs are of type 'TxSignature'.
|
||||||
-}
|
|
||||||
data TxSignature
|
data TxSignature
|
||||||
= TxSignature
|
= TxSignature
|
||||||
{ txSignature :: !Sig
|
{ sig :: !Sig,
|
||||||
, txSignatureSigHash :: !SigHash
|
hash :: !SigHash
|
||||||
}
|
}
|
||||||
| TxSignatureEmpty
|
| TxSignatureEmpty
|
||||||
deriving (Eq, Show, Generic)
|
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'.
|
marshalGet (net, ctx) =
|
||||||
encodeTxSig :: TxSignature -> BS.ByteString
|
bool decode empty =<< isEmpty
|
||||||
encodeTxSig TxSignatureEmpty = error "Can not encode an empty signature"
|
where
|
||||||
encodeTxSig (TxSignature sig (SigHash n)) =
|
empty = return TxSignatureEmpty
|
||||||
runPutS $ putSig sig >> putWord8 (fromIntegral n)
|
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'.
|
instance MarshalJSON (Network, Ctx) TxSignature where
|
||||||
decodeTxSig :: Network -> BS.ByteString -> Either String TxSignature
|
marshalValue (net, ctx) = String . encodeHex . encodeTxSig net ctx
|
||||||
decodeTxSig _ bs | BS.null bs = Left "Empty signature candidate"
|
marshalEncoding s = hexEncoding . runPutL . marshalPut s
|
||||||
decodeTxSig net bs =
|
unmarshalValue (net, ctx) =
|
||||||
case decodeStrictSig $ BS.init bs of
|
withText "TxSignature" $ \t ->
|
||||||
Just sig -> do
|
case decodeHex t of
|
||||||
let sh = fromIntegral $ BS.last bs
|
Nothing -> fail "Cannot decode hex signature"
|
||||||
when (isSigHashUnknown sh) $
|
Just b -> case decodeTxSig net ctx b of
|
||||||
Left "Non-canonical signature: unknown hashtype byte"
|
Left e -> fail e
|
||||||
when (isNothing (getSigHashForkId net) && hasForkIdFlag sh) $
|
Right s -> return s
|
||||||
Left "Non-canonical signature: invalid network for forkId"
|
|
||||||
return $ TxSignature sig sh
|
encodeTxSig :: Network -> Ctx -> TxSignature -> ByteString
|
||||||
Nothing -> Left "Non-canonical signature: could not parse signature"
|
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 DeriveAnyClass #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE NoFieldSelectors #-}
|
||||||
|
|
||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Script.Standard
|
-- Module : Haskoin.Script.Standard
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
Standard scripts like pay-to-public-key, pay-to-public-key-hash,
|
-- Standard scripts like pay-to-public-key, pay-to-public-key-hash,
|
||||||
pay-to-script-hash, pay-to-multisig and corresponding SegWit variants.
|
-- pay-to-script-hash, pay-to-multisig and corresponding SegWit variants.
|
||||||
-}
|
module Haskoin.Script.Standard
|
||||||
module Haskoin.Script.Standard (
|
( -- * Standard Script Outputs
|
||||||
-- * Standard Script Outputs
|
|
||||||
ScriptOutput (..),
|
ScriptOutput (..),
|
||||||
RedeemScript,
|
RedeemScript,
|
||||||
isPayPK,
|
isPayPK,
|
||||||
@ -26,9 +32,7 @@ module Haskoin.Script.Standard (
|
|||||||
isPayWitnessScriptHash,
|
isPayWitnessScriptHash,
|
||||||
isDataCarrier,
|
isDataCarrier,
|
||||||
encodeOutput,
|
encodeOutput,
|
||||||
encodeOutputBS,
|
|
||||||
decodeOutput,
|
decodeOutput,
|
||||||
decodeOutputBS,
|
|
||||||
toP2SH,
|
toP2SH,
|
||||||
toP2WSH,
|
toP2WSH,
|
||||||
sortMulSig,
|
sortMulSig,
|
||||||
@ -37,22 +41,23 @@ module Haskoin.Script.Standard (
|
|||||||
ScriptInput (..),
|
ScriptInput (..),
|
||||||
SimpleInput (..),
|
SimpleInput (..),
|
||||||
encodeInput,
|
encodeInput,
|
||||||
encodeInputBS,
|
|
||||||
decodeInput,
|
decodeInput,
|
||||||
decodeInputBS,
|
|
||||||
isSpendPK,
|
isSpendPK,
|
||||||
isSpendPKHash,
|
isSpendPKHash,
|
||||||
isSpendMulSig,
|
isSpendMulSig,
|
||||||
isScriptHashInput,
|
isScriptHashInput,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Applicative ((<|>))
|
import Control.Applicative ((<|>))
|
||||||
import Control.DeepSeq
|
import Control.DeepSeq
|
||||||
import Control.Monad (guard, liftM2, (<=<))
|
import Control.Monad (guard, liftM2, (<=<))
|
||||||
import qualified Data.Aeson as A
|
import Crypto.Secp256k1
|
||||||
import qualified Data.Aeson.Encoding as A
|
import Data.Aeson (ToJSON (..), Value (..), withText)
|
||||||
|
import Data.Aeson.Encoding (Encoding, text)
|
||||||
|
import Data.Aeson.Types (Parser)
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
import qualified Data.ByteString as BS
|
import Data.ByteString qualified as B
|
||||||
import Data.Bytes.Get
|
import Data.Bytes.Get
|
||||||
import Data.Bytes.Put
|
import Data.Bytes.Put
|
||||||
import Data.Bytes.Serial
|
import Data.Bytes.Serial
|
||||||
@ -62,52 +67,51 @@ import Data.List (sortBy)
|
|||||||
import Data.Maybe (fromJust, isJust)
|
import Data.Maybe (fromJust, isJust)
|
||||||
import Data.Word (Word8)
|
import Data.Word (Word8)
|
||||||
import GHC.Generics (Generic)
|
import GHC.Generics (Generic)
|
||||||
import Haskoin.Crypto
|
import Haskoin.Crypto.Hash
|
||||||
import Haskoin.Data
|
import Haskoin.Crypto.Keys.Common
|
||||||
import Haskoin.Keys.Common
|
import Haskoin.Network.Data
|
||||||
import Haskoin.Script.Common
|
import Haskoin.Script.Common
|
||||||
import Haskoin.Script.SigHash
|
import Haskoin.Script.SigHash
|
||||||
import Haskoin.Util
|
import Haskoin.Util
|
||||||
|
|
||||||
{- | Data type describing standard transaction output scripts. Output scripts
|
-- | Data type describing standard transaction output scripts. Output scripts
|
||||||
provide the conditions that must be fulfilled for someone to spend the funds
|
-- provide the conditions that must be fulfilled for someone to spend the funds
|
||||||
in a transaction output.
|
-- in a transaction output.
|
||||||
-}
|
|
||||||
data ScriptOutput
|
data ScriptOutput
|
||||||
= -- | pay to public key
|
= -- | pay to public key
|
||||||
PayPK {getOutputPubKey :: !PubKeyI}
|
PayPK {key :: !PublicKey}
|
||||||
| -- | pay to public key hash
|
| -- | pay to public key hash
|
||||||
PayPKHash {getOutputHash :: !Hash160}
|
PayPKHash {hash160 :: !Hash160}
|
||||||
| -- | multisig
|
| -- | multisig
|
||||||
PayMulSig
|
PayMulSig
|
||||||
{ getOutputMulSigKeys :: ![PubKeyI]
|
{ keys :: ![PublicKey],
|
||||||
, getOutputMulSigRequired :: !Int
|
required :: !Int
|
||||||
}
|
}
|
||||||
| -- | pay to a script hash
|
| -- | pay to a script hash
|
||||||
PayScriptHash {getOutputHash :: !Hash160}
|
PayScriptHash {hash160 :: !Hash160}
|
||||||
| -- | pay to witness public key hash
|
| -- | pay to witness public key hash
|
||||||
PayWitnessPKHash {getOutputHash :: !Hash160}
|
PayWitnessPKHash {hash160 :: !Hash160}
|
||||||
| -- | pay to witness script hash
|
| -- | pay to witness script hash
|
||||||
PayWitnessScriptHash {getScriptHash :: !Hash256}
|
PayWitnessScriptHash {hash256 :: !Hash256}
|
||||||
| -- | another pay to witness address
|
| -- | another pay to witness address
|
||||||
PayWitness
|
PayWitness
|
||||||
{ getWitnessVersion :: !Word8
|
{ version :: !Word8,
|
||||||
, getWitnessData :: !ByteString
|
bytes :: !ByteString
|
||||||
}
|
}
|
||||||
| -- | provably unspendable data carrier
|
| -- | provably unspendable data carrier
|
||||||
DataCarrier {getOutputData :: !ByteString}
|
DataCarrier {bytes :: !ByteString}
|
||||||
deriving (Eq, Show, Read, Generic, Hashable, NFData)
|
deriving (Eq, Show, Read, Generic, NFData)
|
||||||
|
|
||||||
instance A.FromJSON ScriptOutput where
|
instance MarshalJSON Ctx ScriptOutput where
|
||||||
parseJSON =
|
unmarshalValue ctx =
|
||||||
A.withText "scriptoutput" $ \t ->
|
withText "ScriptOutput" $ \t ->
|
||||||
either fail return $
|
case decodeHex t of
|
||||||
maybeToEither "scriptoutput not hex" (decodeHex t)
|
Nothing -> fail "Could not decode hex script"
|
||||||
>>= decodeOutputBS
|
Just bs -> either fail return $ unmarshal ctx bs
|
||||||
|
|
||||||
instance A.ToJSON ScriptOutput where
|
marshalValue ctx = String . encodeHex . marshal ctx
|
||||||
toJSON = A.String . encodeHex . encodeOutputBS
|
|
||||||
toEncoding = A.text . encodeHex . encodeOutputBS
|
marshalEncoding ctx = hexEncoding . runPutL . marshalPut ctx
|
||||||
|
|
||||||
-- | Is script a pay-to-public-key output?
|
-- | Is script a pay-to-public-key output?
|
||||||
isPayPK :: ScriptOutput -> Bool
|
isPayPK :: ScriptOutput -> Bool
|
||||||
@ -149,35 +153,39 @@ isDataCarrier :: ScriptOutput -> Bool
|
|||||||
isDataCarrier (DataCarrier _) = True
|
isDataCarrier (DataCarrier _) = True
|
||||||
isDataCarrier _ = False
|
isDataCarrier _ = False
|
||||||
|
|
||||||
{- | Tries to decode a 'ScriptOutput' from a 'Script'. This can fail if the
|
-- | Tries to decode a 'ScriptOutput' from a 'Script'. This can fail if the
|
||||||
script is not recognized as any of the standard output types.
|
-- script is not recognized as any of the standard output types.
|
||||||
-}
|
decodeOutput :: Ctx -> Script -> Either String ScriptOutput
|
||||||
decodeOutput :: Script -> Either String ScriptOutput
|
decodeOutput ctx s = case s.ops of
|
||||||
decodeOutput s = case scriptOps s of
|
-- Pay to PubKey
|
||||||
-- Pay to PubKey
|
[OP_PUSHDATA bs _, OP_CHECKSIG] ->
|
||||||
[OP_PUSHDATA bs _, OP_CHECKSIG] -> PayPK <$> runGetS deserialize bs
|
PayPK <$> unmarshal ctx bs
|
||||||
-- Pay to PubKey Hash
|
-- Pay to PubKey Hash
|
||||||
[OP_DUP, OP_HASH160, OP_PUSHDATA bs _, OP_EQUALVERIFY, OP_CHECKSIG] ->
|
[OP_DUP, OP_HASH160, OP_PUSHDATA bs _, OP_EQUALVERIFY, OP_CHECKSIG] ->
|
||||||
PayPKHash <$> runGetS deserialize bs
|
PayPKHash <$> runGetS deserialize bs
|
||||||
-- Pay to Script Hash
|
-- Pay to Script Hash
|
||||||
[OP_HASH160, OP_PUSHDATA bs _, OP_EQUAL] ->
|
[OP_HASH160, OP_PUSHDATA bs _, OP_EQUAL] ->
|
||||||
PayScriptHash <$> runGetS deserialize bs
|
PayScriptHash <$> runGetS deserialize bs
|
||||||
-- Pay to Witness
|
-- Pay to Witness
|
||||||
[OP_0, OP_PUSHDATA bs OPCODE]
|
[OP_0, OP_PUSHDATA bs OPCODE]
|
||||||
| BS.length bs == 20 -> PayWitnessPKHash <$> runGetS deserialize bs
|
| B.length bs == 20 ->
|
||||||
| BS.length bs == 32 -> PayWitnessScriptHash <$> runGetS deserialize bs
|
PayWitnessPKHash <$> runGetS deserialize bs
|
||||||
| BS.length bs /= 20 && BS.length bs /= 32 ->
|
| B.length bs == 32 ->
|
||||||
Left "Version 0 segwit program must be 20 or 32 bytes long"
|
PayWitnessScriptHash <$> runGetS deserialize bs
|
||||||
-- Other Witness
|
| B.length bs /= 20 && B.length bs /= 32 ->
|
||||||
[ver, OP_PUSHDATA bs _]
|
Left
|
||||||
| isJust (opWitnessVersion ver)
|
"decodeOutput: invalid version 0 segwit \
|
||||||
&& BS.length bs >= 2
|
\(must be 20 or 32 bytes)"
|
||||||
&& BS.length bs <= 40 ->
|
-- Other Witness
|
||||||
Right $ PayWitness (fromJust (opWitnessVersion ver)) bs
|
[ver, OP_PUSHDATA bs _]
|
||||||
-- Provably unspendable data carrier output
|
| Just wv <- opWitnessVersion ver,
|
||||||
[OP_RETURN, OP_PUSHDATA bs _] -> Right $ DataCarrier bs
|
B.length bs >= 2,
|
||||||
-- Pay to MultiSig Keys
|
B.length bs <= 40 ->
|
||||||
_ -> matchPayMulSig s
|
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 :: Word8 -> Maybe ScriptOp
|
||||||
witnessVersionOp 0 = Just OP_0
|
witnessVersionOp 0 = Just OP_0
|
||||||
@ -219,51 +227,51 @@ opWitnessVersion OP_15 = Just 15
|
|||||||
opWitnessVersion OP_16 = Just 16
|
opWitnessVersion OP_16 = Just 16
|
||||||
opWitnessVersion _ = Nothing
|
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'.
|
-- | Computes a 'Script' from a standard 'ScriptOutput'.
|
||||||
encodeOutput :: ScriptOutput -> Script
|
encodeOutput :: Ctx -> ScriptOutput -> Script
|
||||||
encodeOutput s = Script $ case s of
|
encodeOutput ctx s = Script $ case s of
|
||||||
-- Pay to PubKey
|
-- Pay to PubKey
|
||||||
(PayPK k) -> [opPushData $ runPutS $ serialize k, OP_CHECKSIG]
|
(PayPK k) -> [opPushData $ marshal ctx k, OP_CHECKSIG]
|
||||||
-- Pay to PubKey Hash Address
|
-- Pay to PubKey Hash Address
|
||||||
(PayPKHash h) ->
|
(PayPKHash h) ->
|
||||||
[ OP_DUP
|
[ OP_DUP,
|
||||||
, OP_HASH160
|
OP_HASH160,
|
||||||
, opPushData $ runPutS $ serialize h
|
opPushData $ runPutS $ serialize h,
|
||||||
, OP_EQUALVERIFY
|
OP_EQUALVERIFY,
|
||||||
, OP_CHECKSIG
|
OP_CHECKSIG
|
||||||
]
|
]
|
||||||
-- Pay to MultiSig Keys
|
-- Pay to MultiSig Keys
|
||||||
(PayMulSig ps r)
|
(PayMulSig ps r)
|
||||||
| r <= length ps ->
|
| r <= length ps ->
|
||||||
let opM = intToScriptOp r
|
let opM = intToScriptOp r
|
||||||
opN = intToScriptOp $ length ps
|
opN = intToScriptOp $ length ps
|
||||||
keys = map (opPushData . runPutS . serialize) ps
|
keys = map (opPushData . marshal ctx) ps
|
||||||
in opM : keys ++ [opN, OP_CHECKMULTISIG]
|
in opM : keys ++ [opN, OP_CHECKMULTISIG]
|
||||||
| otherwise -> error "encodeOutput: PayMulSig r must be <= than pkeys"
|
| otherwise -> error "encodeOutput: PayMulSig r must be <= than pkeys"
|
||||||
-- Pay to Script Hash Address
|
-- Pay to Script Hash Address
|
||||||
(PayScriptHash h) ->
|
(PayScriptHash h) ->
|
||||||
[OP_HASH160, opPushData $ runPutS $ serialize h, OP_EQUAL]
|
[OP_HASH160, opPushData $ runPutS $ serialize h, OP_EQUAL]
|
||||||
-- Pay to Witness PubKey Hash Address
|
-- Pay to Witness PubKey Hash Address
|
||||||
(PayWitnessPKHash h) ->
|
(PayWitnessPKHash h) ->
|
||||||
[OP_0, opPushData $ runPutS $ serialize h]
|
[OP_0, opPushData $ runPutS $ serialize h]
|
||||||
(PayWitnessScriptHash h) ->
|
(PayWitnessScriptHash h) ->
|
||||||
[OP_0, opPushData $ runPutS $ serialize h]
|
[OP_0, opPushData $ runPutS $ serialize h]
|
||||||
(PayWitness v h) ->
|
(PayWitness v h) ->
|
||||||
[ case witnessVersionOp v of
|
[ case witnessVersionOp v of
|
||||||
Nothing -> error "encodeOutput: invalid witness version"
|
Nothing -> error "encodeOutput: invalid witness version"
|
||||||
Just c -> c
|
Just c -> c,
|
||||||
, opPushData h
|
opPushData h
|
||||||
]
|
]
|
||||||
-- Provably unspendable output
|
-- Provably unspendable output
|
||||||
(DataCarrier d) -> [OP_RETURN, opPushData d]
|
(DataCarrier d) -> [OP_RETURN, opPushData d]
|
||||||
|
|
||||||
-- | Similar to 'encodeOutput' but encodes to a ByteString
|
instance Marshal Ctx ScriptOutput where
|
||||||
encodeOutputBS :: ScriptOutput -> ByteString
|
marshalGet ctx = do
|
||||||
encodeOutputBS = runPutS . serialize . encodeOutput
|
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
|
-- | Encode script as pay-to-script-hash script
|
||||||
toP2SH :: Script -> ScriptOutput
|
toP2SH :: Script -> ScriptOutput
|
||||||
@ -274,59 +282,61 @@ toP2WSH :: Script -> ScriptOutput
|
|||||||
toP2WSH = PayWitnessScriptHash . sha256 . runPutS . serialize
|
toP2WSH = PayWitnessScriptHash . sha256 . runPutS . serialize
|
||||||
|
|
||||||
-- | Match @[OP_N, PubKey1, ..., PubKeyM, OP_M, OP_CHECKMULTISIG]@
|
-- | Match @[OP_N, PubKey1, ..., PubKeyM, OP_M, OP_CHECKMULTISIG]@
|
||||||
matchPayMulSig :: Script -> Either String ScriptOutput
|
matchPayMulSig :: Ctx -> Script -> Either String ScriptOutput
|
||||||
matchPayMulSig (Script ops) = case splitAt (length ops - 2) ops of
|
matchPayMulSig ctx (Script ops) = case splitAt (length ops - 2) ops of
|
||||||
(m : xs, [n, OP_CHECKMULTISIG]) -> do
|
(m : xs, [n, OP_CHECKMULTISIG]) -> do
|
||||||
(intM, intN) <- liftM2 (,) (scriptOpToInt m) (scriptOpToInt n)
|
(intM, intN) <- liftM2 (,) (scriptOpToInt m) (scriptOpToInt n)
|
||||||
if intM <= intN && length xs == intN
|
if intM <= intN && length xs == intN
|
||||||
then liftM2 PayMulSig (go xs) (return intM)
|
then liftM2 PayMulSig (go xs) (return intM)
|
||||||
else Left "matchPayMulSig: Invalid M or N parameters"
|
else Left "matchPayMulSig: Invalid M or N parameters"
|
||||||
_ -> Left "matchPayMulSig: script did not match output template"
|
_ -> Left "matchPayMulSig: script did not match output template"
|
||||||
where
|
where
|
||||||
go (OP_PUSHDATA bs _ : xs) = liftM2 (:) (runGetS deserialize bs) (go xs)
|
go (OP_PUSHDATA bs _ : xs) =
|
||||||
go [] = return []
|
liftM2 (:) (unmarshal ctx bs) (go xs)
|
||||||
go _ = Left "matchPayMulSig: invalid multisig opcode"
|
go [] =
|
||||||
|
Right []
|
||||||
|
go _ =
|
||||||
|
Left "matchPayMulSig: invalid multisig opcode"
|
||||||
|
|
||||||
{- | Sort the public keys of a multisig output in ascending order by comparing
|
-- | Sort the public keys of a multisig output in ascending order by comparing
|
||||||
their compressed serialized representations. Refer to BIP-67.
|
-- their compressed serialized representations. Refer to BIP-67.
|
||||||
-}
|
sortMulSig :: Ctx -> ScriptOutput -> ScriptOutput
|
||||||
sortMulSig :: ScriptOutput -> ScriptOutput
|
sortMulSig ctx out = case out of
|
||||||
sortMulSig out = case out of
|
PayMulSig keys r ->
|
||||||
PayMulSig keys r -> PayMulSig (sortBy (compare `on` (runPutS . serialize)) keys) r
|
PayMulSig
|
||||||
_ -> error "Can only call orderMulSig on PayMulSig scripts"
|
(sortBy (compare `on` marshal ctx) keys)
|
||||||
|
r
|
||||||
|
_ -> error "Can only call orderMulSig on PayMulSig scripts"
|
||||||
|
|
||||||
{- | Data type describing standard transaction input scripts. Input scripts
|
-- | Data type describing standard transaction input scripts. Input scripts
|
||||||
provide the signing data required to unlock the coins of the output they are
|
-- 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
|
-- trying to spend, except in pay-to-witness-public-key-hash and
|
||||||
pay-to-script-hash transactions.
|
-- pay-to-script-hash transactions.
|
||||||
-}
|
|
||||||
data SimpleInput
|
data SimpleInput
|
||||||
= SpendPK
|
= SpendPK
|
||||||
{ -- | transaction signature
|
{ -- | transaction signature
|
||||||
getInputSig :: !TxSignature
|
signature :: !TxSignature
|
||||||
}
|
}
|
||||||
| SpendPKHash
|
| SpendPKHash
|
||||||
{ -- | embedded signature
|
{ -- | embedded signature
|
||||||
getInputSig :: !TxSignature
|
signature :: !TxSignature,
|
||||||
, -- | public key
|
-- | public key
|
||||||
getInputKey :: !PubKeyI
|
key :: !PublicKey
|
||||||
}
|
}
|
||||||
| SpendMulSig
|
| SpendMulSig
|
||||||
{ -- | list of signatures
|
{ -- | list of signatures
|
||||||
getInputMulSigKeys :: ![TxSignature]
|
signatures :: ![TxSignature]
|
||||||
}
|
}
|
||||||
deriving (Eq, Show, Generic, NFData)
|
deriving (Eq, Show, Read, Generic, NFData)
|
||||||
|
|
||||||
{- | Returns true if the input script is spending from a pay-to-public-key
|
-- | Returns true if the input script is spending from a pay-to-public-key
|
||||||
output.
|
-- output.
|
||||||
-}
|
|
||||||
isSpendPK :: ScriptInput -> Bool
|
isSpendPK :: ScriptInput -> Bool
|
||||||
isSpendPK (RegularInput (SpendPK _)) = True
|
isSpendPK (RegularInput (SpendPK _)) = True
|
||||||
isSpendPK _ = False
|
isSpendPK _ = False
|
||||||
|
|
||||||
{- | Returns true if the input script is spending from a pay-to-public-key-hash
|
-- | Returns true if the input script is spending from a pay-to-public-key-hash
|
||||||
output.
|
-- output.
|
||||||
-}
|
|
||||||
isSpendPKHash :: ScriptInput -> Bool
|
isSpendPKHash :: ScriptInput -> Bool
|
||||||
isSpendPKHash (RegularInput (SpendPKHash _ _)) = True
|
isSpendPKHash (RegularInput (SpendPKHash _ _)) = True
|
||||||
isSpendPKHash _ = False
|
isSpendPKHash _ = False
|
||||||
@ -341,91 +351,83 @@ isScriptHashInput :: ScriptInput -> Bool
|
|||||||
isScriptHashInput (ScriptHashInput _ _) = True
|
isScriptHashInput (ScriptHashInput _ _) = True
|
||||||
isScriptHashInput _ = False
|
isScriptHashInput _ = False
|
||||||
|
|
||||||
{- | A redeem script is the output script serialized into the spending input
|
-- | 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.
|
-- script. It must be included in inputs that spend pay-to-script-hash outputs.
|
||||||
-}
|
|
||||||
type RedeemScript = ScriptOutput
|
type RedeemScript = ScriptOutput
|
||||||
|
|
||||||
-- | Standard input script high-level representation.
|
-- | Standard input script high-level representation.
|
||||||
data ScriptInput
|
data ScriptInput
|
||||||
= RegularInput
|
= RegularInput
|
||||||
{ -- | get wrapped simple input
|
{ -- | get wrapped simple input
|
||||||
getRegularInput :: !SimpleInput
|
get :: !SimpleInput
|
||||||
}
|
}
|
||||||
| ScriptHashInput
|
| ScriptHashInput
|
||||||
{ -- | get simple input associated with redeem script
|
{ -- | get simple input associated with redeem script
|
||||||
getScriptHashInput :: !SimpleInput
|
get :: !SimpleInput,
|
||||||
, -- | redeem script
|
-- | redeem script
|
||||||
getScriptHashRedeem :: !RedeemScript
|
redeem :: !RedeemScript
|
||||||
}
|
}
|
||||||
deriving (Eq, Show, Generic, NFData)
|
deriving (Show, Read, Eq, Generic, NFData)
|
||||||
|
|
||||||
-- | Heuristic to decode an input script into one of the standard types.
|
-- | Heuristic to decode an input script into one of the standard types.
|
||||||
decodeSimpleInput :: Network -> Script -> Either String SimpleInput
|
decodeSimpleInput :: Network -> Ctx -> Script -> Either String SimpleInput
|
||||||
decodeSimpleInput net (Script ops) =
|
decodeSimpleInput net ctx (Script ops) =
|
||||||
maybeToEither errMsg $ matchPK ops <|> matchPKHash ops <|> matchMulSig ops
|
maybeToEither errMsg $ matchPK ops <|> matchPKHash ops <|> matchMulSig ops
|
||||||
where
|
where
|
||||||
matchPK [op] = SpendPK <$> f op
|
matchPK [op] = SpendPK <$> f op
|
||||||
matchPK _ = Nothing
|
matchPK _ = Nothing
|
||||||
matchPKHash [op, OP_PUSHDATA pub _] =
|
matchPKHash [op, OP_PUSHDATA pub _] =
|
||||||
SpendPKHash <$> f op <*> eitherToMaybe (runGetS deserialize pub)
|
SpendPKHash <$> f op <*> eitherToMaybe (unmarshal ctx pub)
|
||||||
matchPKHash _ = Nothing
|
matchPKHash _ = Nothing
|
||||||
matchMulSig (x : xs) = do
|
matchMulSig (x : xs) = do
|
||||||
guard $ x == OP_0
|
guard $ x == OP_0
|
||||||
SpendMulSig <$> mapM f xs
|
SpendMulSig <$> mapM f xs
|
||||||
matchMulSig _ = Nothing
|
matchMulSig _ = Nothing
|
||||||
f OP_0 = return TxSignatureEmpty
|
f OP_0 = return TxSignatureEmpty
|
||||||
f (OP_PUSHDATA "" OPCODE) = f OP_0
|
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
|
f _ = Nothing
|
||||||
errMsg = "decodeInput: Could not decode script input"
|
errMsg = "decodeInput: Could not decode script input"
|
||||||
|
|
||||||
{- | Heuristic to decode a 'ScriptInput' from a 'Script'. This function fails if
|
-- | Heuristic to decode a 'ScriptInput' from a 'Script'. This function fails if
|
||||||
the script can not be parsed as a standard script input.
|
-- the script can not be parsed as a standard script input.
|
||||||
-}
|
decodeInput :: Network -> Ctx -> Script -> Either String ScriptInput
|
||||||
decodeInput :: Network -> Script -> Either String ScriptInput
|
decodeInput net ctx s@(Script ops) =
|
||||||
decodeInput net s@(Script ops) =
|
maybeToEither errMsg $ matchSimpleInput <|> matchPayScriptHash
|
||||||
maybeToEither errMsg $ matchSimpleInput <|> matchPayScriptHash
|
|
||||||
where
|
where
|
||||||
matchSimpleInput =
|
matchSimpleInput =
|
||||||
RegularInput <$> eitherToMaybe (decodeSimpleInput net s)
|
RegularInput <$> eitherToMaybe (decodeSimpleInput net ctx s)
|
||||||
matchPayScriptHash =
|
matchPayScriptHash =
|
||||||
case splitAt (length (scriptOps s) - 1) ops of
|
case splitAt (length s.ops - 1) ops of
|
||||||
(is, [OP_PUSHDATA bs _]) -> do
|
(is, [OP_PUSHDATA bs _]) -> do
|
||||||
rdm <- eitherToMaybe $ decodeOutputBS bs
|
rdm <- eitherToMaybe $ unmarshal ctx bs
|
||||||
inp <- eitherToMaybe $ decodeSimpleInput net $ Script is
|
inp <- eitherToMaybe $ decodeSimpleInput net ctx $ Script is
|
||||||
return $ ScriptHashInput inp rdm
|
return $ ScriptHashInput inp rdm
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
errMsg = "decodeInput: Could not decode script input"
|
errMsg = "decodeInput: Could not decode script input"
|
||||||
|
|
||||||
{- | Like 'decodeInput' but decodes directly from a serialized script
|
instance Marshal (Network, Ctx) ScriptInput where
|
||||||
'ByteString'.
|
marshalGet (net, ctx) =
|
||||||
-}
|
deserialize >>= either fail return . decodeInput net ctx
|
||||||
decodeInputBS :: Network -> ByteString -> Either String ScriptInput
|
|
||||||
decodeInputBS net = decodeInput net <=< runGetS deserialize
|
marshalPut (net, ctx) =
|
||||||
|
serialize . encodeInput net ctx
|
||||||
|
|
||||||
-- | Encode a standard input into a script.
|
-- | Encode a standard input into a script.
|
||||||
encodeInput :: ScriptInput -> Script
|
encodeInput :: Network -> Ctx -> ScriptInput -> Script
|
||||||
encodeInput s = case s of
|
encodeInput net ctx s = case s of
|
||||||
RegularInput ri -> encodeSimpleInput ri
|
RegularInput ri -> encodeSimpleInput net ctx ri
|
||||||
ScriptHashInput i o ->
|
ScriptHashInput i o ->
|
||||||
Script $
|
Script $ (encodeSimpleInput net ctx i).ops ++ [opPushData $ marshal ctx o]
|
||||||
scriptOps (encodeSimpleInput i) ++ [opPushData $ encodeOutputBS o]
|
|
||||||
|
|
||||||
{- | Similar to 'encodeInput' but encodes directly to a serialized script
|
|
||||||
'ByteString'.
|
|
||||||
-}
|
|
||||||
encodeInputBS :: ScriptInput -> ByteString
|
|
||||||
encodeInputBS = runPutS . serialize . encodeInput
|
|
||||||
|
|
||||||
-- | Encode a standard 'SimpleInput' into opcodes as an input 'Script'.
|
-- | Encode a standard 'SimpleInput' into opcodes as an input 'Script'.
|
||||||
encodeSimpleInput :: SimpleInput -> Script
|
encodeSimpleInput :: Network -> Ctx -> SimpleInput -> Script
|
||||||
encodeSimpleInput s =
|
encodeSimpleInput net ctx s =
|
||||||
Script $
|
Script $
|
||||||
case s of
|
case s of
|
||||||
SpendPK ts -> [f ts]
|
SpendPK ts -> [f ts]
|
||||||
SpendPKHash ts p -> [f ts, opPushData $ runPutS $ serialize p]
|
SpendPKHash ts p -> [f ts, opPushData $ marshal ctx p]
|
||||||
SpendMulSig xs -> OP_0 : map f xs
|
SpendMulSig xs -> OP_0 : map f xs
|
||||||
where
|
where
|
||||||
f TxSignatureEmpty = OP_0
|
f TxSignatureEmpty = OP_0
|
||||||
f ts = opPushData $ encodeTxSig ts
|
f ts = opPushData $ encodeTxSig net ctx ts
|
||||||
|
@ -1,21 +1,21 @@
|
|||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Transaction
|
-- Module : Haskoin.Transaction
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
Transactions and related code.
|
-- Transactions and related code.
|
||||||
-}
|
module Haskoin.Transaction
|
||||||
module Haskoin.Transaction (
|
( module Common,
|
||||||
module Common,
|
|
||||||
module Builder,
|
module Builder,
|
||||||
module Segwit,
|
module Segwit,
|
||||||
module Taproot,
|
module Taproot,
|
||||||
module Partial,
|
module Partial,
|
||||||
module Genesis,
|
module Genesis,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Haskoin.Transaction.Builder as Builder
|
import Haskoin.Transaction.Builder as Builder
|
||||||
import Haskoin.Transaction.Common as Common
|
import Haskoin.Transaction.Common as Common
|
||||||
|
@ -1,20 +1,24 @@
|
|||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE NoFieldSelectors #-}
|
||||||
|
|
||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Transaction.Builder
|
-- Module : Haskoin.Transaction.Builder
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
Code to simplify transaction creation, signing, fee calculation and coin
|
-- Code to simplify transaction creation, signing, fee calculation and coin
|
||||||
selection.
|
-- selection.
|
||||||
-}
|
module Haskoin.Transaction.Builder
|
||||||
module Haskoin.Transaction.Builder (
|
( -- * Transaction Builder
|
||||||
-- * Transaction Builder
|
|
||||||
buildAddrTx,
|
buildAddrTx,
|
||||||
buildTx,
|
buildTx,
|
||||||
buildInput,
|
buildInput,
|
||||||
@ -43,24 +47,19 @@ module Haskoin.Transaction.Builder (
|
|||||||
guessMSTxFee,
|
guessMSTxFee,
|
||||||
guessTxSize,
|
guessTxSize,
|
||||||
guessMSSize,
|
guessMSSize,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Applicative ((<|>))
|
import Control.Applicative ((<|>))
|
||||||
import Control.Arrow (first)
|
import Control.Arrow (first)
|
||||||
import Control.Monad (foldM, unless)
|
import Control.Monad (foldM, unless)
|
||||||
import Control.Monad.Identity (runIdentity)
|
import Control.Monad.Identity (runIdentity)
|
||||||
import Crypto.Secp256k1
|
import Crypto.Secp256k1
|
||||||
import qualified Data.ByteString as B
|
import Data.ByteString qualified as B
|
||||||
import Data.Bytes.Get
|
import Data.Bytes.Get
|
||||||
import Data.Bytes.Put
|
import Data.Bytes.Put
|
||||||
import Data.Bytes.Serial
|
import Data.Bytes.Serial
|
||||||
import Data.Conduit (
|
import Data.Conduit (ConduitT, Void, await, runConduit, (.|))
|
||||||
ConduitT,
|
|
||||||
Void,
|
|
||||||
await,
|
|
||||||
runConduit,
|
|
||||||
(.|),
|
|
||||||
)
|
|
||||||
import Data.Conduit.List (sourceList)
|
import Data.Conduit.List (sourceList)
|
||||||
import Data.Either (fromRight)
|
import Data.Either (fromRight)
|
||||||
import Data.List (nub)
|
import Data.List (nub)
|
||||||
@ -70,508 +69,554 @@ import Data.Text (Text)
|
|||||||
import Data.Word (Word64)
|
import Data.Word (Word64)
|
||||||
import Haskoin.Address
|
import Haskoin.Address
|
||||||
import Haskoin.Crypto.Hash (Hash256, addressHash)
|
import Haskoin.Crypto.Hash (Hash256, addressHash)
|
||||||
|
import Haskoin.Crypto.Keys.Common
|
||||||
import Haskoin.Crypto.Signature
|
import Haskoin.Crypto.Signature
|
||||||
import Haskoin.Data
|
|
||||||
import Haskoin.Keys.Common
|
|
||||||
import Haskoin.Network.Common
|
import Haskoin.Network.Common
|
||||||
|
import Haskoin.Network.Data
|
||||||
import Haskoin.Script
|
import Haskoin.Script
|
||||||
import Haskoin.Transaction.Builder.Sign (
|
import Haskoin.Transaction.Builder.Sign (SigInput, buildInput, makeSignature, sigKeys)
|
||||||
SigInput (..),
|
import Haskoin.Transaction.Builder.Sign qualified as Sign
|
||||||
buildInput,
|
|
||||||
makeSignature,
|
|
||||||
sigKeys,
|
|
||||||
)
|
|
||||||
import qualified Haskoin.Transaction.Builder.Sign as S
|
|
||||||
import Haskoin.Transaction.Common
|
import Haskoin.Transaction.Common
|
||||||
import Haskoin.Transaction.Segwit (
|
import Haskoin.Transaction.Segwit
|
||||||
decodeWitnessInput,
|
|
||||||
isSegwit,
|
|
||||||
viewWitnessProgram,
|
|
||||||
)
|
|
||||||
import Haskoin.Util
|
import Haskoin.Util
|
||||||
|
|
||||||
{- | Any type can be used as a Coin if it can provide a value in Satoshi.
|
-- | Any type can be used as a Coin if it can provide a value in Satoshi.
|
||||||
The value is used in coin selection algorithms.
|
-- The value is used in coin selection algorithms.
|
||||||
-}
|
|
||||||
class Coin c where
|
class Coin c where
|
||||||
coinValue :: c -> Word64
|
coinValue :: c -> Word64
|
||||||
|
|
||||||
{- | Coin selection algorithm for normal (non-multisig) transactions. This
|
-- | Coin selection algorithm for normal (non-multisig) transactions. This
|
||||||
function returns the selected coins together with the amount of change to
|
-- function returns the selected coins together with the amount of change to
|
||||||
send back to yourself, taking the fee into account.
|
-- send back to yourself, taking the fee into account.
|
||||||
-}
|
|
||||||
chooseCoins ::
|
chooseCoins ::
|
||||||
Coin c =>
|
(Coin c) =>
|
||||||
-- | value to send
|
-- | value to send
|
||||||
Word64 ->
|
Word64 ->
|
||||||
-- | fee per byte
|
-- | fee per byte
|
||||||
Word64 ->
|
Word64 ->
|
||||||
-- | number of outputs (including change)
|
-- | number of outputs (including change)
|
||||||
Int ->
|
Int ->
|
||||||
-- | try to find better solutions
|
-- | try to find better solutions
|
||||||
Bool ->
|
Bool ->
|
||||||
-- | list of ordered coins to choose from
|
-- | list of ordered coins to choose from
|
||||||
[c] ->
|
[c] ->
|
||||||
-- | coin selection and change
|
-- | coin selection and change
|
||||||
Either String ([c], Word64)
|
Either String ([c], Word64)
|
||||||
chooseCoins target fee nOut continue coins =
|
chooseCoins target fee nOut continue coins =
|
||||||
runIdentity . runConduit $
|
runIdentity . runConduit $
|
||||||
sourceList coins .| chooseCoinsSink target fee nOut continue
|
sourceList coins .| chooseCoinsSink target fee nOut continue
|
||||||
|
|
||||||
{- | Coin selection algorithm for normal (non-multisig) transactions. This
|
-- | Coin selection algorithm for normal (non-multisig) transactions. This
|
||||||
function returns the selected coins together with the amount of change to
|
-- 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
|
-- send back to yourself, taking the fee into account. This version uses a Sink
|
||||||
for conduit-based coin selection.
|
-- for conduit-based coin selection.
|
||||||
-}
|
|
||||||
chooseCoinsSink ::
|
chooseCoinsSink ::
|
||||||
(Monad m, Coin c) =>
|
(Monad m, Coin c) =>
|
||||||
-- | value to send
|
-- | value to send
|
||||||
Word64 ->
|
Word64 ->
|
||||||
-- | fee per byte
|
-- | fee per byte
|
||||||
Word64 ->
|
Word64 ->
|
||||||
-- | number of outputs (including change)
|
-- | number of outputs (including change)
|
||||||
Int ->
|
Int ->
|
||||||
-- | try to find better solution
|
-- | try to find better solution
|
||||||
Bool ->
|
Bool ->
|
||||||
-- | coin selection and change
|
-- | coin selection and change
|
||||||
ConduitT c Void m (Either String ([c], Word64))
|
ConduitT c Void m (Either String ([c], Word64))
|
||||||
chooseCoinsSink target fee nOut continue
|
chooseCoinsSink target fee nOut continue
|
||||||
| target > 0 =
|
| target > 0 =
|
||||||
maybeToEither err
|
maybeToEither err
|
||||||
<$> greedyAddSink target (guessTxFee fee nOut) continue
|
<$> greedyAddSink target (guessTxFee fee nOut) continue
|
||||||
| otherwise = return $ Left "chooseCoins: Target must be > 0"
|
| otherwise = return $ Left "chooseCoins: Target must be > 0"
|
||||||
where
|
where
|
||||||
err = "chooseCoins: No solution found"
|
err = "chooseCoins: No solution found"
|
||||||
|
|
||||||
{- | Coin selection algorithm for multisig transactions. This function returns
|
-- | Coin selection algorithm for multisig transactions. This function returns
|
||||||
the selected coins together with the amount of change to send back to
|
-- 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
|
-- yourself, taking the fee into account. This function assumes all the coins
|
||||||
are script hash outputs that send funds to a multisignature address.
|
-- are script hash outputs that send funds to a multisignature address.
|
||||||
-}
|
|
||||||
chooseMSCoins ::
|
chooseMSCoins ::
|
||||||
Coin c =>
|
(Coin c) =>
|
||||||
-- | value to send
|
-- | value to send
|
||||||
Word64 ->
|
Word64 ->
|
||||||
-- | fee per byte
|
-- | fee per byte
|
||||||
Word64 ->
|
Word64 ->
|
||||||
-- | m of n multisig
|
-- | m of n multisig
|
||||||
(Int, Int) ->
|
(Int, Int) ->
|
||||||
-- | number of outputs (including change)
|
-- | number of outputs (including change)
|
||||||
Int ->
|
Int ->
|
||||||
-- | try to find better solution
|
-- | try to find better solution
|
||||||
Bool ->
|
Bool ->
|
||||||
[c] ->
|
[c] ->
|
||||||
-- | coin selection change amount
|
-- | coin selection change amount
|
||||||
Either String ([c], Word64)
|
Either String ([c], Word64)
|
||||||
chooseMSCoins target fee ms nOut continue coins =
|
chooseMSCoins target fee ms nOut continue coins =
|
||||||
runIdentity . runConduit $
|
runIdentity . runConduit $
|
||||||
sourceList coins .| chooseMSCoinsSink target fee ms nOut continue
|
sourceList coins .| chooseMSCoinsSink target fee ms nOut continue
|
||||||
|
|
||||||
{- | Coin selection algorithm for multisig transactions. This function returns
|
-- | Coin selection algorithm for multisig transactions. This function returns
|
||||||
the selected coins together with the amount of change to send back to
|
-- 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
|
-- yourself, taking the fee into account. This function assumes all the coins
|
||||||
are script hash outputs that send funds to a multisignature address. This
|
-- are script hash outputs that send funds to a multisignature address. This
|
||||||
version uses a Sink if you need conduit-based coin selection.
|
-- version uses a Sink if you need conduit-based coin selection.
|
||||||
-}
|
|
||||||
chooseMSCoinsSink ::
|
chooseMSCoinsSink ::
|
||||||
(Monad m, Coin c) =>
|
(Monad m, Coin c) =>
|
||||||
-- | value to send
|
-- | value to send
|
||||||
Word64 ->
|
Word64 ->
|
||||||
-- | fee per byte
|
-- | fee per byte
|
||||||
Word64 ->
|
Word64 ->
|
||||||
-- | m of n multisig
|
-- | m of n multisig
|
||||||
(Int, Int) ->
|
(Int, Int) ->
|
||||||
-- | number of outputs (including change)
|
-- | number of outputs (including change)
|
||||||
Int ->
|
Int ->
|
||||||
-- | try to find better solution
|
-- | try to find better solution
|
||||||
Bool ->
|
Bool ->
|
||||||
-- | coin selection and change
|
-- | coin selection and change
|
||||||
ConduitT c Void m (Either String ([c], Word64))
|
ConduitT c Void m (Either String ([c], Word64))
|
||||||
chooseMSCoinsSink target fee ms nOut continue
|
chooseMSCoinsSink target fee ms nOut continue
|
||||||
| target > 0 =
|
| target > 0 =
|
||||||
maybeToEither err
|
maybeToEither err
|
||||||
<$> greedyAddSink target (guessMSTxFee fee ms nOut) continue
|
<$> greedyAddSink target (guessMSTxFee fee ms nOut) continue
|
||||||
| otherwise = return $ Left "chooseMSCoins: Target must be > 0"
|
| otherwise = return $ Left "chooseMSCoins: Target must be > 0"
|
||||||
where
|
where
|
||||||
err = "chooseMSCoins: No solution found"
|
err = "chooseMSCoins: No solution found"
|
||||||
|
|
||||||
{- | Select coins greedily by starting from an empty solution. If the 'continue'
|
-- | 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
|
-- 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
|
-- 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
|
-- than the previously found solution, the algorithm stops and returns the
|
||||||
previous solution. If the continue flag is not set, the algorithm will return
|
-- previous solution. If the continue flag is not set, the algorithm will return
|
||||||
the first solution it finds in the stream.
|
-- the first solution it finds in the stream.
|
||||||
-}
|
|
||||||
greedyAddSink ::
|
greedyAddSink ::
|
||||||
(Monad m, Coin c) =>
|
(Monad m, Coin c) =>
|
||||||
-- | value to send
|
-- | value to send
|
||||||
Word64 ->
|
Word64 ->
|
||||||
-- | coin count to fee function
|
-- | coin count to fee function
|
||||||
(Int -> Word64) ->
|
(Int -> Word64) ->
|
||||||
-- | try to find better solutions
|
-- | try to find better solutions
|
||||||
Bool ->
|
Bool ->
|
||||||
-- | coin selection and change
|
-- | coin selection and change
|
||||||
ConduitT c Void m (Maybe ([c], Word64))
|
ConduitT c Void m (Maybe ([c], Word64))
|
||||||
greedyAddSink target guessFee continue =
|
greedyAddSink target guessFee continue =
|
||||||
go [] 0 [] 0
|
go [] 0 [] 0
|
||||||
where
|
where
|
||||||
-- The goal is the value we must reach (including the fee) for a certain
|
-- The goal is the value we must reach (including the fee) for a certain
|
||||||
-- amount of selected coins.
|
-- amount of selected coins.
|
||||||
goal c = target + guessFee c
|
goal c = target + guessFee c
|
||||||
go acc aTot ps pTot =
|
go acc aTot ps pTot =
|
||||||
await >>= \case
|
await >>= \case
|
||||||
-- A coin is available in the stream
|
-- A coin is available in the stream
|
||||||
Just coin -> do
|
Just coin -> do
|
||||||
let val = coinValue coin
|
let val = coinValue coin
|
||||||
-- We have reached the goal using this coin
|
-- We have reached the goal using this coin
|
||||||
if val + aTot >= goal (length acc + 1)
|
if val + aTot >= goal (length acc + 1)
|
||||||
then -- If we want to continue searching for better solutions
|
then -- If we want to continue searching for better solutions
|
||||||
|
|
||||||
if continue
|
if continue
|
||||||
then -- This solution is the first one or
|
then -- This solution is the first one or
|
||||||
-- This solution is better than the previous one
|
-- This solution is better than the previous one
|
||||||
|
|
||||||
if pTot == 0 || val + aTot < pTot
|
if pTot == 0 || val + aTot < pTot
|
||||||
then -- Continue searching for better solutions in the stream
|
then -- Continue searching for better solutions in the stream
|
||||||
go [] 0 (coin : acc) (val + aTot)
|
go [] 0 (coin : acc) (val + aTot)
|
||||||
else -- Otherwise, we stop here and return the previous
|
else -- Otherwise, we stop here and return the previous
|
||||||
-- solution
|
-- solution
|
||||||
return $ Just (ps, pTot - goal (length ps))
|
return $ Just (ps, pTot - goal (length ps))
|
||||||
else -- Otherwise, return this solution
|
else -- Otherwise, return this solution
|
||||||
|
|
||||||
return $
|
return $
|
||||||
Just (coin : acc, val + aTot - goal (length acc + 1))
|
Just (coin : acc, val + aTot - goal (length acc + 1))
|
||||||
else -- We have not yet reached the goal. Add the coin to the
|
else -- We have not yet reached the goal. Add the coin to the
|
||||||
-- accumulator
|
-- accumulator
|
||||||
go (coin : acc) (val + aTot) ps pTot
|
go (coin : acc) (val + aTot) ps pTot
|
||||||
-- We reached the end of the stream
|
-- We reached the end of the stream
|
||||||
Nothing ->
|
Nothing ->
|
||||||
return $
|
return $
|
||||||
if null ps
|
if null ps
|
||||||
then -- If no solution was found, return Nothing
|
then -- If no solution was found, return Nothing
|
||||||
Nothing
|
Nothing
|
||||||
else -- If we have a solution, return it
|
else -- If we have a solution, return it
|
||||||
Just (ps, pTot - goal (length ps))
|
Just (ps, pTot - goal (length ps))
|
||||||
|
|
||||||
-- | Estimate tranasction fee to pay based on transaction size estimation.
|
-- | Estimate tranasction fee to pay based on transaction size estimation.
|
||||||
guessTxFee :: Word64 -> Int -> Int -> Word64
|
guessTxFee :: Word64 -> Int -> Int -> Word64
|
||||||
guessTxFee byteFee nOut nIn =
|
guessTxFee byteFee nOut nIn =
|
||||||
byteFee * fromIntegral (guessTxSize nIn [] nOut 0)
|
byteFee * fromIntegral (guessTxSize nIn [] nOut 0)
|
||||||
|
|
||||||
-- | Same as 'guessTxFee' but for multisig transactions.
|
-- | Same as 'guessTxFee' but for multisig transactions.
|
||||||
guessMSTxFee :: Word64 -> (Int, Int) -> Int -> Int -> Word64
|
guessMSTxFee :: Word64 -> (Int, Int) -> Int -> Int -> Word64
|
||||||
guessMSTxFee byteFee ms nOut nIn =
|
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
|
-- | Computes an upper bound on the size of a transaction based on some known
|
||||||
properties of the transaction.
|
-- properties of the transaction.
|
||||||
-}
|
|
||||||
guessTxSize ::
|
guessTxSize ::
|
||||||
-- | number of regular transaction inputs
|
-- | number of regular transaction inputs
|
||||||
Int ->
|
Int ->
|
||||||
-- | multisig m of n for each input
|
-- | multisig m of n for each input
|
||||||
[(Int, Int)] ->
|
[(Int, Int)] ->
|
||||||
-- | number of P2PKH outputs
|
-- | number of P2PKH outputs
|
||||||
Int ->
|
Int ->
|
||||||
-- | number of P2SH outputs
|
-- | number of P2SH outputs
|
||||||
Int ->
|
Int ->
|
||||||
-- | upper bound on transaction size
|
-- | upper bound on transaction size
|
||||||
Int
|
Int
|
||||||
guessTxSize pki msi pkout msout =
|
guessTxSize pki msi pkout msout =
|
||||||
8 + inpLen + inp + outLen + out
|
8 + inpLen + inp + outLen + out
|
||||||
where
|
where
|
||||||
inpLen =
|
inpLen =
|
||||||
B.length
|
B.length
|
||||||
. runPutS
|
. runPutS
|
||||||
. serialize
|
. serialize
|
||||||
. VarInt
|
. VarInt
|
||||||
. fromIntegral
|
. fromIntegral
|
||||||
$ length msi + pki
|
$ length msi + pki
|
||||||
outLen =
|
outLen =
|
||||||
B.length
|
B.length
|
||||||
. runPutS
|
. runPutS
|
||||||
. serialize
|
. serialize
|
||||||
. VarInt
|
. VarInt
|
||||||
. fromIntegral
|
. fromIntegral
|
||||||
$ pkout + msout
|
$ pkout + msout
|
||||||
inp = pki * 148 + sum (map guessMSSize msi)
|
inp = pki * 148 + sum (map guessMSSize msi)
|
||||||
-- (20: hash160) + (5: opcodes) +
|
-- (20: hash160) + (5: opcodes) +
|
||||||
-- (1: script len) + (8: Word64)
|
-- (1: script len) + (8: Word64)
|
||||||
out =
|
out =
|
||||||
pkout * 34
|
pkout * 34
|
||||||
+
|
+
|
||||||
-- (20: hash160) + (3: opcodes) +
|
-- (20: hash160) + (3: opcodes) +
|
||||||
-- (1: script len) + (8: Word64)
|
-- (20: hash160) + (3: opcodes) +
|
||||||
msout * 32
|
-- (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.
|
-- | Size of a multisig P2SH input.
|
||||||
guessMSSize :: (Int, Int) -> Int
|
guessMSSize :: (Int, Int) -> Int
|
||||||
guessMSSize (m, n) =
|
guessMSSize (m, n) =
|
||||||
-- OutPoint (36) + Sequence (4) + Script
|
-- OutPoint (36) + Sequence (4) + Script
|
||||||
40
|
40
|
||||||
+ fromIntegral (B.length $ runPutS . serialize $ VarInt $ fromIntegral scp)
|
+ fromIntegral (B.length $ runPutS . serialize $ VarInt $ fromIntegral scp)
|
||||||
+ scp
|
+ scp
|
||||||
where
|
where
|
||||||
-- OP_M + n*PubKey + OP_N + OP_CHECKMULTISIG
|
-- OP_M + n*PubKey + OP_N + OP_CHECKMULTISIG
|
||||||
|
|
||||||
rdm =
|
rdm =
|
||||||
fromIntegral $
|
fromIntegral $
|
||||||
B.length $ runPutS $ serialize $ opPushData $ B.replicate (n * 34 + 3) 0
|
B.length $
|
||||||
|
runPutS $
|
||||||
|
serialize $
|
||||||
|
opPushData $
|
||||||
|
B.replicate (n * 34 + 3) 0
|
||||||
-- Redeem + m*sig + OP_0
|
-- Redeem + m*sig + OP_0
|
||||||
scp = rdm + m * 73 + 1
|
scp = rdm + m * 73 + 1
|
||||||
|
|
||||||
{- Build a new Tx -}
|
{- Build a new Tx -}
|
||||||
|
|
||||||
{- | Build a transaction by providing a list of outpoints as inputs
|
-- | Build a transaction by providing a list of outpoints as inputs
|
||||||
and a list of recipient addresses and amounts as outputs.
|
-- and a list of recipient addresses and amounts as outputs.
|
||||||
-}
|
buildAddrTx :: Network -> Ctx -> [OutPoint] -> [(Text, Word64)] -> Either String Tx
|
||||||
buildAddrTx :: Network -> [OutPoint] -> [(Text, Word64)] -> Either String Tx
|
buildAddrTx net ctx ops rcps =
|
||||||
buildAddrTx net ops rcps =
|
buildTx ctx ops <$> mapM f rcps
|
||||||
buildTx ops <$> mapM f rcps
|
|
||||||
where
|
where
|
||||||
f (aTxt, v) =
|
f (aTxt, v) =
|
||||||
maybeToEither ("buildAddrTx: Invalid address " <> cs aTxt) $ do
|
maybeToEither ("buildAddrTx: Invalid address " <> cs aTxt) $ do
|
||||||
a <- textToAddr net aTxt
|
a <- textToAddr net aTxt
|
||||||
let o = addressToOutput a
|
let o = addressToOutput a
|
||||||
return (o, v)
|
return (o, v)
|
||||||
|
|
||||||
{- | Build a transaction by providing a list of outpoints as inputs
|
-- | Build a transaction by providing a list of outpoints as inputs
|
||||||
and a list of 'ScriptOutput' and amounts as outputs.
|
-- and a list of 'ScriptOutput' and amounts as outputs.
|
||||||
-}
|
buildTx :: Ctx -> [OutPoint] -> [(ScriptOutput, Word64)] -> Tx
|
||||||
buildTx :: [OutPoint] -> [(ScriptOutput, Word64)] -> Tx
|
buildTx ctx ops rcpts =
|
||||||
buildTx ops rcpts =
|
Tx 1 (toIn <$> ops) (toOut <$> rcpts) [] 0
|
||||||
Tx 1 (toIn <$> ops) (toOut <$> rcpts) [] 0
|
|
||||||
where
|
where
|
||||||
toIn op = TxIn op B.empty maxBound
|
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
|
-- | Sign a transaction by providing the 'SigInput' signing parameters and a
|
||||||
list of private keys. The signature is computed deterministically as defined
|
-- list of private keys. The signature is computed deterministically as defined
|
||||||
in RFC-6979.
|
-- in RFC-6979.
|
||||||
|
--
|
||||||
Example: P2SH-P2WKH
|
-- Example: P2SH-P2WKH
|
||||||
|
--
|
||||||
> sigIn = SigInput (PayWitnessPKHash h) 100000 op sigHashAll Nothing
|
-- > sigIn = SigInput (PayWitnessPKHash h) 100000 op sigHashAll Nothing
|
||||||
> signedTx = signTx btc unsignedTx [sigIn] [key]
|
-- > signedTx = signTx btc unsignedTx [sigIn] [key]
|
||||||
|
--
|
||||||
Example: P2SH-P2WSH multisig
|
-- Example: P2SH-P2WSH multisig
|
||||||
|
--
|
||||||
> sigIn = SigInput (PayWitnessScriptHash h) 100000 op sigHashAll (Just $ PayMulSig [p1,p2,p3] 2)
|
-- > sigIn = SigInput (PayWitnessScriptHash h) 100000 op sigHashAll (Just $ PayMulSig [p1,p2,p3] 2)
|
||||||
> signedTx = signTx btc unsignedTx [sigIn] [k1,k3]
|
-- > signedTx = signTx btc unsignedTx [sigIn] [k1,k3]
|
||||||
-}
|
|
||||||
signTx ::
|
signTx ::
|
||||||
Network ->
|
Network ->
|
||||||
-- | transaction to sign
|
Ctx ->
|
||||||
Tx ->
|
-- | transaction to sign
|
||||||
-- | signing parameters
|
Tx ->
|
||||||
[SigInput] ->
|
-- | signing parameters
|
||||||
-- | private keys to sign with
|
[SigInput] ->
|
||||||
[SecKey] ->
|
-- | private keys to sign with
|
||||||
-- | signed transaction
|
[SecKey] ->
|
||||||
Either String Tx
|
-- | signed transaction
|
||||||
signTx net tx si = S.signTx net tx $ notNested <$> si
|
Either String Tx
|
||||||
|
signTx net ctx tx si = Sign.signTx net ctx tx $ notNested <$> si
|
||||||
where
|
where
|
||||||
notNested s = (s, False)
|
notNested s = (s, False)
|
||||||
|
|
||||||
{- | This function differs from 'signTx' by assuming all segwit inputs are
|
-- | This function differs from 'signTx' by assuming all segwit inputs are
|
||||||
P2SH-nested. Use the same signing parameters for segwit inputs as in 'signTx'.
|
-- P2SH-nested. Use the same signing parameters for segwit inputs as in 'signTx'.
|
||||||
-}
|
|
||||||
signNestedWitnessTx ::
|
signNestedWitnessTx ::
|
||||||
Network ->
|
Network ->
|
||||||
-- | transaction to sign
|
Ctx ->
|
||||||
Tx ->
|
-- | transaction to sign
|
||||||
-- | signing parameters
|
Tx ->
|
||||||
[SigInput] ->
|
-- | signing parameters
|
||||||
-- | private keys to sign with
|
[SigInput] ->
|
||||||
[SecKey] ->
|
-- | private keys to sign with
|
||||||
-- | signed transaction
|
[SecKey] ->
|
||||||
Either String Tx
|
-- | signed transaction
|
||||||
signNestedWitnessTx net tx si = S.signTx net tx $ nested <$> si
|
Either String Tx
|
||||||
|
signNestedWitnessTx net ctx tx si = Sign.signTx net ctx tx $ nested <$> si
|
||||||
where
|
where
|
||||||
-- NOTE: the nesting flag is ignored for non-segwit inputs
|
-- NOTE: the nesting flag is ignored for non-segwit inputs
|
||||||
nested s = (s, True)
|
nested s = (s, True)
|
||||||
|
|
||||||
-- | Sign a single input in a transaction deterministically (RFC-6979).
|
-- | Sign a single input in a transaction deterministically (RFC-6979).
|
||||||
signInput :: Network -> Tx -> Int -> SigInput -> SecKeyI -> Either String Tx
|
signInput ::
|
||||||
signInput net tx i si = S.signInput net tx i (si, False)
|
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
|
-- | Like 'signInput' but treat segwit inputs as nested
|
||||||
signNestedInput :: Network -> Tx -> Int -> SigInput -> SecKeyI -> Either String Tx
|
signNestedInput ::
|
||||||
signNestedInput net tx i si = S.signInput net tx i (si, True)
|
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
|
-- | 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
|
-- the user to provide the 'SigInput' in any order. Users can also provide only
|
||||||
a partial set of 'SigInput' entries.
|
-- a partial set of 'SigInput' entries.
|
||||||
-}
|
|
||||||
findSigInput :: [SigInput] -> [TxIn] -> [(SigInput, Int)]
|
findSigInput :: [SigInput] -> [TxIn] -> [(SigInput, Int)]
|
||||||
findSigInput = S.findInputIndex sigInputOP
|
findSigInput = Sign.findInputIndex (.outpoint)
|
||||||
|
|
||||||
{- Merge multisig transactions -}
|
{- Merge multisig transactions -}
|
||||||
|
|
||||||
{- | Merge partially-signed multisig transactions. This function does not
|
-- | Merge partially-signed multisig transactions. This function does not
|
||||||
support segwit and P2SH-segwit inputs. Use PSBTs to merge transactions with
|
-- support segwit and P2SH-segwit inputs. Use PSBTs to merge transactions with
|
||||||
segwit inputs.
|
-- segwit inputs.
|
||||||
-}
|
|
||||||
mergeTxs ::
|
mergeTxs ::
|
||||||
Network -> [Tx] -> [(ScriptOutput, Word64, OutPoint)] -> Either String Tx
|
Network ->
|
||||||
mergeTxs net txs os
|
Ctx ->
|
||||||
| null txs = Left "Transaction list is empty"
|
[Tx] ->
|
||||||
| length (nub emptyTxs) /= 1 = Left "Transactions do not match"
|
[(ScriptOutput, Word64, OutPoint)] ->
|
||||||
| length txs == 1 = return $ head txs
|
Either String Tx
|
||||||
| otherwise = foldM (mergeTxInput net txs) (head emptyTxs) outs
|
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
|
where
|
||||||
zipOp = zip (matchTemplate os (txIn $ head txs) f) [0 ..]
|
zipOp = zip (matchTemplate os (head txs).inputs f) [0 ..]
|
||||||
outs =
|
outs =
|
||||||
map (first $ (\(o, v, _) -> (o, v)) . fromJust) $
|
map (first $ (\(o, v, _) -> (o, v)) . fromJust) $
|
||||||
filter (isJust . fst) zipOp
|
filter (isJust . fst) zipOp
|
||||||
f (_, _, o) txin = o == prevOutput txin
|
f (_, _, o) txin = o == txin.outpoint
|
||||||
emptyTxs = map (\tx -> foldl clearInput tx outs) txs
|
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) =
|
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
|
-- | Merge input from partially-signed multisig transactions. This function
|
||||||
does not support segwit and P2SH-segwit inputs.
|
-- does not support segwit and P2SH-segwit inputs.
|
||||||
-}
|
|
||||||
mergeTxInput ::
|
mergeTxInput ::
|
||||||
Network ->
|
Network ->
|
||||||
[Tx] ->
|
Ctx ->
|
||||||
Tx ->
|
[Tx] ->
|
||||||
((ScriptOutput, Word64), Int) ->
|
Tx ->
|
||||||
Either String Tx
|
((ScriptOutput, Word64), Int) ->
|
||||||
mergeTxInput net txs tx ((so, val), i) = do
|
Either String Tx
|
||||||
-- Ignore transactions with empty inputs
|
mergeTxInput net ctx txs tx ((so, val), i) = do
|
||||||
let ins = map (scriptInput . (!! i) . txIn) txs
|
-- Ignore transactions with empty inputs
|
||||||
sigRes <- mapM extractSigs $ filter (not . B.null) ins
|
let ins = map ((.script) . (!! i) . (.inputs)) txs
|
||||||
let rdm = snd $ head sigRes
|
sigRes <- mapM extractSigs $ filter (not . B.null) ins
|
||||||
unless (all ((== rdm) . snd) sigRes) $ Left "Redeem scripts do not match"
|
let rdm = snd $ head sigRes
|
||||||
si <- encodeInputBS <$> go (nub $ concatMap fst sigRes) so rdm
|
unless (all ((== rdm) . snd) sigRes) $ Left "Redeem scripts do not match"
|
||||||
let ins' = updateIndex i (txIn tx) (\ti -> ti{scriptInput = si})
|
si <- marshal (net, ctx) <$> go (nub $ concatMap fst sigRes) so rdm
|
||||||
return $ Tx (txVersion tx) ins' (txOut tx) [] (txLockTime tx)
|
let ins' = updateIndex i tx.inputs (\TxIn {..} -> TxIn {script = si, ..})
|
||||||
|
return $ Tx tx.version ins' tx.outputs [] tx.locktime
|
||||||
where
|
where
|
||||||
go allSigs out rdmM =
|
go allSigs out rdmM =
|
||||||
case out of
|
case out of
|
||||||
PayMulSig msPubs r ->
|
PayMulSig msPubs r ->
|
||||||
let sigs =
|
let sigs =
|
||||||
take r $
|
take r $
|
||||||
catMaybes $ matchTemplate allSigs msPubs $ f out
|
catMaybes $
|
||||||
in return $ RegularInput $ SpendMulSig sigs
|
matchTemplate allSigs msPubs $
|
||||||
PayScriptHash _ ->
|
f out
|
||||||
case rdmM of
|
in return $ RegularInput $ SpendMulSig sigs
|
||||||
Just rdm -> do
|
PayScriptHash _ ->
|
||||||
si <- go allSigs rdm Nothing
|
case rdmM of
|
||||||
return $ ScriptHashInput (getRegularInput si) rdm
|
Just rdm -> do
|
||||||
_ -> Left "Invalid output script type"
|
si <- go allSigs rdm Nothing
|
||||||
|
return $ ScriptHashInput si.get rdm
|
||||||
_ -> Left "Invalid output script type"
|
_ -> Left "Invalid output script type"
|
||||||
|
_ -> Left "Invalid output script type"
|
||||||
extractSigs si =
|
extractSigs si =
|
||||||
case decodeInputBS net si of
|
case unmarshal (net, ctx) si of
|
||||||
Right (RegularInput (SpendMulSig sigs)) -> Right (sigs, Nothing)
|
Right (RegularInput (SpendMulSig sigs)) ->
|
||||||
Right (ScriptHashInput (SpendMulSig sigs) rdm) ->
|
Right (sigs, Nothing)
|
||||||
Right (sigs, Just rdm)
|
Right (ScriptHashInput (SpendMulSig sigs) rdm) ->
|
||||||
_ -> Left "Invalid script input type"
|
Right (sigs, Just rdm)
|
||||||
|
_ -> Left "Invalid script input type"
|
||||||
f out (TxSignature x sh) p =
|
f out (TxSignature x sh) p =
|
||||||
verifyHashSig
|
verifyHashSig
|
||||||
(txSigHash net tx (encodeOutput out) val i sh)
|
ctx
|
||||||
x
|
(txSigHash net tx (encodeOutput ctx out) val i sh)
|
||||||
(pubKeyPoint p)
|
x
|
||||||
|
p.point
|
||||||
f _ TxSignatureEmpty _ = False
|
f _ TxSignatureEmpty _ = False
|
||||||
|
|
||||||
{- Tx verification -}
|
{- Tx verification -}
|
||||||
|
|
||||||
-- | Verify if a transaction is valid and all of its inputs are standard.
|
-- | Verify if a transaction is valid and all of its inputs are standard.
|
||||||
verifyStdTx :: Network -> Tx -> [(ScriptOutput, Word64, OutPoint)] -> Bool
|
verifyStdTx ::
|
||||||
verifyStdTx net tx xs =
|
Network -> Ctx -> Tx -> [(ScriptOutput, Word64, OutPoint)] -> Bool
|
||||||
not (null (txIn tx)) && all go (zip (matchTemplate xs (txIn tx) f) [0 ..])
|
verifyStdTx net ctx tx xs =
|
||||||
|
not (null tx.inputs) && all go (zip (matchTemplate xs tx.inputs f) [0 ..])
|
||||||
where
|
where
|
||||||
f (_, _, o) txin = o == prevOutput txin
|
f (_, _, o) txin = o == txin.outpoint
|
||||||
go (Just (so, val, _), i) = verifyStdInput net tx i so val
|
go (Just (so, val, _), i) = verifyStdInput net ctx tx i so val
|
||||||
go _ = False
|
go _ = False
|
||||||
|
|
||||||
-- | Verify if a transaction input is valid and standard.
|
-- | Verify if a transaction input is valid and standard.
|
||||||
verifyStdInput :: Network -> Tx -> Int -> ScriptOutput -> Word64 -> Bool
|
verifyStdInput :: Network -> Ctx -> Tx -> Int -> ScriptOutput -> Word64 -> Bool
|
||||||
verifyStdInput net tx i so0 val
|
verifyStdInput net ctx tx i so0 val
|
||||||
| isSegwit so0 =
|
| isSegwit so0 =
|
||||||
fromRight False $ (inp == mempty &&) . verifySegwitInput so0 <$> wp so0
|
fromRight False $ (inp == mempty &&) . verifySegwitInput so0 <$> wp so0
|
||||||
| otherwise =
|
| otherwise =
|
||||||
fromRight False $
|
fromRight False $
|
||||||
(verifyLegacyInput so0 <$> decodeInputBS net inp)
|
(verifyLegacyInput so0 <$> unmarshal (net, ctx) inp)
|
||||||
<|> (nestedScriptOutput >>= \so -> verifyNestedInput so0 so <$> wp so)
|
<|> (nestedScriptOutput >>= \so -> verifyNestedInput so0 so <$> wp so)
|
||||||
where
|
where
|
||||||
inp = scriptInput $ txIn tx !! i
|
inp = (tx.inputs !! i).script
|
||||||
theTxSigHash so = S.makeSigHash net tx i so val
|
theTxSigHash so = Sign.makeSigHash net ctx tx i so val
|
||||||
|
|
||||||
ws :: WitnessStack
|
ws :: WitnessStack
|
||||||
ws
|
ws
|
||||||
| length (txWitness tx) > i = txWitness tx !! i
|
| length tx.witness > i = tx.witness !! i
|
||||||
| otherwise = []
|
| otherwise = []
|
||||||
|
|
||||||
wp :: ScriptOutput -> Either String (Maybe ScriptOutput, SimpleInput)
|
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 :: Either String ScriptOutput
|
||||||
nestedScriptOutput =
|
nestedScriptOutput =
|
||||||
scriptOps <$> runGetS deserialize inp >>= \case
|
runGetS deserialize inp >>= dec . ops
|
||||||
[OP_PUSHDATA bs _] -> decodeOutputBS bs
|
where
|
||||||
_ -> Left "nestedScriptOutput: not a nested output"
|
ops (Script ops') = ops'
|
||||||
|
dec = \case
|
||||||
|
[OP_PUSHDATA bs _] -> unmarshal ctx bs
|
||||||
|
_ -> Left "nestedScriptOutput: not a nested output"
|
||||||
|
|
||||||
verifyLegacyInput :: ScriptOutput -> ScriptInput -> Bool
|
verifyLegacyInput :: ScriptOutput -> ScriptInput -> Bool
|
||||||
verifyLegacyInput so si = case (so, si) of
|
verifyLegacyInput so si = case (so, si) of
|
||||||
(PayPK pub, RegularInput (SpendPK (TxSignature sig sh))) ->
|
(PayPK pub, RegularInput (SpendPK (TxSignature sig sh))) ->
|
||||||
verifyHashSig (theTxSigHash so sh Nothing) sig (pubKeyPoint pub)
|
verifyHashSig ctx (theTxSigHash so sh Nothing) sig pub.point
|
||||||
(PayPKHash h, RegularInput (SpendPKHash (TxSignature sig sh) pub)) ->
|
(PayPKHash h, RegularInput (SpendPKHash (TxSignature sig sh) pub)) ->
|
||||||
pubKeyAddr pub == p2pkhAddr h
|
pubKeyAddr ctx pub == p2pkhAddr h
|
||||||
&& verifyHashSig (theTxSigHash so sh Nothing) sig (pubKeyPoint pub)
|
&& verifyHashSig ctx (theTxSigHash so sh Nothing) sig pub.point
|
||||||
(PayMulSig pubs r, RegularInput (SpendMulSig sigs)) ->
|
(PayMulSig pubs r, RegularInput (SpendMulSig sigs)) ->
|
||||||
countMulSig net tx out val i (pubKeyPoint <$> pubs) sigs == r
|
countMulSig net ctx tx out val i ((.point) <$> pubs) sigs == r
|
||||||
(PayScriptHash h, ScriptHashInput si' rdm) ->
|
(PayScriptHash h, ScriptHashInput si' rdm) ->
|
||||||
payToScriptAddress rdm == p2shAddr h && verifyLegacyInput rdm (RegularInput si')
|
payToScriptAddress ctx rdm == p2shAddr h && verifyLegacyInput rdm (RegularInput si')
|
||||||
_ -> False
|
_ -> False
|
||||||
where
|
where
|
||||||
out = encodeOutput so
|
out = encodeOutput ctx so
|
||||||
|
|
||||||
verifySegwitInput ::
|
verifySegwitInput ::
|
||||||
ScriptOutput -> (Maybe ScriptOutput, SimpleInput) -> Bool
|
ScriptOutput -> (Maybe ScriptOutput, SimpleInput) -> Bool
|
||||||
verifySegwitInput so (rdm, si) = case (so, rdm, si) of
|
verifySegwitInput so (rdm, si) = case (so, rdm, si) of
|
||||||
(PayWitnessPKHash h, Nothing, SpendPKHash (TxSignature sig sh) pub) ->
|
( PayWitnessPKHash h,
|
||||||
pubKeyWitnessAddr pub == p2wpkhAddr h
|
Nothing,
|
||||||
&& verifyHashSig (theTxSigHash so sh Nothing) sig (pubKeyPoint pub)
|
SpendPKHash (TxSignature sig sh) pub
|
||||||
(PayWitnessScriptHash h, Just rdm'@(PayPK pub), SpendPK (TxSignature sig sh)) ->
|
) ->
|
||||||
payToWitnessScriptAddress rdm' == p2wshAddr h
|
let keytest = pubKeyWitnessAddr ctx pub == p2wpkhAddr h
|
||||||
&& verifyHashSig (theTxSigHash so sh $ Just rdm') sig (pubKeyPoint pub)
|
sighash = theTxSigHash so sh Nothing
|
||||||
(PayWitnessScriptHash h, Just rdm'@(PayPKHash kh), SpendPKHash (TxSignature sig sh) pub) ->
|
pkpoint = pub.point
|
||||||
payToWitnessScriptAddress rdm' == p2wshAddr h
|
verify = verifyHashSig ctx sighash sig pkpoint
|
||||||
&& addressHash (runPutS (serialize pub)) == kh
|
in keytest && verify
|
||||||
&& verifyHashSig (theTxSigHash so sh $ Just rdm') sig (pubKeyPoint pub)
|
( PayWitnessScriptHash h,
|
||||||
(PayWitnessScriptHash h, Just rdm'@(PayMulSig pubs r), SpendMulSig sigs) ->
|
Just rdm'@(PayPK pub),
|
||||||
payToWitnessScriptAddress rdm' == p2wshAddr h
|
SpendPK (TxSignature sig sh)
|
||||||
&& countMulSig' (\sh -> theTxSigHash so sh $ Just rdm') (pubKeyPoint <$> pubs) sigs == r
|
) ->
|
||||||
_ -> False
|
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 ::
|
verifyNestedInput ::
|
||||||
ScriptOutput -> ScriptOutput -> (Maybe RedeemScript, SimpleInput) -> Bool
|
ScriptOutput -> ScriptOutput -> (Maybe RedeemScript, SimpleInput) -> Bool
|
||||||
verifyNestedInput so so' x = case so of
|
verifyNestedInput so so' x = case so of
|
||||||
PayScriptHash h -> payToScriptAddress so' == p2shAddr h && verifySegwitInput so' x
|
PayScriptHash h -> payToScriptAddress ctx so' == p2shAddr h && verifySegwitInput so' x
|
||||||
_ -> False
|
_ -> False
|
||||||
|
|
||||||
-- | Count the number of valid signatures for a multi-signature transaction.
|
-- | Count the number of valid signatures for a multi-signature transaction.
|
||||||
countMulSig ::
|
countMulSig ::
|
||||||
Network ->
|
Network ->
|
||||||
Tx ->
|
Ctx ->
|
||||||
Script ->
|
Tx ->
|
||||||
Word64 ->
|
Script ->
|
||||||
Int ->
|
Word64 ->
|
||||||
[PubKey] ->
|
Int ->
|
||||||
[TxSignature] ->
|
[PubKey] ->
|
||||||
Int
|
[TxSignature] ->
|
||||||
countMulSig net tx out val i =
|
Int
|
||||||
countMulSig' h
|
countMulSig net ctx tx out val i =
|
||||||
|
countMulSig' ctx h
|
||||||
where
|
where
|
||||||
h = txSigHash net tx out val i
|
h = txSigHash net tx out val i
|
||||||
|
|
||||||
countMulSig' :: (SigHash -> Hash256) -> [PubKey] -> [TxSignature] -> Int
|
countMulSig' :: Ctx -> (SigHash -> Hash256) -> [PubKey] -> [TxSignature] -> Int
|
||||||
countMulSig' _ [] _ = 0
|
countMulSig' _ _ [] _ = 0
|
||||||
countMulSig' _ _ [] = 0
|
countMulSig' _ _ _ [] = 0
|
||||||
countMulSig' h (_ : pubs) (TxSignatureEmpty : sigs) = countMulSig' h pubs sigs
|
countMulSig' ctx h (_ : pubs) (TxSignatureEmpty : sigs) =
|
||||||
countMulSig' h (pub : pubs) sigs@(TxSignature sig sh : sigs')
|
countMulSig' ctx h pubs sigs
|
||||||
| verifyHashSig (h sh) sig pub = 1 + countMulSig' h pubs sigs'
|
countMulSig' ctx h (pub : pubs) sigs@(TxSignature sig sh : sigs')
|
||||||
| otherwise = countMulSig' h pubs 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 DeriveAnyClass #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE NoFieldSelectors #-}
|
||||||
|
|
||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Transaction.Builder.Sign
|
-- Module : Haskoin.Transaction.Builder.Sign
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
Types and logic for signing transactions.
|
-- Types and logic for signing transactions.
|
||||||
-}
|
module Haskoin.Transaction.Builder.Sign
|
||||||
module Haskoin.Transaction.Builder.Sign (
|
( SigInput (..),
|
||||||
SigInput (..),
|
|
||||||
makeSignature,
|
makeSignature,
|
||||||
makeSigHash,
|
makeSigHash,
|
||||||
signTx,
|
signTx,
|
||||||
@ -22,298 +27,296 @@ module Haskoin.Transaction.Builder.Sign (
|
|||||||
signInput,
|
signInput,
|
||||||
buildInput,
|
buildInput,
|
||||||
sigKeys,
|
sigKeys,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.DeepSeq (NFData)
|
import Control.DeepSeq
|
||||||
import Control.Monad (foldM, when)
|
import Control.Monad
|
||||||
import Data.Aeson (
|
import Crypto.Secp256k1
|
||||||
FromJSON,
|
import Data.Aeson
|
||||||
ToJSON (..),
|
import Data.Aeson.Encoding
|
||||||
object,
|
|
||||||
pairs,
|
|
||||||
parseJSON,
|
|
||||||
withObject,
|
|
||||||
(.:),
|
|
||||||
(.:?),
|
|
||||||
(.=),
|
|
||||||
)
|
|
||||||
import Data.Bytes.Get
|
import Data.Bytes.Get
|
||||||
import Data.Bytes.Put
|
import Data.Bytes.Put
|
||||||
import Data.Bytes.Serial
|
import Data.Bytes.Serial
|
||||||
import Data.Either (rights)
|
import Data.Either
|
||||||
import Data.Hashable (Hashable)
|
import Data.Hashable
|
||||||
import Data.List (find, nub)
|
import Data.List
|
||||||
import Data.Maybe (
|
import Data.Maybe
|
||||||
catMaybes,
|
import Data.Word
|
||||||
fromMaybe,
|
import GHC.Generics
|
||||||
mapMaybe,
|
import Haskoin.Address
|
||||||
maybeToList,
|
import Haskoin.Crypto.Hash
|
||||||
)
|
import Haskoin.Crypto.Keys.Common
|
||||||
import Data.Word (Word64)
|
import Haskoin.Crypto.Signature
|
||||||
import GHC.Generics (Generic)
|
import Haskoin.Network.Data
|
||||||
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 Haskoin.Script
|
import Haskoin.Script
|
||||||
import Haskoin.Transaction.Common
|
import Haskoin.Transaction.Common
|
||||||
import Haskoin.Transaction.Segwit
|
import Haskoin.Transaction.Segwit
|
||||||
import Haskoin.Util (matchTemplate, updateIndex)
|
import Haskoin.Util
|
||||||
|
|
||||||
{- | Data type used to specify the signing parameters of a transaction input.
|
-- | Data type used to specify the signing parameters of a transaction input.
|
||||||
To sign an input, the previous output script, outpoint and sighash are
|
-- To sign an input, the previous output script, outpoint and sighash are
|
||||||
required. When signing a pay to script hash output, an additional redeem
|
-- required. When signing a pay to script hash output, an additional redeem
|
||||||
script is required.
|
-- script is required.
|
||||||
-}
|
|
||||||
data SigInput = SigInput
|
data SigInput = SigInput
|
||||||
{ -- | output script to spend
|
{ -- | output script to spend
|
||||||
-- ^ output script value
|
-- ^ output script value
|
||||||
sigInputScript :: !ScriptOutput
|
script :: !ScriptOutput,
|
||||||
, -- | output script value
|
-- | output script value
|
||||||
-- ^ outpoint to spend
|
-- ^ outpoint to spend
|
||||||
sigInputValue :: !Word64
|
value :: !Word64,
|
||||||
, -- | outpoint to spend
|
-- | outpoint to spend
|
||||||
-- ^ signature type
|
-- ^ signature type
|
||||||
sigInputOP :: !OutPoint
|
outpoint :: !OutPoint,
|
||||||
, -- | signature type
|
-- | signature type
|
||||||
-- ^ redeem script
|
-- ^ redeem script
|
||||||
sigInputSH :: !SigHash
|
sighash :: !SigHash,
|
||||||
, -- | redeem script
|
-- | redeem script
|
||||||
sigInputRedeem :: !(Maybe RedeemScript)
|
redeem :: !(Maybe RedeemScript)
|
||||||
}
|
}
|
||||||
deriving (Eq, Show, Read, Generic, Hashable, NFData)
|
deriving (Show, Read, Eq, Generic, NFData)
|
||||||
|
|
||||||
instance ToJSON SigInput where
|
instance MarshalJSON Ctx SigInput where
|
||||||
toJSON (SigInput so val op sh rdm) =
|
marshalValue ctx (SigInput s v o h r) =
|
||||||
object $
|
object $
|
||||||
[ "pkscript" .= so
|
[ "pkscript" .= marshalValue ctx s,
|
||||||
, "value" .= val
|
"value" .= v,
|
||||||
, "outpoint" .= op
|
"outpoint" .= o,
|
||||||
, "sighash" .= sh
|
"sighash" .= h
|
||||||
]
|
]
|
||||||
++ ["redeem" .= r | r <- maybeToList rdm]
|
++ [ "redeem" .= marshalValue ctx r
|
||||||
toEncoding (SigInput so val op sh rdm) =
|
| r <- maybeToList r
|
||||||
pairs $
|
]
|
||||||
"pkscript" .= so
|
|
||||||
<> "value" .= val
|
|
||||||
<> "outpoint" .= op
|
|
||||||
<> "sighash" .= sh
|
|
||||||
<> maybe mempty ("redeem" .=) rdm
|
|
||||||
|
|
||||||
instance FromJSON SigInput where
|
marshalEncoding ctx (SigInput s v o h r) =
|
||||||
parseJSON =
|
pairs $
|
||||||
withObject "SigInput" $ \o ->
|
mconcat
|
||||||
SigInput <$> o .: "pkscript"
|
[ "pkscript" `pair` marshalEncoding ctx s,
|
||||||
<*> o .: "value"
|
"value" `pair` word64 v,
|
||||||
<*> o .: "outpoint"
|
"outpoint" `pair` toEncoding o,
|
||||||
<*> o .: "sighash"
|
"sighash" `pair` toEncoding h,
|
||||||
<*> o .:? "redeem"
|
maybe mempty (pair "redeem" . marshalEncoding ctx) r
|
||||||
|
]
|
||||||
|
|
||||||
{- | Sign a transaction by providing the 'SigInput' signing parameters and a
|
unmarshalValue ctx =
|
||||||
list of private keys. The signature is computed deterministically as defined
|
withObject "SigInput" $ \o ->
|
||||||
in RFC-6979.
|
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 ::
|
signTx ::
|
||||||
Network ->
|
Network ->
|
||||||
-- | transaction to sign
|
Ctx ->
|
||||||
Tx ->
|
-- | transaction to sign
|
||||||
-- | signing parameters, with nesting flag
|
Tx ->
|
||||||
[(SigInput, Bool)] ->
|
-- | signing parameters, with nesting flag
|
||||||
-- | private keys to sign with
|
[(SigInput, Bool)] ->
|
||||||
[SecKey] ->
|
-- | private keys to sign with
|
||||||
-- | signed transaction
|
[SecKey] ->
|
||||||
Either String Tx
|
-- | signed transaction
|
||||||
signTx net otx sigis allKeys
|
Either String Tx
|
||||||
| null ti = Left "signTx: Transaction has no inputs"
|
signTx net ctx otx sigis allKeys
|
||||||
| otherwise = foldM go otx $ findInputIndex (sigInputOP . fst) sigis ti
|
| null ti = Left "signTx: Transaction has no inputs"
|
||||||
|
| otherwise = foldM go otx $ findInputIndex ((.outpoint) . fst) sigis ti
|
||||||
where
|
where
|
||||||
ti = txIn otx
|
ti = otx.inputs
|
||||||
go tx (sigi@(SigInput so _ _ _ rdmM, _), i) = do
|
go tx (sigi@(SigInput so _ _ _ rdmM, _), i) = do
|
||||||
keys <- sigKeys so rdmM allKeys
|
keys <- sigKeys ctx so rdmM allKeys
|
||||||
foldM (\t k -> signInput net t i sigi k) tx keys
|
foldM (\t k -> signInput net ctx t i sigi k) tx keys
|
||||||
|
|
||||||
{- | Sign a single input in a transaction deterministically (RFC-6979). The
|
-- | Sign a single input in a transaction deterministically (RFC-6979). The
|
||||||
nesting flag only affects the behavior of segwit inputs.
|
-- nesting flag only affects the behavior of segwit inputs.
|
||||||
-}
|
|
||||||
signInput ::
|
signInput ::
|
||||||
Network ->
|
Network ->
|
||||||
Tx ->
|
Ctx ->
|
||||||
Int ->
|
Tx ->
|
||||||
-- | boolean flag: nest input
|
Int ->
|
||||||
(SigInput, Bool) ->
|
-- | boolean flag: nest input
|
||||||
SecKeyI ->
|
(SigInput, Bool) ->
|
||||||
Either String Tx
|
PrivateKey ->
|
||||||
signInput net tx i (sigIn@(SigInput so val _ _ rdmM), nest) key = do
|
Either String Tx
|
||||||
let sig = makeSignature net tx i sigIn key
|
signInput net ctx tx i (sigIn@(SigInput so val _ _ rdmM), nest) key = do
|
||||||
si <- buildInput net tx i so val rdmM sig $ derivePubKeyI key
|
let sig = makeSignature net ctx tx i sigIn key
|
||||||
w <- updatedWitnessData tx i so si
|
si <- buildInput net ctx tx i so val rdmM sig $ derivePublicKey ctx key
|
||||||
return
|
w <- updatedWitnessData net ctx tx i so si
|
||||||
tx
|
return tx {inputs = nextTxIn so si, witness = w}
|
||||||
{ txIn = nextTxIn so si
|
|
||||||
, txWitness = w
|
|
||||||
}
|
|
||||||
where
|
where
|
||||||
f si x = x{scriptInput = encodeInputBS si}
|
f si TxIn {..} = TxIn {script = marshal (net, ctx) si, ..}
|
||||||
g so' x = x{scriptInput = runPutS . serialize . opPushData $ encodeOutputBS so'}
|
g so' TxIn {..} = TxIn {script = pkScript so', ..}
|
||||||
txis = txIn tx
|
pkScript so' = runPutS . serialize . opPushData $ marshal ctx so'
|
||||||
nextTxIn so' si
|
nextTxIn so' si
|
||||||
| isSegwit so' && nest = updateIndex i txis (g so')
|
| isSegwit so' && nest = updateIndex i tx.inputs (g so')
|
||||||
| isSegwit so' = txIn tx
|
| isSegwit so' = tx.inputs
|
||||||
| otherwise = updateIndex i txis (f si)
|
| otherwise = updateIndex i tx.inputs (f si)
|
||||||
|
|
||||||
{- | Add the witness data of the transaction given segwit parameters for an input.
|
-- | Add the witness data of the transaction given segwit parameters for an input.
|
||||||
|
--
|
||||||
@since 0.11.0.0
|
-- @since 0.11.0.0
|
||||||
-}
|
updatedWitnessData ::
|
||||||
updatedWitnessData :: Tx -> Int -> ScriptOutput -> ScriptInput -> Either String WitnessData
|
Network ->
|
||||||
updatedWitnessData tx i so si
|
Ctx ->
|
||||||
| isSegwit so = updateWitness . toWitnessStack =<< calcWitnessProgram so si
|
Tx ->
|
||||||
| otherwise = return $ txWitness 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
|
where
|
||||||
updateWitness w
|
updateWitness w
|
||||||
| null $ txWitness tx = return $ updateIndex i defaultStack (const w)
|
| null tx.witness = return $ updateIndex i defaultStack (const w)
|
||||||
| length (txWitness tx) /= n = Left "Invalid number of witness stacks"
|
| length tx.witness /= n = Left "Invalid number of witness stacks"
|
||||||
| otherwise = return $ updateIndex i (txWitness tx) (const w)
|
| otherwise = return $ updateIndex i tx.witness (const w)
|
||||||
defaultStack = replicate n $ toWitnessStack EmptyWitnessProgram
|
defaultStack = replicate n $ toWitnessStack net ctx EmptyWitnessProgram
|
||||||
n = length $ txIn tx
|
n = length tx.inputs
|
||||||
|
|
||||||
-- | Associate an input index to each value in a list
|
-- | Associate an input index to each value in a list
|
||||||
findInputIndex ::
|
findInputIndex ::
|
||||||
-- | extract an outpoint
|
-- | extract an outpoint
|
||||||
(a -> OutPoint) ->
|
(a -> OutPoint) ->
|
||||||
-- | input list
|
-- | input list
|
||||||
[a] ->
|
[a] ->
|
||||||
-- | reference list of inputs
|
-- | reference list of inputs
|
||||||
[TxIn] ->
|
[TxIn] ->
|
||||||
[(a, Int)]
|
[(a, Int)]
|
||||||
findInputIndex getOutPoint as ti =
|
findInputIndex getOutPoint as ti =
|
||||||
mapMaybe g $ zip (matchTemplate as ti f) [0 ..]
|
mapMaybe g $ zip (matchTemplate as ti f) [0 ..]
|
||||||
where
|
where
|
||||||
f s txin = getOutPoint s == prevOutput txin
|
f s txin = getOutPoint s == txin.outpoint
|
||||||
g (Just s, i) = Just (s, i)
|
g (Just s, i) = Just (s, i)
|
||||||
g (Nothing, _) = Nothing
|
g (Nothing, _) = Nothing
|
||||||
|
|
||||||
{- | Find from the list of provided private keys which one is required to sign
|
-- | Find from the list of provided private keys which one is required to sign
|
||||||
the 'ScriptOutput'.
|
-- the 'ScriptOutput'.
|
||||||
-}
|
|
||||||
sigKeys ::
|
sigKeys ::
|
||||||
ScriptOutput ->
|
Ctx ->
|
||||||
Maybe RedeemScript ->
|
ScriptOutput ->
|
||||||
[SecKey] ->
|
Maybe RedeemScript ->
|
||||||
Either String [SecKeyI]
|
[SecKey] ->
|
||||||
sigKeys so rdmM keys =
|
Either String [PrivateKey]
|
||||||
case (so, rdmM) of
|
sigKeys ctx so rdmM keys =
|
||||||
(PayPK p, Nothing) ->
|
case (so, rdmM) of
|
||||||
return . map fst . maybeToList $ find ((== p) . snd) zipKeys
|
(PayPK p, Nothing) ->
|
||||||
(PayPKHash h, Nothing) -> return $ keyByHash h
|
return . map fst . maybeToList $ find ((== p) . snd) zipKeys
|
||||||
(PayMulSig ps r, Nothing) ->
|
(PayPKHash h, Nothing) -> return $ keyByHash h
|
||||||
return $ map fst $ take r $ filter ((`elem` ps) . snd) zipKeys
|
(PayMulSig ps r, Nothing) ->
|
||||||
(PayScriptHash _, Just rdm) -> sigKeys rdm Nothing keys
|
return $ map fst $ take r $ filter ((`elem` ps) . snd) zipKeys
|
||||||
(PayWitnessPKHash h, _) -> return $ keyByHash h
|
(PayScriptHash _, Just rdm) -> sigKeys ctx rdm Nothing keys
|
||||||
(PayWitnessScriptHash _, Just rdm) -> sigKeys rdm Nothing keys
|
(PayWitnessPKHash h, _) -> return $ keyByHash h
|
||||||
_ -> Left "sigKeys: Could not decode output script"
|
(PayWitnessScriptHash _, Just rdm) -> sigKeys ctx rdm Nothing keys
|
||||||
|
_ -> Left "sigKeys: Could not decode output script"
|
||||||
where
|
where
|
||||||
zipKeys =
|
zipKeys =
|
||||||
[ (prv, pub)
|
[ (prv, pub)
|
||||||
| k <- keys
|
| k <- keys,
|
||||||
, t <- [True, False]
|
t <- [True, False],
|
||||||
, let prv = wrapSecKey t k
|
let prv = wrapSecKey t k,
|
||||||
, let pub = derivePubKeyI prv
|
let pub = derivePublicKey ctx prv
|
||||||
]
|
]
|
||||||
keyByHash h = fmap fst . maybeToList . findKey h $ zipKeys
|
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
|
-- | Construct an input for a transaction given a signature, public key and data
|
||||||
about the previous output.
|
-- about the previous output.
|
||||||
-}
|
|
||||||
buildInput ::
|
buildInput ::
|
||||||
Network ->
|
Network ->
|
||||||
-- | transaction where input will be added
|
Ctx ->
|
||||||
Tx ->
|
-- | transaction where input will be added
|
||||||
-- | input index where signature will go
|
Tx ->
|
||||||
Int ->
|
-- | input index where signature will go
|
||||||
-- | output script being spent
|
Int ->
|
||||||
ScriptOutput ->
|
-- | output script being spent
|
||||||
-- | amount of previous output
|
ScriptOutput ->
|
||||||
Word64 ->
|
-- | amount of previous output
|
||||||
-- | redeem script if pay-to-script-hash
|
Word64 ->
|
||||||
Maybe RedeemScript ->
|
-- | redeem script if pay-to-script-hash
|
||||||
TxSignature ->
|
Maybe RedeemScript ->
|
||||||
PubKeyI ->
|
TxSignature ->
|
||||||
Either String ScriptInput
|
PublicKey ->
|
||||||
buildInput net tx i so val rdmM sig pub = do
|
Either String ScriptInput
|
||||||
when (i >= length (txIn tx)) $ Left "buildInput: Invalid input index"
|
buildInput net ctx tx i so val rdmM sig pub = do
|
||||||
case (so, rdmM) of
|
when (i >= length tx.inputs) $ Left "buildInput: Invalid input index"
|
||||||
(PayScriptHash _, Just rdm) -> buildScriptHashInput rdm
|
case (so, rdmM) of
|
||||||
(PayWitnessScriptHash _, Just rdm) -> buildScriptHashInput rdm
|
(PayScriptHash _, Just rdm) ->
|
||||||
(PayWitnessPKHash _, Nothing) -> return . RegularInput $ SpendPKHash sig pub
|
buildScriptHashInput rdm
|
||||||
(_, Nothing) -> buildRegularInput so
|
(PayWitnessScriptHash _, Just rdm) ->
|
||||||
_ -> Left "buildInput: Invalid output/redeem script combination"
|
buildScriptHashInput rdm
|
||||||
|
(PayWitnessPKHash _, Nothing) ->
|
||||||
|
return . RegularInput $ SpendPKHash sig pub
|
||||||
|
(_, Nothing) ->
|
||||||
|
buildRegularInput so
|
||||||
|
_ -> Left "buildInput: Invalid output/redeem script combination"
|
||||||
where
|
where
|
||||||
buildRegularInput = \case
|
buildRegularInput = \case
|
||||||
PayPK _ -> return $ RegularInput $ SpendPK sig
|
PayPK _ -> return $ RegularInput $ SpendPK sig
|
||||||
PayPKHash _ -> return $ RegularInput $ SpendPKHash sig pub
|
PayPKHash _ -> return $ RegularInput $ SpendPKHash sig pub
|
||||||
PayMulSig msPubs r -> do
|
PayMulSig msPubs r -> do
|
||||||
let mSigs = take r $ catMaybes $ matchTemplate allSigs msPubs f
|
let mSigs = take r $ catMaybes $ matchTemplate allSigs msPubs f
|
||||||
allSigs = nub $ sig : parseExistingSigs net tx so i
|
allSigs = nub $ sig : parseExistingSigs net ctx tx so i
|
||||||
return $ RegularInput $ SpendMulSig mSigs
|
return $ RegularInput $ SpendMulSig mSigs
|
||||||
_ -> Left "buildInput: Invalid output/redeem script combination"
|
_ -> Left "buildInput: Invalid output/redeem script combination"
|
||||||
buildScriptHashInput rdm = do
|
buildScriptHashInput rdm = do
|
||||||
inp <- buildRegularInput rdm
|
inp <- buildRegularInput rdm
|
||||||
return $ ScriptHashInput (getRegularInput inp) rdm
|
return $ ScriptHashInput inp.get rdm
|
||||||
f (TxSignature x sh) p =
|
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
|
f TxSignatureEmpty _ = False
|
||||||
|
|
||||||
{- | Apply heuristics to extract the signatures for a particular input that are
|
-- | Apply heuristics to extract the signatures for a particular input that are
|
||||||
embedded in the transaction.
|
-- embedded in the transaction.
|
||||||
|
--
|
||||||
@since 0.11.0.0
|
-- @since 0.11.0.0
|
||||||
-}
|
parseExistingSigs :: Network -> Ctx -> Tx -> ScriptOutput -> Int -> [TxSignature]
|
||||||
parseExistingSigs :: Network -> Tx -> ScriptOutput -> Int -> [TxSignature]
|
parseExistingSigs net ctx tx so i = insSigs <> witSigs
|
||||||
parseExistingSigs net tx so i = insSigs <> witSigs
|
|
||||||
where
|
where
|
||||||
insSigs = case decodeInputBS net scp of
|
insSigs = case unmarshal (net, ctx) scp of
|
||||||
Right (ScriptHashInput (SpendMulSig xs) _) -> xs
|
Right (ScriptHashInput (SpendMulSig xs) _) -> xs
|
||||||
Right (RegularInput (SpendMulSig xs)) -> xs
|
Right (RegularInput (SpendMulSig xs)) -> xs
|
||||||
_ -> []
|
_ -> []
|
||||||
scp = scriptInput $ txIn tx !! i
|
scp = (tx.inputs !! i).script
|
||||||
witSigs
|
witSigs
|
||||||
| not $ isSegwit so = []
|
| not $ isSegwit so = []
|
||||||
| null $ txWitness tx = []
|
| null tx.witness = []
|
||||||
| otherwise = rights $ decodeTxSig net <$> (txWitness tx !! i)
|
| otherwise = rights $ decodeTxSig net ctx <$> (tx.witness !! i)
|
||||||
|
|
||||||
-- | Produce a structured representation of a deterministic (RFC-6979) signature over an input.
|
-- | Produce a structured representation of a deterministic (RFC-6979) signature over an input.
|
||||||
makeSignature :: Network -> Tx -> Int -> SigInput -> SecKeyI -> TxSignature
|
makeSignature :: Network -> Ctx -> Tx -> Int -> SigInput -> PrivateKey -> TxSignature
|
||||||
makeSignature net tx i (SigInput so val _ sh rdmM) key =
|
makeSignature net ctx tx i (SigInput so val _ sh rdmM) key =
|
||||||
TxSignature (signHash (secKeyData key) m) sh
|
TxSignature (signHash ctx key.key m) sh
|
||||||
where
|
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
|
-- | A function which selects the digest algorithm and parameters as appropriate
|
||||||
|
--
|
||||||
@since 0.11.0.0
|
-- @since 0.11.0.0
|
||||||
-}
|
|
||||||
makeSigHash ::
|
makeSigHash ::
|
||||||
Network ->
|
Network ->
|
||||||
Tx ->
|
Ctx ->
|
||||||
Int ->
|
Tx ->
|
||||||
ScriptOutput ->
|
Int ->
|
||||||
Word64 ->
|
ScriptOutput ->
|
||||||
SigHash ->
|
Word64 ->
|
||||||
Maybe RedeemScript ->
|
SigHash ->
|
||||||
Hash256
|
Maybe RedeemScript ->
|
||||||
makeSigHash net tx i so val sh rdmM = h net tx (encodeOutput so') val i sh
|
Hash256
|
||||||
|
makeSigHash net ctx tx i so val sh rdmM = h net tx (encodeOutput ctx so') val i sh
|
||||||
where
|
where
|
||||||
so' = case so of
|
so' = case so of
|
||||||
PayWitnessPKHash h' -> PayPKHash h'
|
PayWitnessPKHash h' -> PayPKHash h'
|
||||||
_ -> fromMaybe so rdmM
|
_ -> fromMaybe so rdmM
|
||||||
h
|
h
|
||||||
| isSegwit so = txSigHashForkId
|
| isSegwit so = txSigHashForkId
|
||||||
| otherwise = txSigHash
|
| otherwise = txSigHash
|
||||||
|
@ -1,19 +1,25 @@
|
|||||||
{-# LANGUAGE DeriveAnyClass #-}
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE DerivingStrategies #-}
|
||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE NoFieldSelectors #-}
|
||||||
|
|
||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Transaction.Common
|
-- Module : Haskoin.Transaction.Common
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
Code related to transactions parsing and serialization.
|
-- Code related to transactions parsing and serialization.
|
||||||
-}
|
module Haskoin.Transaction.Common
|
||||||
module Haskoin.Transaction.Common (
|
( -- * Transactions
|
||||||
-- * Transactions
|
|
||||||
Tx (..),
|
Tx (..),
|
||||||
TxIn (..),
|
TxIn (..),
|
||||||
TxOut (..),
|
TxOut (..),
|
||||||
@ -27,27 +33,20 @@ module Haskoin.Transaction.Common (
|
|||||||
txHashToHex,
|
txHashToHex,
|
||||||
nosigTxHash,
|
nosigTxHash,
|
||||||
nullOutPoint,
|
nullOutPoint,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Applicative ((<|>))
|
import Control.Applicative ((<|>))
|
||||||
import Control.DeepSeq
|
import Control.DeepSeq
|
||||||
import Control.Monad (
|
import Control.Monad (forM_, guard, liftM2, mzero, replicateM, unless, when, (<=<))
|
||||||
forM_,
|
|
||||||
guard,
|
|
||||||
liftM2,
|
|
||||||
mzero,
|
|
||||||
replicateM,
|
|
||||||
unless,
|
|
||||||
when,
|
|
||||||
(<=<),
|
|
||||||
)
|
|
||||||
import Data.Aeson as A
|
import Data.Aeson as A
|
||||||
import Data.Aeson.Encoding (unsafeToEncoding)
|
import Data.Aeson.Encoding qualified as E
|
||||||
import Data.Binary (Binary (..))
|
import Data.Binary (Binary (..))
|
||||||
|
import Data.Bool (bool)
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
import qualified Data.ByteString as B
|
import Data.ByteString qualified as B
|
||||||
import Data.ByteString.Builder (char7)
|
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.Get
|
||||||
import Data.Bytes.Put
|
import Data.Bytes.Put
|
||||||
import Data.Bytes.Serial
|
import Data.Bytes.Serial
|
||||||
@ -61,67 +60,67 @@ import Data.Word (Word32, Word64)
|
|||||||
import GHC.Generics (Generic)
|
import GHC.Generics (Generic)
|
||||||
import Haskoin.Crypto.Hash
|
import Haskoin.Crypto.Hash
|
||||||
import Haskoin.Network.Common
|
import Haskoin.Network.Common
|
||||||
import Haskoin.Util
|
import Haskoin.Util.Helpers
|
||||||
import Text.Read as R
|
import Text.Read as R
|
||||||
|
|
||||||
-- | Transaction id: hash of transaction excluding witness data.
|
-- | Transaction id: hash of transaction excluding witness data.
|
||||||
newtype TxHash = TxHash {getTxHash :: Hash256}
|
newtype TxHash = TxHash {get :: Hash256}
|
||||||
deriving (Eq, Ord, Generic, Hashable, Serial, NFData)
|
deriving (Eq, Ord, Generic)
|
||||||
|
deriving newtype (Hashable, NFData)
|
||||||
|
|
||||||
|
instance Serial TxHash where
|
||||||
|
serialize (TxHash h) = serialize h
|
||||||
|
deserialize = TxHash <$> deserialize
|
||||||
|
|
||||||
instance Serialize TxHash where
|
instance Serialize TxHash where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance Binary TxHash where
|
instance Binary TxHash where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance Show TxHash where
|
instance Show TxHash where
|
||||||
showsPrec _ = shows . txHashToHex
|
showsPrec _ = shows . txHashToHex
|
||||||
|
|
||||||
instance Read TxHash where
|
instance Read TxHash where
|
||||||
readPrec = do
|
readPrec = do
|
||||||
R.String str <- R.lexP
|
R.String str <- R.lexP
|
||||||
maybe R.pfail return $ hexToTxHash $ cs str
|
maybe R.pfail return $ hexToTxHash $ cs str
|
||||||
|
|
||||||
instance IsString TxHash where
|
instance IsString TxHash where
|
||||||
fromString s =
|
fromString s =
|
||||||
let e = error "Could not read transaction hash from hex string"
|
let e = error "Could not read transaction hash from hex string"
|
||||||
in fromMaybe e $ hexToTxHash $ cs s
|
in fromMaybe e $ hexToTxHash $ cs s
|
||||||
|
|
||||||
instance FromJSON TxHash where
|
instance FromJSON TxHash where
|
||||||
parseJSON =
|
parseJSON =
|
||||||
withText "txid" $
|
withText "txid" $
|
||||||
maybe mzero return . hexToTxHash
|
maybe mzero return . hexToTxHash
|
||||||
|
|
||||||
instance ToJSON TxHash where
|
instance ToJSON TxHash where
|
||||||
toJSON = A.String . txHashToHex
|
toJSON = A.String . txHashToHex
|
||||||
toEncoding h =
|
toEncoding = hexEncoding . BL.reverse . runPutL . serialize
|
||||||
unsafeToEncoding $
|
|
||||||
char7 '"'
|
|
||||||
<> hexBuilder (BL.reverse (runPutL (serialize h)))
|
|
||||||
<> char7 '"'
|
|
||||||
|
|
||||||
-- | Transaction hash excluding signatures.
|
-- | Transaction hash excluding signatures.
|
||||||
nosigTxHash :: Tx -> TxHash
|
nosigTxHash :: Tx -> TxHash
|
||||||
nosigTxHash tx =
|
nosigTxHash Tx {..} =
|
||||||
TxHash $
|
TxHash . doubleSHA256 . runPutS $ serialize tx
|
||||||
doubleSHA256 $
|
|
||||||
runPutS $
|
|
||||||
serialize tx{txIn = map clearInput $ txIn tx}
|
|
||||||
where
|
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.
|
-- | Convert transaction hash to hex form, reversing bytes.
|
||||||
txHashToHex :: TxHash -> Text
|
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.
|
-- | Convert transaction hash from hex, reversing bytes.
|
||||||
hexToTxHash :: Text -> Maybe TxHash
|
hexToTxHash :: Text -> Maybe TxHash
|
||||||
hexToTxHash hex = do
|
hexToTxHash hex = do
|
||||||
bs <- B.reverse <$> decodeHex hex
|
bs <- B.reverse <$> decodeHex hex
|
||||||
h <- either (const Nothing) Just (runGetS deserialize bs)
|
h <- either (const Nothing) Just (runGetS deserialize bs)
|
||||||
return $ TxHash h
|
return $ TxHash h
|
||||||
|
|
||||||
-- | Witness stack for SegWit transactions.
|
-- | Witness stack for SegWit transactions.
|
||||||
type WitnessData = [WitnessStack]
|
type WitnessData = [WitnessStack]
|
||||||
@ -134,289 +133,297 @@ type WitnessStackItem = ByteString
|
|||||||
|
|
||||||
-- | Data type representing a transaction.
|
-- | Data type representing a transaction.
|
||||||
data Tx = Tx
|
data Tx = Tx
|
||||||
{ -- | transaction data format version
|
{ -- | transaction data format version
|
||||||
txVersion :: !Word32
|
version :: !Word32,
|
||||||
, -- | list of transaction inputs
|
-- | list of transaction inputs
|
||||||
txIn :: ![TxIn]
|
inputs :: ![TxIn],
|
||||||
, -- | list of transaction outputs
|
-- | list of transaction outputs
|
||||||
txOut :: ![TxOut]
|
outputs :: ![TxOut],
|
||||||
, -- | witness data for the transaction
|
-- | witness data for the transaction
|
||||||
txWitness :: !WitnessData
|
witness :: !WitnessData,
|
||||||
, -- | earliest mining height or time
|
-- | earliest mining height or time
|
||||||
txLockTime :: !Word32
|
locktime :: !Word32
|
||||||
}
|
}
|
||||||
deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData)
|
deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData)
|
||||||
|
|
||||||
-- | Compute transaction hash.
|
-- | Compute transaction hash.
|
||||||
txHash :: Tx -> TxHash
|
txHash :: Tx -> TxHash
|
||||||
txHash tx = TxHash . doubleSHA256 . runPutS $ serialize tx{txWitness = []}
|
txHash tx = TxHash . doubleSHA256 . runPutS $ serialize tx {witness = []}
|
||||||
|
|
||||||
instance IsString Tx where
|
instance IsString Tx where
|
||||||
fromString =
|
fromString =
|
||||||
fromMaybe e . (eitherToMaybe . runGetS deserialize <=< decodeHex) . cs
|
fromMaybe e . (eitherToMaybe . runGetS deserialize <=< decodeHex) . cs
|
||||||
where
|
where
|
||||||
e = error "Could not read transaction from hex string"
|
e = error "Could not read transaction from hex string"
|
||||||
|
|
||||||
instance Serial Tx where
|
instance Serial Tx where
|
||||||
deserialize =
|
deserialize = isWitnessTx >>= bool parseLegacyTx parseWitnessTx
|
||||||
isWitnessTx >>= \w -> if w then parseWitnessTx else parseLegacyTx
|
serialize tx
|
||||||
serialize tx
|
| null tx.witness = putLegacyTx tx
|
||||||
| null (txWitness tx) = putLegacyTx tx
|
| otherwise = putWitnessTx tx
|
||||||
| otherwise = putWitnessTx tx
|
|
||||||
|
|
||||||
instance Binary Tx where
|
instance Binary Tx where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance Serialize Tx where
|
instance Serialize Tx where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
putInOut :: MonadPut m => Tx -> m ()
|
putInOut :: (MonadPut m) => Tx -> m ()
|
||||||
putInOut tx = do
|
putInOut tx = do
|
||||||
putVarInt $ length (txIn tx)
|
putVarInt $ length tx.inputs
|
||||||
forM_ (txIn tx) serialize
|
mapM_ serialize tx.inputs
|
||||||
putVarInt $ length (txOut tx)
|
putVarInt $ length tx.outputs
|
||||||
forM_ (txOut tx) serialize
|
mapM_ serialize tx.outputs
|
||||||
|
|
||||||
-- | Non-SegWit transaction serializer.
|
-- | Non-SegWit transaction serializer.
|
||||||
putLegacyTx :: MonadPut m => Tx -> m ()
|
putLegacyTx :: (MonadPut m) => Tx -> m ()
|
||||||
putLegacyTx tx = do
|
putLegacyTx tx = do
|
||||||
putWord32le (txVersion tx)
|
putWord32le tx.version
|
||||||
putInOut tx
|
putInOut tx
|
||||||
putWord32le (txLockTime tx)
|
putWord32le tx.locktime
|
||||||
|
|
||||||
-- | Witness transaciton serializer.
|
-- | Witness transaciton serializer.
|
||||||
putWitnessTx :: MonadPut m => Tx -> m ()
|
putWitnessTx :: (MonadPut m) => Tx -> m ()
|
||||||
putWitnessTx tx = do
|
putWitnessTx tx = do
|
||||||
putWord32le (txVersion tx)
|
putWord32le tx.version
|
||||||
putWord8 0x00
|
putWord8 0x00
|
||||||
putWord8 0x01
|
putWord8 0x01
|
||||||
putInOut tx
|
putInOut tx
|
||||||
putWitnessData (txWitness tx)
|
putWitnessData tx.witness
|
||||||
putWord32le (txLockTime tx)
|
putWord32le tx.locktime
|
||||||
|
|
||||||
isWitnessTx :: MonadGet m => m Bool
|
isWitnessTx :: (MonadGet m) => m Bool
|
||||||
isWitnessTx = lookAhead $ do
|
isWitnessTx = lookAhead $ do
|
||||||
_ <- getWord32le
|
_ <- getWord32le
|
||||||
m <- getWord8
|
m <- getWord8
|
||||||
f <- getWord8
|
f <- getWord8
|
||||||
return (m == 0x00 && f == 0x01)
|
return (m == 0x00 && f == 0x01)
|
||||||
|
|
||||||
-- | Non-SegWit transaction deseralizer.
|
-- | Non-SegWit transaction deseralizer.
|
||||||
parseLegacyTx :: MonadGet m => m Tx
|
parseLegacyTx :: (MonadGet m) => m Tx
|
||||||
parseLegacyTx = do
|
parseLegacyTx = do
|
||||||
v <- getWord32le
|
version <- getWord32le
|
||||||
is <- replicateList =<< deserialize
|
inputs <- rl =<< deserialize
|
||||||
os <- replicateList =<< deserialize
|
outputs <- rl =<< deserialize
|
||||||
when (length is == 0x00 && length os == 0x01) $ fail "Witness transaction"
|
when (length inputs == 0x00 && length outputs == 0x01) $
|
||||||
l <- getWord32le
|
fail "Witness transaction"
|
||||||
return
|
locktime <- getWord32le
|
||||||
Tx
|
return Tx {witness = [], ..}
|
||||||
{ txVersion = v
|
|
||||||
, txIn = is
|
|
||||||
, txOut = os
|
|
||||||
, txWitness = []
|
|
||||||
, txLockTime = l
|
|
||||||
}
|
|
||||||
where
|
where
|
||||||
replicateList (VarInt c) = replicateM (fromIntegral c) deserialize
|
rl (VarInt c) = replicateM (fromIntegral c) deserialize
|
||||||
|
|
||||||
-- | Witness transaction deserializer.
|
-- | Witness transaction deserializer.
|
||||||
parseWitnessTx :: MonadGet m => m Tx
|
parseWitnessTx :: (MonadGet m) => m Tx
|
||||||
parseWitnessTx = do
|
parseWitnessTx = do
|
||||||
v <- getWord32le
|
version <- getWord32le
|
||||||
m <- getWord8
|
m <- getWord8
|
||||||
f <- getWord8
|
f <- getWord8
|
||||||
unless (m == 0x00 && f == 0x01) $ fail "Not a witness transaction"
|
unless (m == 0x00 && f == 0x01) $ fail "Not a witness transaction"
|
||||||
is <- replicateList =<< deserialize
|
inputs <- replicateList =<< deserialize
|
||||||
os <- replicateList =<< deserialize
|
outputs <- replicateList =<< deserialize
|
||||||
w <- parseWitnessData $ length is
|
witness <- parseWitnessData $ length inputs
|
||||||
l <- getWord32le
|
locktime <- getWord32le
|
||||||
return
|
return Tx {..}
|
||||||
Tx{txVersion = v, txIn = is, txOut = os, txWitness = w, txLockTime = l}
|
|
||||||
where
|
where
|
||||||
replicateList (VarInt c) = replicateM (fromIntegral c) deserialize
|
replicateList (VarInt c) = replicateM (fromIntegral c) deserialize
|
||||||
|
|
||||||
-- | Witness data deserializer. Requires count of inputs.
|
-- | Witness data deserializer. Requires count of inputs.
|
||||||
parseWitnessData :: MonadGet m => Int -> m WitnessData
|
parseWitnessData :: (MonadGet m) => Int -> m WitnessData
|
||||||
parseWitnessData n = replicateM n parseWitnessStack
|
parseWitnessData n = replicateM n parseWitnessStack
|
||||||
where
|
where
|
||||||
parseWitnessStack = do
|
parseWitnessStack = do
|
||||||
VarInt i <- deserialize
|
VarInt i <- deserialize
|
||||||
replicateM (fromIntegral i) parseWitnessStackItem
|
replicateM (fromIntegral i) parseWitnessStackItem
|
||||||
parseWitnessStackItem = do
|
parseWitnessStackItem = do
|
||||||
VarInt i <- deserialize
|
VarInt i <- deserialize
|
||||||
getByteString $ fromIntegral i
|
getByteString $ fromIntegral i
|
||||||
|
|
||||||
-- | Witness data serializer.
|
-- | Witness data serializer.
|
||||||
putWitnessData :: MonadPut m => WitnessData -> m ()
|
putWitnessData :: (MonadPut m) => WitnessData -> m ()
|
||||||
putWitnessData = mapM_ putWitnessStack
|
putWitnessData = mapM_ putWitnessStack
|
||||||
where
|
where
|
||||||
putWitnessStack ws = do
|
putWitnessStack ws = do
|
||||||
putVarInt $ length ws
|
putVarInt $ length ws
|
||||||
mapM_ putWitnessStackItem ws
|
mapM_ putWitnessStackItem ws
|
||||||
putWitnessStackItem bs = do
|
putWitnessStackItem bs = do
|
||||||
putVarInt $ B.length bs
|
putVarInt $ B.length bs
|
||||||
putByteString bs
|
putByteString bs
|
||||||
|
|
||||||
instance FromJSON Tx where
|
instance FromJSON Tx where
|
||||||
parseJSON = withObject "Tx" $ \o ->
|
parseJSON = withObject "Tx" $ \o ->
|
||||||
Tx <$> o .: "version"
|
Tx
|
||||||
<*> o .: "inputs"
|
<$> o .: "version"
|
||||||
<*> o .: "outputs"
|
<*> o .: "inputs"
|
||||||
<*> (mapM (mapM f) =<< o .: "witnessdata")
|
<*> o .: "outputs"
|
||||||
<*> o .: "locktime"
|
<*> (mapM (mapM f) =<< o .: "witnessdata")
|
||||||
where
|
<*> o .: "locktime"
|
||||||
f = maybe mzero return . decodeHex
|
where
|
||||||
|
f = maybe mzero return . decodeHex
|
||||||
|
|
||||||
instance ToJSON Tx where
|
instance ToJSON Tx where
|
||||||
toJSON (Tx v i o w l) =
|
toJSON (Tx v i o w l) =
|
||||||
object
|
object
|
||||||
[ "version" .= v
|
[ "version" .= v,
|
||||||
, "inputs" .= i
|
"inputs" .= i,
|
||||||
, "outputs" .= o
|
"outputs" .= o,
|
||||||
, "witnessdata" .= fmap (fmap encodeHex) w
|
"witnessdata" .= fmap (fmap encodeHex) w,
|
||||||
, "locktime" .= l
|
"locktime" .= l
|
||||||
]
|
]
|
||||||
toEncoding (Tx v i o w l) =
|
toEncoding (Tx v i o w l) =
|
||||||
pairs
|
pairs $
|
||||||
( "version" .= v
|
mconcat
|
||||||
<> "inputs" .= i
|
[ "version" `E.pair` E.word32 v,
|
||||||
<> "outputs" .= o
|
"inputs" `E.pair` E.list toEncoding i,
|
||||||
<> "witnessdata" .= fmap (fmap encodeHex) w
|
"outputs" `E.pair` E.list toEncoding o,
|
||||||
<> "locktime" .= l
|
"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 type representing a transaction input.
|
||||||
data TxIn = TxIn
|
data TxIn = TxIn
|
||||||
{ -- | output being spent
|
{ -- | output being spent
|
||||||
prevOutput :: !OutPoint
|
outpoint :: !OutPoint,
|
||||||
, -- | signatures and redeem script
|
-- | signatures and redeem script
|
||||||
scriptInput :: !ByteString
|
script :: !ByteString,
|
||||||
, -- | lock-time using sequence numbers (BIP-68)
|
-- | lock-time using sequence numbers (BIP-68)
|
||||||
txInSequence :: !Word32
|
sequence :: !Word32
|
||||||
}
|
}
|
||||||
deriving (Eq, Show, Read, Ord, Generic, Hashable, NFData)
|
deriving (Eq, Show, Read, Ord, Generic, Hashable, NFData)
|
||||||
|
|
||||||
instance Serial TxIn where
|
instance Serial TxIn where
|
||||||
deserialize =
|
deserialize =
|
||||||
TxIn <$> deserialize <*> (readBS =<< deserialize) <*> getWord32le
|
TxIn <$> deserialize <*> (readBS =<< deserialize) <*> getWord32le
|
||||||
where
|
where
|
||||||
readBS (VarInt len) = getByteString $ fromIntegral len
|
readBS (VarInt len) = getByteString $ fromIntegral len
|
||||||
|
|
||||||
serialize (TxIn o s q) = do
|
serialize (TxIn o s q) = do
|
||||||
serialize o
|
serialize o
|
||||||
putVarInt $ B.length s
|
putVarInt $ B.length s
|
||||||
putByteString s
|
putByteString s
|
||||||
putWord32le q
|
putWord32le q
|
||||||
|
|
||||||
instance Binary TxIn where
|
instance Binary TxIn where
|
||||||
get = deserialize
|
get = deserialize
|
||||||
put = serialize
|
put = serialize
|
||||||
|
|
||||||
instance Serialize TxIn where
|
instance Serialize TxIn where
|
||||||
get = deserialize
|
get = deserialize
|
||||||
put = serialize
|
put = serialize
|
||||||
|
|
||||||
instance FromJSON TxIn where
|
instance FromJSON TxIn where
|
||||||
parseJSON =
|
parseJSON =
|
||||||
withObject "TxIn" $ \o ->
|
withObject "TxIn" $ \o ->
|
||||||
TxIn <$> o .: "prevoutput"
|
TxIn
|
||||||
<*> (maybe mzero return . decodeHex =<< o .: "inputscript")
|
<$> o .: "prevoutput"
|
||||||
<*> o .: "sequence"
|
<*> (maybe mzero return . decodeHex =<< o .: "inputscript")
|
||||||
|
<*> o .: "sequence"
|
||||||
|
|
||||||
instance ToJSON TxIn where
|
instance ToJSON TxIn where
|
||||||
toJSON (TxIn o s q) =
|
toJSON (TxIn o s q) =
|
||||||
object
|
object
|
||||||
[ "prevoutput" .= o
|
[ "prevoutput" .= o,
|
||||||
, "inputscript" .= encodeHex s
|
"inputscript" .= encodeHex s,
|
||||||
, "sequence" .= q
|
"sequence" .= q
|
||||||
]
|
]
|
||||||
toEncoding (TxIn o s q) =
|
toEncoding (TxIn o s q) =
|
||||||
pairs
|
pairs $
|
||||||
( "prevoutput" .= o
|
mconcat
|
||||||
<> "inputscript" .= encodeHex s
|
[ "prevoutput" `E.pair` toEncoding o,
|
||||||
<> "sequence" .= q
|
"inputscript" `E.pair` hexEncoding (BL.fromStrict s),
|
||||||
)
|
"sequence" `E.pair` E.word32 q
|
||||||
|
]
|
||||||
|
|
||||||
-- | Data type representing a transaction output.
|
-- | Data type representing a transaction output.
|
||||||
data TxOut = TxOut
|
data TxOut = TxOut
|
||||||
{ -- | value of output is satoshi
|
{ -- | value of output is satoshi
|
||||||
outValue :: !Word64
|
value :: !Word64,
|
||||||
, -- | pubkey script
|
-- | pubkey script
|
||||||
scriptOutput :: !ByteString
|
script :: !ByteString
|
||||||
}
|
}
|
||||||
deriving (Eq, Show, Read, Ord, Generic, Hashable, NFData)
|
deriving (Eq, Show, Read, Ord, Generic, Hashable, NFData)
|
||||||
|
|
||||||
instance Serial TxOut where
|
instance Serial TxOut where
|
||||||
deserialize = do
|
deserialize = do
|
||||||
val <- getWord64le
|
val <- getWord64le
|
||||||
VarInt len <- deserialize
|
VarInt len <- deserialize
|
||||||
TxOut val <$> getByteString (fromIntegral len)
|
TxOut val <$> getByteString (fromIntegral len)
|
||||||
|
|
||||||
serialize (TxOut o s) = do
|
serialize (TxOut o s) = do
|
||||||
putWord64le o
|
putWord64le o
|
||||||
putVarInt $ B.length s
|
putVarInt $ B.length s
|
||||||
putByteString s
|
putByteString s
|
||||||
|
|
||||||
instance Binary TxOut where
|
instance Binary TxOut where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance Serialize TxOut where
|
instance Serialize TxOut where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance FromJSON TxOut where
|
instance FromJSON TxOut where
|
||||||
parseJSON =
|
parseJSON =
|
||||||
withObject "TxOut" $ \o ->
|
withObject "TxOut" $ \o -> do
|
||||||
TxOut <$> o .: "value"
|
value <- o .: "value"
|
||||||
<*> (maybe mzero return . decodeHex =<< o .: "outputscript")
|
t <- o .: "outputscript"
|
||||||
|
script <- maybe mzero return (decodeHex t)
|
||||||
|
return TxOut {..}
|
||||||
|
|
||||||
instance ToJSON TxOut where
|
instance ToJSON TxOut where
|
||||||
toJSON (TxOut o s) =
|
toJSON (TxOut o s) =
|
||||||
object ["value" .= o, "outputscript" .= encodeHex s]
|
object ["value" .= o, "outputscript" .= encodeHex s]
|
||||||
toEncoding (TxOut o s) =
|
toEncoding (TxOut o s) =
|
||||||
pairs ("value" .= o <> "outputscript" .= encodeHex 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.
|
-- | The 'OutPoint' refers to a transaction output being spent.
|
||||||
data OutPoint = OutPoint
|
data OutPoint = OutPoint
|
||||||
{ -- | hash of previous transaction
|
{ -- | hash of previous transaction
|
||||||
outPointHash :: !TxHash
|
hash :: !TxHash,
|
||||||
, -- | position of output in previous transaction
|
-- | position of output in previous transaction
|
||||||
outPointIndex :: !Word32
|
index :: !Word32
|
||||||
}
|
}
|
||||||
deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData)
|
deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData)
|
||||||
|
|
||||||
instance Serial OutPoint where
|
instance Serial OutPoint where
|
||||||
deserialize = do
|
deserialize = do
|
||||||
(h, i) <- liftM2 (,) deserialize getWord32le
|
(h, i) <- liftM2 (,) deserialize getWord32le
|
||||||
return $ OutPoint h i
|
return $ OutPoint h i
|
||||||
serialize (OutPoint h i) = serialize h >> putWord32le i
|
serialize (OutPoint h i) = serialize h >> putWord32le i
|
||||||
|
|
||||||
instance Binary OutPoint where
|
instance Binary OutPoint where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance Serialize OutPoint where
|
instance Serialize OutPoint where
|
||||||
put = serialize
|
put = serialize
|
||||||
get = deserialize
|
get = deserialize
|
||||||
|
|
||||||
instance FromJSON OutPoint where
|
instance FromJSON OutPoint where
|
||||||
parseJSON =
|
parseJSON =
|
||||||
withObject "OutPoint" $ \o ->
|
withObject "OutPoint" $ \o ->
|
||||||
OutPoint <$> o .: "txid" <*> o .: "index"
|
OutPoint <$> o .: "txid" <*> o .: "index"
|
||||||
|
|
||||||
instance ToJSON OutPoint where
|
instance ToJSON OutPoint where
|
||||||
toJSON (OutPoint h i) = object ["txid" .= h, "index" .= i]
|
toJSON (OutPoint h i) = object ["txid" .= h, "index" .= i]
|
||||||
toEncoding (OutPoint h i) = pairs ("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.
|
-- | Outpoint used in coinbase transactions.
|
||||||
nullOutPoint :: OutPoint
|
nullOutPoint :: OutPoint
|
||||||
nullOutPoint =
|
nullOutPoint =
|
||||||
OutPoint
|
OutPoint
|
||||||
{ outPointHash =
|
{ hash = "0000000000000000000000000000000000000000000000000000000000000000",
|
||||||
"0000000000000000000000000000000000000000000000000000000000000000"
|
index = maxBound
|
||||||
, outPointIndex = maxBound
|
}
|
||||||
}
|
|
||||||
|
@ -1,42 +1,42 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Transaction.Genesis
|
-- Module : Haskoin.Transaction.Genesis
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : UNLICENSE
|
-- License : UNLICENSE
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
|
-- Code related to transactions parsing and serialization.
|
||||||
|
module Haskoin.Transaction.Genesis (genesisTx) where
|
||||||
|
|
||||||
Code related to transactions parsing and serialization.
|
import Crypto.Secp256k1 (Ctx, importPubKey)
|
||||||
-}
|
import Data.Bytes.Get (runGetS)
|
||||||
module Haskoin.Transaction.Genesis (
|
import Haskoin.Crypto.Keys.Common
|
||||||
genesisTx,
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Data.String (fromString)
|
|
||||||
import Haskoin.Script.Standard
|
import Haskoin.Script.Standard
|
||||||
import Haskoin.Transaction.Common
|
import Haskoin.Transaction.Common
|
||||||
import Haskoin.Util
|
import Haskoin.Util
|
||||||
|
|
||||||
-- | Transaction from Genesis block.
|
-- | Transaction from Genesis block.
|
||||||
genesisTx :: Tx
|
genesisTx :: Ctx -> Tx
|
||||||
genesisTx =
|
genesisTx ctx =
|
||||||
Tx 1 [txin] [txout] [] locktime
|
Tx 1 [txin] [txout] [] locktime
|
||||||
where
|
where
|
||||||
txin = TxIn outpoint inputBS maxBound
|
txin = TxIn outpoint inputBS maxBound
|
||||||
txout = TxOut 5000000000 (encodeOutputBS output)
|
txout = TxOut 5000000000 (marshal ctx output)
|
||||||
locktime = 0
|
locktime = 0
|
||||||
outpoint = OutPoint z maxBound
|
outpoint = OutPoint z maxBound
|
||||||
Just inputBS =
|
Just inputBS =
|
||||||
decodeHex $
|
decodeHex
|
||||||
fromString $
|
"04ffff001d0104455468652054696d65732030332f4a616e2f323030392043686\
|
||||||
"04ffff001d0104455468652054696d65732030332f4a616e2f323030392043686"
|
\16e63656c6c6f72206f6e206272696e6b206f66207365636f6e64206261696c6f\
|
||||||
++ "16e63656c6c6f72206f6e206272696e6b206f66207365636f6e64206261696c6f"
|
\757420666f722062616e6b73"
|
||||||
++ "757420666f722062616e6b73"
|
Just pubKeyBS =
|
||||||
output =
|
decodeHex
|
||||||
PayPK $
|
"04678afdb0fe5548271967f1a67130b7105cd6a828e03909a67962e0ea1f61deb\
|
||||||
fromString $
|
\649f6bc3f4cef38c4f35504e51ec112de5c384df7ba0b8d578a4c702b6bf11d5f"
|
||||||
"04678afdb0fe5548271967f1a67130b7105cd6a828e03909a67962e0ea1f61deb"
|
Right pubKey =
|
||||||
++ "649f6bc3f4cef38c4f35504e51ec112de5c384df7ba0b8d578a4c702b6bf11d5f"
|
unmarshal ctx pubKeyBS
|
||||||
|
output = PayPK pubKey
|
||||||
z = "0000000000000000000000000000000000000000000000000000000000000000"
|
z = "0000000000000000000000000000000000000000000000000000000000000000"
|
||||||
|
File diff suppressed because it is too large
Load Diff
@ -1,22 +1,23 @@
|
|||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
{-# LANGUAGE NoFieldSelectors #-}
|
||||||
|
|
||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Transaction.Segwit
|
-- Module : Haskoin.Transaction.Segwit
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
Types to represent segregated witness data and auxilliary functions to
|
-- 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)
|
-- 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
|
-- and [BIP 143](https://github.com/bitcoin/bips/blob/master/bip-0143.mediawiki) for
|
||||||
details.
|
-- details.
|
||||||
-}
|
module Haskoin.Transaction.Segwit
|
||||||
module Haskoin.Transaction.Segwit (
|
( -- * Segwit
|
||||||
-- * Segwit
|
|
||||||
WitnessProgram (..),
|
WitnessProgram (..),
|
||||||
WitnessProgramPKH (..),
|
WitnessProgramPKH (..),
|
||||||
WitnessProgramSH (..),
|
WitnessProgramSH (..),
|
||||||
@ -26,131 +27,149 @@ module Haskoin.Transaction.Segwit (
|
|||||||
calcWitnessProgram,
|
calcWitnessProgram,
|
||||||
simpleInputStack,
|
simpleInputStack,
|
||||||
toWitnessStack,
|
toWitnessStack,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
|
import Crypto.Secp256k1
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
import Data.Bytes.Get
|
import Data.Bytes.Get (runGetS)
|
||||||
import Data.Bytes.Put
|
import Data.Bytes.Put (runPutS)
|
||||||
import Data.Bytes.Serial
|
import Data.Bytes.Serial (Serial (deserialize, serialize))
|
||||||
import Haskoin.Data
|
import Haskoin.Crypto.Keys.Common
|
||||||
import Haskoin.Keys.Common
|
import Haskoin.Network.Data
|
||||||
import Haskoin.Script
|
import Haskoin.Script.Common
|
||||||
|
import Haskoin.Script.SigHash
|
||||||
|
import Haskoin.Script.Standard
|
||||||
import Haskoin.Transaction.Common
|
import Haskoin.Transaction.Common
|
||||||
|
import Haskoin.Util.Marshal
|
||||||
|
|
||||||
{- | Test if a 'ScriptOutput' is P2WPKH or P2WSH
|
-- | Test if a 'ScriptOutput' is P2WPKH or P2WSH
|
||||||
|
--
|
||||||
@since 0.11.0.0
|
-- @since 0.11.0.0
|
||||||
-}
|
|
||||||
isSegwit :: ScriptOutput -> Bool
|
isSegwit :: ScriptOutput -> Bool
|
||||||
isSegwit = \case
|
isSegwit = \case
|
||||||
PayWitnessPKHash{} -> True
|
PayWitnessPKHash {} -> True
|
||||||
PayWitnessScriptHash{} -> True
|
PayWitnessScriptHash {} -> True
|
||||||
_ -> False
|
_ -> False
|
||||||
|
|
||||||
{- | High level represenation of a (v0) witness program
|
-- | High level represenation of a (v0) witness program
|
||||||
|
--
|
||||||
@since 0.11.0.0
|
-- @since 0.11.0.0
|
||||||
-}
|
|
||||||
data WitnessProgram
|
data WitnessProgram
|
||||||
= P2WPKH WitnessProgramPKH
|
= P2WPKH WitnessProgramPKH
|
||||||
| P2WSH WitnessProgramSH
|
| P2WSH WitnessProgramSH
|
||||||
| EmptyWitnessProgram
|
| EmptyWitnessProgram
|
||||||
deriving (Eq, Show)
|
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
|
-- | High level representation of a P2WPKH witness
|
||||||
-}
|
--
|
||||||
toWitnessStack :: WitnessProgram -> WitnessStack
|
-- @since 0.11.0.0
|
||||||
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
|
|
||||||
-}
|
|
||||||
data WitnessProgramPKH = WitnessProgramPKH
|
data WitnessProgramPKH = WitnessProgramPKH
|
||||||
{ witnessSignature :: !TxSignature
|
{ signature :: !TxSignature,
|
||||||
, witnessPubKey :: !PubKeyI
|
key :: !PublicKey
|
||||||
}
|
}
|
||||||
deriving (Eq, Show)
|
deriving (Eq)
|
||||||
|
|
||||||
{- | High-level representation of a P2WSH witness
|
-- | High-level representation of a P2WSH witness
|
||||||
|
--
|
||||||
@since 0.11.0.0
|
-- @since 0.11.0.0
|
||||||
-}
|
|
||||||
data WitnessProgramSH = WitnessProgramSH
|
data WitnessProgramSH = WitnessProgramSH
|
||||||
{ witnessScriptHashStack :: ![ByteString]
|
{ stack :: ![ByteString],
|
||||||
, witnessScriptHashScript :: !Script
|
script :: !Script
|
||||||
}
|
}
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
{- | Calculate the witness program from the transaction data
|
-- | Calculate the witness program from the transaction data
|
||||||
|
--
|
||||||
@since 0.11.0.0
|
-- @since 0.11.0.0
|
||||||
-}
|
|
||||||
viewWitnessProgram ::
|
viewWitnessProgram ::
|
||||||
Network -> ScriptOutput -> WitnessStack -> Either String WitnessProgram
|
Network ->
|
||||||
viewWitnessProgram net so witness = case so of
|
Ctx ->
|
||||||
PayWitnessPKHash _ | length witness == 2 -> do
|
ScriptOutput ->
|
||||||
sig <- decodeTxSig net $ head witness
|
WitnessStack ->
|
||||||
pubkey <- runGetS deserialize $ witness !! 1
|
Either String WitnessProgram
|
||||||
return . P2WPKH $ WitnessProgramPKH sig pubkey
|
viewWitnessProgram net ctx so witness = case so of
|
||||||
PayWitnessScriptHash _ | not (null witness) -> do
|
PayWitnessPKHash _ | length witness == 2 -> do
|
||||||
redeemScript <- runGetS deserialize $ last witness
|
sig <- decodeTxSig net ctx (head witness)
|
||||||
return . P2WSH $ WitnessProgramSH (init witness) redeemScript
|
pubkey <- unmarshal ctx $ witness !! 1
|
||||||
_
|
return . P2WPKH $ WitnessProgramPKH sig pubkey
|
||||||
| null witness -> return EmptyWitnessProgram
|
PayWitnessScriptHash _ | not (null witness) -> do
|
||||||
| otherwise -> Left "viewWitnessProgram: Invalid witness program"
|
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
|
-- | Analyze the witness, trying to match it with standard input structures
|
||||||
|
--
|
||||||
@since 0.11.0.0
|
-- @since 0.11.0.0
|
||||||
-}
|
|
||||||
decodeWitnessInput ::
|
decodeWitnessInput ::
|
||||||
Network ->
|
Network ->
|
||||||
WitnessProgram ->
|
Ctx ->
|
||||||
Either String (Maybe ScriptOutput, SimpleInput)
|
WitnessProgram ->
|
||||||
decodeWitnessInput net = \case
|
Either String (Maybe ScriptOutput, SimpleInput)
|
||||||
P2WPKH (WitnessProgramPKH sig key) -> return (Nothing, SpendPKHash sig key)
|
decodeWitnessInput net ctx = \case
|
||||||
P2WSH (WitnessProgramSH st scr) -> do
|
P2WPKH (WitnessProgramPKH sig key) -> return (Nothing, SpendPKHash sig key)
|
||||||
so <- decodeOutput scr
|
P2WSH (WitnessProgramSH st scr) -> do
|
||||||
fmap (Just so,) $ case (so, st) of
|
so <- decodeOutput ctx scr
|
||||||
(PayPK _, [sigBS]) ->
|
fmap (Just so,) $ case (so, st) of
|
||||||
SpendPK <$> decodeTxSig net sigBS
|
(PayPK _, [sigBS]) ->
|
||||||
(PayPKHash _, [sigBS, keyBS]) ->
|
SpendPK <$> decodeTxSig net ctx sigBS
|
||||||
SpendPKHash <$> decodeTxSig net sigBS <*> runGetS deserialize keyBS
|
(PayPKHash _, [sigBS, keyBS]) ->
|
||||||
(PayMulSig _ _, "" : sigsBS) ->
|
SpendPKHash
|
||||||
SpendMulSig <$> traverse (decodeTxSig net) sigsBS
|
<$> decodeTxSig net ctx sigBS
|
||||||
_ -> Left "decodeWitnessInput: Non-standard script output"
|
<*> unmarshal ctx keyBS
|
||||||
EmptyWitnessProgram -> Left "decodeWitnessInput: Empty witness program"
|
(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
|
-- | Create the witness program for a standard input
|
||||||
|
--
|
||||||
@since 0.11.0.0
|
-- @since 0.11.0.0
|
||||||
-}
|
calcWitnessProgram ::
|
||||||
calcWitnessProgram :: ScriptOutput -> ScriptInput -> Either String WitnessProgram
|
Network ->
|
||||||
calcWitnessProgram so si = case (so, si) of
|
Ctx ->
|
||||||
(PayWitnessPKHash{}, RegularInput (SpendPKHash sig pk)) -> p2wpkh sig pk
|
ScriptOutput ->
|
||||||
(PayScriptHash{}, RegularInput (SpendPKHash sig pk)) -> p2wpkh sig pk
|
ScriptInput ->
|
||||||
(PayWitnessScriptHash{}, ScriptHashInput i o) -> p2wsh i o
|
Either String WitnessProgram
|
||||||
(PayScriptHash{}, ScriptHashInput i o) -> p2wsh i o
|
calcWitnessProgram net ctx so si = case (so, si) of
|
||||||
_ -> Left "calcWitnessProgram: Invalid segwit SigInput"
|
(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
|
where
|
||||||
p2wpkh sig = return . P2WPKH . WitnessProgramPKH sig
|
p2wpkh sig =
|
||||||
p2wsh i o = return . P2WSH $ WitnessProgramSH (simpleInputStack i) (encodeOutput o)
|
P2WPKH . WitnessProgramPKH sig
|
||||||
|
p2wsh i =
|
||||||
|
P2WSH . WitnessProgramSH (simpleInputStack net ctx i) . encodeOutput ctx
|
||||||
|
|
||||||
{- | Create the witness stack required to spend a standard P2WSH input
|
-- | Create the witness stack required to spend a standard P2WSH input
|
||||||
|
--
|
||||||
@since 0.11.0.0
|
-- @since 0.11.0.0
|
||||||
-}
|
simpleInputStack :: Network -> Ctx -> SimpleInput -> [ByteString]
|
||||||
simpleInputStack :: SimpleInput -> [ByteString]
|
simpleInputStack net ctx = \case
|
||||||
simpleInputStack = \case
|
SpendPK sig -> [f sig]
|
||||||
SpendPK sig -> [f sig]
|
SpendPKHash sig k -> [f sig, marshal ctx k]
|
||||||
SpendPKHash sig k -> [f sig, runPutS (serialize k)]
|
SpendMulSig sigs -> "" : fmap f sigs
|
||||||
SpendMulSig sigs -> "" : fmap f sigs
|
|
||||||
where
|
where
|
||||||
f TxSignatureEmpty = ""
|
f TxSignatureEmpty = ""
|
||||||
f sig = encodeTxSig sig
|
f sig = encodeTxSig net ctx sig
|
||||||
|
@ -1,21 +1,26 @@
|
|||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE NoFieldSelectors #-}
|
||||||
|
|
||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Transaction.Taproot
|
-- Module : Haskoin.Transaction.Taproot
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
This module provides support for reperesenting full taproot outputs and parsing
|
-- This module provides support for reperesenting full taproot outputs and parsing
|
||||||
taproot witnesses. For reference see BIPS 340, 341, and 342.
|
-- taproot witnesses. For reference see BIPS 340, 341, and 342.
|
||||||
-}
|
module Haskoin.Transaction.Taproot
|
||||||
module Haskoin.Transaction.Taproot (
|
( XOnlyPubKey (..),
|
||||||
XOnlyPubKey (..),
|
|
||||||
TapLeafVersion,
|
TapLeafVersion,
|
||||||
MAST (..),
|
MAST (..),
|
||||||
mastCommitment,
|
mastCommitment,
|
||||||
@ -28,283 +33,283 @@ module Haskoin.Transaction.Taproot (
|
|||||||
viewTaprootWitness,
|
viewTaprootWitness,
|
||||||
encodeTaprootWitness,
|
encodeTaprootWitness,
|
||||||
verifyScriptPathData,
|
verifyScriptPathData,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Applicative (many)
|
import Control.Applicative (many)
|
||||||
import Control.Monad ((<=<))
|
import Control.Monad ((<=<))
|
||||||
import Crypto.Hash (
|
import Crypto.Hash
|
||||||
Digest,
|
( Digest,
|
||||||
SHA256,
|
SHA256,
|
||||||
digestFromByteString,
|
digestFromByteString,
|
||||||
hashFinalize,
|
hashFinalize,
|
||||||
hashUpdate,
|
hashUpdate,
|
||||||
hashUpdates,
|
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.Binary (Binary (..))
|
||||||
import Data.Bits ((.&.), (.|.))
|
import Data.Bits ((.&.), (.|.))
|
||||||
import Data.Bool (bool)
|
import Data.Bool (bool)
|
||||||
import qualified Data.ByteArray as BA
|
import Data.ByteArray qualified as BA
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
import qualified Data.ByteString as BS
|
import Data.ByteString qualified as BS
|
||||||
import Data.Bytes.Get (getBytes, runGetS)
|
import Data.Bytes.Get (MonadGet, getBytes, runGetS)
|
||||||
import Data.Bytes.Put (putByteString, runPutS)
|
import Data.Bytes.Put (MonadPut, putByteString, runPutL, runPutS)
|
||||||
import Data.Bytes.Serial (Serial (..), deserialize, serialize)
|
import Data.Bytes.Serial (Serial (..), deserialize, serialize)
|
||||||
import Data.Bytes.VarInt (VarInt (VarInt))
|
import Data.Bytes.VarInt (VarInt (VarInt))
|
||||||
import Data.Foldable (foldl')
|
import Data.Foldable (foldl')
|
||||||
import Data.Maybe (fromMaybe, mapMaybe)
|
import Data.Maybe (fromMaybe, mapMaybe)
|
||||||
import Data.Serialize (Serialize, get, getByteString, getWord8, put)
|
import Data.Serialize (Serialize, get, getByteString, getWord8, put)
|
||||||
import Data.Word (Word8)
|
import Data.Word (Word8)
|
||||||
import Haskoin.Crypto (PubKey, initTaggedHash, tweak, tweakAddPubKey)
|
import Haskoin.Crypto.Hash
|
||||||
import Haskoin.Keys.Common (PubKeyI (PubKeyI), pubKeyPoint)
|
import Haskoin.Crypto.Keys.Common
|
||||||
import Haskoin.Script.Common (Script)
|
import Haskoin.Crypto.Keys.Extended
|
||||||
import Haskoin.Script.Standard (ScriptOutput (PayWitness))
|
import Haskoin.Script.Common
|
||||||
import Haskoin.Transaction.Common (WitnessStack)
|
import Haskoin.Script.Standard
|
||||||
import Haskoin.Util (decodeHex, eitherToMaybe, encodeHex)
|
import Haskoin.Transaction.Common
|
||||||
|
import Haskoin.Util
|
||||||
|
|
||||||
{- | An x-only pubkey corresponds to the keys @(x,y)@ and @(x, -y)@. The
|
-- | 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
|
-- equality test only checks the x-coordinate. An x-only pubkey serializes to 32
|
||||||
bytes.
|
-- bytes.
|
||||||
|
--
|
||||||
@since 0.21.0
|
-- @since 0.21.0
|
||||||
-}
|
newtype XOnlyPubKey = XOnlyPubKey {point :: PubKey}
|
||||||
newtype XOnlyPubKey = XOnlyPubKey {xOnlyPubKey :: PubKey}
|
deriving (Read, Show)
|
||||||
deriving (Show)
|
|
||||||
|
|
||||||
instance Eq XOnlyPubKey where
|
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
|
instance Marshal Ctx XOnlyPubKey where
|
||||||
serialize (XOnlyPubKey pk) =
|
marshalPut ctx (XOnlyPubKey pk) =
|
||||||
putByteString
|
putByteString
|
||||||
. BS.drop 1
|
. BS.drop 1
|
||||||
. runPutS
|
. marshal ctx
|
||||||
. serialize
|
$ PublicKey pk True
|
||||||
$ PubKeyI pk True
|
|
||||||
deserialize =
|
|
||||||
either fail (pure . XOnlyPubKey . pubKeyPoint)
|
|
||||||
. runGetS deserialize
|
|
||||||
. BS.cons 0x02
|
|
||||||
=<< getBytes 32
|
|
||||||
|
|
||||||
instance Serialize XOnlyPubKey where
|
marshalGet ctx =
|
||||||
put = serialize
|
either fail (pure . XOnlyPubKey . (\PublicKey {point} -> point))
|
||||||
get = deserialize
|
. unmarshal ctx
|
||||||
|
. BS.cons 0x02
|
||||||
|
=<< getBytes 32
|
||||||
|
|
||||||
instance Binary XOnlyPubKey where
|
instance MarshalJSON Ctx XOnlyPubKey where
|
||||||
put = serialize
|
unmarshalValue ctx =
|
||||||
get = deserialize
|
withText "XOnlyPubKey" $ either fail pure . (des <=< hex)
|
||||||
|
where
|
||||||
|
hex = maybe (Left "Unable to decode hex") Right . decodeHex
|
||||||
|
des = runGetS $ marshalGet ctx
|
||||||
|
|
||||||
-- | Hex encoding
|
marshalValue ctx =
|
||||||
instance FromJSON XOnlyPubKey where
|
String . encodeHex . marshal ctx
|
||||||
parseJSON =
|
|
||||||
withText "XOnlyPubKey" $
|
|
||||||
either fail pure
|
|
||||||
. (runGetS deserialize <=< maybe (Left "Unable to decode hex") Right . decodeHex)
|
|
||||||
|
|
||||||
-- | Hex encoding
|
marshalEncoding ctx =
|
||||||
instance ToJSON XOnlyPubKey where
|
hexEncoding . runPutL . marshalPut ctx
|
||||||
toJSON = toJSON . encodeHex . runPutS . serialize
|
|
||||||
|
|
||||||
-- | @since 0.21.0
|
-- | @since 0.21.0
|
||||||
type TapLeafVersion = Word8
|
type TapLeafVersion = Word8
|
||||||
|
|
||||||
{- | Merklized Abstract Syntax Tree. This type can represent trees where only a
|
-- | 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
|
-- subset of the leaves are known. Note that the tree is invariant under swapping
|
||||||
branches at an internal node.
|
-- branches at an internal node.
|
||||||
|
--
|
||||||
@since 0.21.0
|
-- @since 0.21.0
|
||||||
-}
|
|
||||||
data MAST
|
data MAST
|
||||||
= MASTBranch MAST MAST
|
= MASTBranch MAST MAST
|
||||||
| MASTLeaf TapLeafVersion Script
|
| MASTLeaf TapLeafVersion Script
|
||||||
| MASTCommitment (Digest SHA256)
|
| MASTCommitment (Digest SHA256)
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
{- | Get the inclusion proofs for the leaves in the tree. The proof is ordered
|
-- | Get the inclusion proofs for the leaves in the tree. The proof is ordered
|
||||||
leaf-to-root.
|
-- leaf-to-root.
|
||||||
|
--
|
||||||
@since 0.21.0
|
-- @since 0.21.0
|
||||||
-}
|
|
||||||
getMerkleProofs :: MAST -> [(TapLeafVersion, Script, [Digest SHA256])]
|
getMerkleProofs :: MAST -> [(TapLeafVersion, Script, [Digest SHA256])]
|
||||||
getMerkleProofs = getProofs mempty
|
getMerkleProofs = getProofs mempty
|
||||||
where
|
where
|
||||||
getProofs proof = \case
|
getProofs proof = \case
|
||||||
MASTBranch branchL branchR ->
|
MASTBranch branchL branchR ->
|
||||||
(updateProof proof (mastCommitment branchR) <$> getMerkleProofs branchL)
|
(updateProof proof (mastCommitment branchR) <$> getMerkleProofs branchL)
|
||||||
<> (updateProof proof (mastCommitment branchL) <$> getMerkleProofs branchR)
|
<> (updateProof proof (mastCommitment branchL) <$> getMerkleProofs branchR)
|
||||||
MASTLeaf v s -> [(v, s, proof)]
|
MASTLeaf v s -> [(v, s, proof)]
|
||||||
MASTCommitment{} -> mempty
|
MASTCommitment {} -> mempty
|
||||||
updateProof proofInit branchCommitment (v, s, proofTail) =
|
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.
|
-- | Calculate the root hash for this tree.
|
||||||
|
--
|
||||||
@since 0.21.0
|
-- @since 0.21.0
|
||||||
-}
|
|
||||||
mastCommitment :: MAST -> Digest SHA256
|
mastCommitment :: MAST -> Digest SHA256
|
||||||
mastCommitment = \case
|
mastCommitment = \case
|
||||||
MASTBranch leftBranch rightBranch ->
|
MASTBranch leftBranch rightBranch ->
|
||||||
hashBranch (mastCommitment leftBranch) (mastCommitment rightBranch)
|
hashBranch (mastCommitment leftBranch) (mastCommitment rightBranch)
|
||||||
MASTLeaf leafVersion leafScript -> leafHash leafVersion leafScript
|
MASTLeaf leafVersion leafScript -> leafHash leafVersion leafScript
|
||||||
MASTCommitment theCommitment -> theCommitment
|
MASTCommitment theCommitment -> theCommitment
|
||||||
|
|
||||||
hashBranch :: Digest SHA256 -> Digest SHA256 -> Digest SHA256
|
hashBranch :: Digest SHA256 -> Digest SHA256 -> Digest SHA256
|
||||||
hashBranch hashA hashB =
|
hashBranch hashA hashB =
|
||||||
hashFinalize $
|
hashFinalize $
|
||||||
hashUpdates
|
hashUpdates
|
||||||
(initTaggedHash "TapBranch")
|
(initTaggedHash "TapBranch")
|
||||||
[ min hashA hashB
|
[ min hashA hashB,
|
||||||
, max hashA hashB
|
max hashA hashB
|
||||||
]
|
]
|
||||||
|
|
||||||
leafHash :: TapLeafVersion -> Script -> Digest SHA256
|
leafHash :: TapLeafVersion -> Script -> Digest SHA256
|
||||||
leafHash leafVersion leafScript =
|
leafHash leafVersion leafScript =
|
||||||
hashFinalize
|
hashFinalize
|
||||||
. hashUpdate (initTaggedHash "TapLeaf")
|
. hashUpdate (initTaggedHash "TapLeaf")
|
||||||
. runPutS
|
. runPutS
|
||||||
$ do
|
$ do
|
||||||
serialize leafVersion
|
serialize leafVersion
|
||||||
serialize $ VarInt (BS.length scriptBytes)
|
serialize $ VarInt (BS.length scriptBytes)
|
||||||
putByteString scriptBytes
|
putByteString scriptBytes
|
||||||
where
|
where
|
||||||
scriptBytes = runPutS $ serialize leafScript
|
scriptBytes = runPutS $ serialize leafScript
|
||||||
|
|
||||||
{- | Representation of a full taproot output.
|
-- | Representation of a full taproot output.
|
||||||
|
--
|
||||||
@since 0.21.0
|
-- @since 0.21.0
|
||||||
-}
|
|
||||||
data TaprootOutput = TaprootOutput
|
data TaprootOutput = TaprootOutput
|
||||||
{ taprootInternalKey :: PubKey
|
{ internalKey :: PubKey,
|
||||||
, taprootMAST :: Maybe MAST
|
mast :: Maybe MAST
|
||||||
}
|
}
|
||||||
deriving (Show)
|
|
||||||
|
|
||||||
-- | @since 0.21.0
|
-- | @since 0.21.0
|
||||||
taprootOutputKey :: TaprootOutput -> PubKey
|
taprootOutputKey :: Ctx -> TaprootOutput -> PubKey
|
||||||
taprootOutputKey TaprootOutput{taprootInternalKey, taprootMAST} =
|
taprootOutputKey ctx TaprootOutput {..} =
|
||||||
fromMaybe keyFail $ tweak commitment >>= tweakAddPubKey taprootInternalKey
|
fromMaybe keyFail $
|
||||||
|
tweak commitment >>= tweakAddPubKey ctx internalKey
|
||||||
where
|
where
|
||||||
commitment = taprootCommitment taprootInternalKey $ mastCommitment <$> taprootMAST
|
commitment =
|
||||||
|
taprootCommitment ctx internalKey $
|
||||||
|
mastCommitment <$> mast
|
||||||
keyFail = error "haskoin-core taprootOutputKey: key derivation failed"
|
keyFail = error "haskoin-core taprootOutputKey: key derivation failed"
|
||||||
|
|
||||||
taprootCommitment :: PubKey -> Maybe (Digest SHA256) -> ByteString
|
taprootCommitment :: Ctx -> PubKey -> Maybe (Digest SHA256) -> ByteString
|
||||||
taprootCommitment internalKey merkleRoot =
|
taprootCommitment ctx internalKey merkleRoot =
|
||||||
BA.convert . hashFinalize
|
BA.convert
|
||||||
. maybe id (flip hashUpdate) merkleRoot
|
. hashFinalize
|
||||||
. (`hashUpdate` keyBytes)
|
. maybe id (flip hashUpdate) merkleRoot
|
||||||
$ initTaggedHash "TapTweak"
|
. (`hashUpdate` keyBytes)
|
||||||
|
$ initTaggedHash "TapTweak"
|
||||||
where
|
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
|
-- | Comprehension of taproot witness data
|
||||||
-}
|
--
|
||||||
taprootScriptOutput :: TaprootOutput -> ScriptOutput
|
-- @since 0.21.0
|
||||||
taprootScriptOutput = PayWitness 0x01 . runPutS . serialize . XOnlyPubKey . taprootOutputKey
|
|
||||||
|
|
||||||
{- | Comprehension of taproot witness data
|
|
||||||
|
|
||||||
@since 0.21.0
|
|
||||||
-}
|
|
||||||
data TaprootWitness
|
data TaprootWitness
|
||||||
= -- | Signature
|
= -- | Signature
|
||||||
KeyPathSpend ByteString
|
KeyPathSpend ByteString
|
||||||
| ScriptPathSpend ScriptPathData
|
| ScriptPathSpend ScriptPathData
|
||||||
deriving (Eq, Show)
|
deriving (Eq)
|
||||||
|
|
||||||
-- | @since 0.21.0
|
-- | @since 0.21.0
|
||||||
data ScriptPathData = ScriptPathData
|
data ScriptPathData = ScriptPathData
|
||||||
{ scriptPathAnnex :: Maybe ByteString
|
{ annex :: Maybe ByteString,
|
||||||
, scriptPathStack :: [ByteString]
|
stack :: [ByteString],
|
||||||
, scriptPathScript :: Script
|
script :: Script,
|
||||||
, scriptPathExternalIsOdd :: Bool
|
extIsOdd :: Bool,
|
||||||
, -- | This value is masked by 0xFE
|
-- | This value is masked by 0xFE
|
||||||
scriptPathLeafVersion :: Word8
|
leafVersion :: Word8,
|
||||||
, scriptPathInternalKey :: PubKey
|
internalKey :: PubKey,
|
||||||
, scriptPathControl :: [ByteString]
|
control :: [ByteString]
|
||||||
}
|
}
|
||||||
deriving (Eq, Show)
|
deriving (Eq)
|
||||||
|
|
||||||
{- | Try to interpret a 'WitnessStack' as taproot witness data.
|
-- | Try to interpret a 'WitnessStack' as taproot witness data.
|
||||||
|
--
|
||||||
@since 0.21.0
|
-- @since 0.21.0
|
||||||
-}
|
viewTaprootWitness :: Ctx -> WitnessStack -> Maybe TaprootWitness
|
||||||
viewTaprootWitness :: WitnessStack -> Maybe TaprootWitness
|
viewTaprootWitness ctx witnessStack = case reverse witnessStack of
|
||||||
viewTaprootWitness witnessStack = case reverse witnessStack of
|
[sig] -> Just $ KeyPathSpend sig
|
||||||
[sig] -> Just $ KeyPathSpend sig
|
annexA : remainingStack
|
||||||
annexA : remainingStack
|
| 0x50 : _ <- BS.unpack annexA ->
|
||||||
| 0x50 : _ <- BS.unpack annexA ->
|
parseSpendPathData (Just annexA) remainingStack
|
||||||
parseSpendPathData (Just annexA) remainingStack
|
remainingStack -> parseSpendPathData Nothing remainingStack
|
||||||
remainingStack -> parseSpendPathData Nothing remainingStack
|
|
||||||
where
|
where
|
||||||
parseSpendPathData scriptPathAnnex = \case
|
parseSpendPathData annex = \case
|
||||||
scriptBytes : controlBytes : scriptPathStack -> do
|
scriptBytes : controlBytes : stack -> do
|
||||||
scriptPathScript <- eitherToMaybe $ runGetS deserialize scriptBytes
|
script <- eitherToMaybe $ runGetS deserialize scriptBytes
|
||||||
(v, scriptPathInternalKey, scriptPathControl) <- deconstructControl controlBytes
|
(v, internalKey, control) <- deconstructControl controlBytes
|
||||||
pure . ScriptPathSpend $
|
let extIsOdd = odd v
|
||||||
ScriptPathData
|
leafVersion = v .&. 0xFE
|
||||||
{ scriptPathAnnex
|
pure $ ScriptPathSpend ScriptPathData {..}
|
||||||
, scriptPathStack
|
_ -> Nothing
|
||||||
, scriptPathScript
|
|
||||||
, scriptPathExternalIsOdd = odd v
|
|
||||||
, scriptPathLeafVersion = v .&. 0xFE
|
|
||||||
, scriptPathInternalKey
|
|
||||||
, scriptPathControl
|
|
||||||
}
|
|
||||||
_ -> Nothing
|
|
||||||
deconstructControl = eitherToMaybe . runGetS deserializeControl
|
deconstructControl = eitherToMaybe . runGetS deserializeControl
|
||||||
deserializeControl = do
|
deserializeControl = do
|
||||||
v <- getWord8
|
v <- getWord8
|
||||||
k <- xOnlyPubKey <$> deserialize
|
XOnlyPubKey k <- marshalGet ctx
|
||||||
proof <- many $ getByteString 32
|
proof <- many $ getByteString 32
|
||||||
pure (v, k, proof)
|
pure (v, k, proof)
|
||||||
|
|
||||||
{- | Transform the high-level representation of taproot witness data into a witness stack
|
-- | Transform the high-level representation of taproot witness data into a witness stack
|
||||||
|
--
|
||||||
@since 0.21.0
|
-- @since 0.21.0
|
||||||
-}
|
encodeTaprootWitness :: Ctx -> TaprootWitness -> WitnessStack
|
||||||
encodeTaprootWitness :: TaprootWitness -> WitnessStack
|
encodeTaprootWitness ctx = \case
|
||||||
encodeTaprootWitness = \case
|
KeyPathSpend signature -> pure signature
|
||||||
KeyPathSpend signature -> pure signature
|
ScriptPathSpend scriptPathData -> wit scriptPathData
|
||||||
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
|
|
||||||
]
|
|
||||||
where
|
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.
|
-- | Verify that the script path spend is valid, except for script execution.
|
||||||
|
--
|
||||||
@since 0.21.0
|
-- @since 0.21.0
|
||||||
-}
|
|
||||||
verifyScriptPathData ::
|
verifyScriptPathData ::
|
||||||
-- | Output key
|
Ctx ->
|
||||||
PubKey ->
|
-- | Output key
|
||||||
ScriptPathData ->
|
PubKey ->
|
||||||
Bool
|
ScriptPathData ->
|
||||||
verifyScriptPathData outputKey scriptPathData = fromMaybe False $ do
|
Bool
|
||||||
tweak commitment >>= fmap onComputedKey . tweakAddPubKey (scriptPathInternalKey scriptPathData)
|
verifyScriptPathData ctx outkey spd = fromMaybe False $ do
|
||||||
|
tweak commitment
|
||||||
|
>>= fmap onComputedKey
|
||||||
|
. tweakAddPubKey ctx spd.internalKey
|
||||||
where
|
where
|
||||||
onComputedKey computedKey =
|
onComputedKey computedKey =
|
||||||
XOnlyPubKey outputKey == XOnlyPubKey computedKey
|
XOnlyPubKey outkey == XOnlyPubKey computedKey
|
||||||
&& expectedParity == keyParity computedKey
|
&& expectedParity == keyParity ctx computedKey
|
||||||
commitment = taprootCommitment (scriptPathInternalKey scriptPathData) (Just merkleRoot)
|
commitment =
|
||||||
|
taprootCommitment ctx spd.internalKey (Just merkleRoot)
|
||||||
merkleRoot =
|
merkleRoot =
|
||||||
foldl' hashBranch theLeafHash
|
foldl' hashBranch theLeafHash $
|
||||||
. mapMaybe (digestFromByteString @SHA256)
|
mapMaybe (digestFromByteString @SHA256) spd.control
|
||||||
$ scriptPathControl scriptPathData
|
theLeafHash =
|
||||||
theLeafHash = (leafHash <$> (.&. 0xFE) . scriptPathLeafVersion <*> scriptPathScript) scriptPathData
|
(leafHash <$> (.&. 0xFE) . (.leafVersion) <*> (.script))
|
||||||
expectedParity = bool 0 1 $ scriptPathExternalIsOdd scriptPathData
|
spd
|
||||||
|
expectedParity = bool 0 1 spd.extIsOdd
|
||||||
|
|
||||||
keyParity :: PubKey -> Word8
|
keyParity :: Ctx -> PubKey -> Word8
|
||||||
keyParity key = case BS.unpack . runPutS . serialize $ PubKeyI key True of
|
keyParity ctx key =
|
||||||
|
case BS.unpack . marshal ctx $ PublicKey key True of
|
||||||
0x02 : _ -> 0x00
|
0x02 : _ -> 0x00
|
||||||
_ -> 0x01
|
_ -> 0x01
|
||||||
|
@ -1,8 +1,3 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE ImportQualifiedPost #-}
|
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
-- Module : Haskoin.Util
|
-- Module : Haskoin.Util
|
||||||
-- Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
@ -11,376 +6,12 @@
|
|||||||
-- Stability : experimental
|
-- Stability : experimental
|
||||||
-- Portability : POSIX
|
-- Portability : POSIX
|
||||||
--
|
--
|
||||||
-- This module defines various utility functions used across the library.
|
-- Marshalling and helper functions.
|
||||||
module Haskoin.Util
|
module Haskoin.Util
|
||||||
( -- * ByteString Helpers
|
( module Marshal,
|
||||||
bsToInteger,
|
module Helpers,
|
||||||
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,
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Monad
|
import Haskoin.Util.Helpers as Helpers
|
||||||
import Control.Monad.Except (ExceptT (..), liftEither)
|
import Haskoin.Util.Marshal as Marshal
|
||||||
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
|
|
||||||
|
@ -1,16 +1,16 @@
|
|||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Test
|
-- Module : Haskoin.Test
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
|
--
|
||||||
Arbitrary instances for testing.
|
-- Arbitrary instances for testing.
|
||||||
-}
|
module Haskoin.Util.Arbitrary
|
||||||
module Haskoin.Util.Arbitrary (
|
( module X,
|
||||||
module X,
|
)
|
||||||
) where
|
where
|
||||||
|
|
||||||
import Haskoin.Util.Arbitrary.Address as X
|
import Haskoin.Util.Arbitrary.Address as X
|
||||||
import Haskoin.Util.Arbitrary.Block as X
|
import Haskoin.Util.Arbitrary.Block as X
|
||||||
|
@ -1,19 +1,18 @@
|
|||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
|
||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Test.Address
|
-- Module : Haskoin.Test.Address
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
-}
|
|
||||||
module Haskoin.Util.Arbitrary.Address where
|
module Haskoin.Util.Arbitrary.Address where
|
||||||
|
|
||||||
import qualified Data.ByteString as B
|
import qualified Data.ByteString as B
|
||||||
import Haskoin.Address
|
import Haskoin.Address
|
||||||
import Haskoin.Constants
|
import Haskoin.Network.Constants
|
||||||
import Haskoin.Data
|
import Haskoin.Network.Data
|
||||||
import Haskoin.Util.Arbitrary.Crypto
|
import Haskoin.Util.Arbitrary.Crypto
|
||||||
import Haskoin.Util.Arbitrary.Util
|
import Haskoin.Util.Arbitrary.Util
|
||||||
import Test.QuickCheck
|
import Test.QuickCheck
|
||||||
@ -25,21 +24,21 @@ arbitraryAddress = oneof [arbitraryPubKeyAddress, arbitraryScriptAddress]
|
|||||||
-- | Arbitrary address including pay-to-witness
|
-- | Arbitrary address including pay-to-witness
|
||||||
arbitraryAddressAll :: Gen Address
|
arbitraryAddressAll :: Gen Address
|
||||||
arbitraryAddressAll =
|
arbitraryAddressAll =
|
||||||
oneof
|
oneof
|
||||||
[ arbitraryPubKeyAddress
|
[ arbitraryPubKeyAddress,
|
||||||
, arbitraryScriptAddress
|
arbitraryScriptAddress,
|
||||||
, arbitraryWitnessPubKeyAddress
|
arbitraryWitnessPubKeyAddress,
|
||||||
, arbitraryWitnessScriptAddress
|
arbitraryWitnessScriptAddress,
|
||||||
, arbitraryWitnessAddress
|
arbitraryWitnessAddress
|
||||||
]
|
]
|
||||||
|
|
||||||
-- | Arbitrary valid combination of (Network, Address)
|
-- | Arbitrary valid combination of (Network, Address)
|
||||||
arbitraryNetAddress :: Gen (Network, Address)
|
arbitraryNetAddress :: Gen (Network, Address)
|
||||||
arbitraryNetAddress = do
|
arbitraryNetAddress = do
|
||||||
net <- arbitraryNetwork
|
net <- arbitraryNetwork
|
||||||
if net `elem` [bch, bchTest, bchTest4, bchRegTest]
|
if net `elem` [bch, bchTest, bchTest4, bchRegTest]
|
||||||
then (net,) <$> arbitraryAddress
|
then (net,) <$> arbitraryAddress
|
||||||
else (net,) <$> arbitraryAddressAll
|
else (net,) <$> arbitraryAddressAll
|
||||||
|
|
||||||
-- | Arbitrary pay-to-public-key-hash address.
|
-- | Arbitrary pay-to-public-key-hash address.
|
||||||
arbitraryPubKeyAddress :: Gen Address
|
arbitraryPubKeyAddress :: Gen Address
|
||||||
@ -59,8 +58,8 @@ arbitraryWitnessScriptAddress = WitnessPubKeyAddress <$> arbitraryHash160
|
|||||||
|
|
||||||
arbitraryWitnessAddress :: Gen Address
|
arbitraryWitnessAddress :: Gen Address
|
||||||
arbitraryWitnessAddress = do
|
arbitraryWitnessAddress = do
|
||||||
ver <- choose (1, 16)
|
ver <- choose (1, 16)
|
||||||
len <- choose (2, 40)
|
len <- choose (2, 40)
|
||||||
ws <- vectorOf len arbitrary
|
ws <- vectorOf len arbitrary
|
||||||
let bs = B.pack ws
|
let bs = B.pack ws
|
||||||
return $ WitnessAddress ver bs
|
return $ WitnessAddress ver bs
|
||||||
|
@ -1,16 +1,16 @@
|
|||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Test.Block
|
-- Module : Haskoin.Test.Block
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
-}
|
|
||||||
module Haskoin.Util.Arbitrary.Block where
|
module Haskoin.Util.Arbitrary.Block where
|
||||||
|
|
||||||
import qualified Data.HashMap.Strict as HashMap
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
import Haskoin.Block
|
import Haskoin.Block
|
||||||
import Haskoin.Data
|
import Haskoin.Crypto (Ctx)
|
||||||
|
import Haskoin.Network.Data
|
||||||
import Haskoin.Util.Arbitrary.Crypto
|
import Haskoin.Util.Arbitrary.Crypto
|
||||||
import Haskoin.Util.Arbitrary.Network
|
import Haskoin.Util.Arbitrary.Network
|
||||||
import Haskoin.Util.Arbitrary.Transaction
|
import Haskoin.Util.Arbitrary.Transaction
|
||||||
@ -18,22 +18,23 @@ import Haskoin.Util.Arbitrary.Util
|
|||||||
import Test.QuickCheck
|
import Test.QuickCheck
|
||||||
|
|
||||||
-- | Block full or arbitrary transactions.
|
-- | Block full or arbitrary transactions.
|
||||||
arbitraryBlock :: Network -> Gen Block
|
arbitraryBlock :: Network -> Ctx -> Gen Block
|
||||||
arbitraryBlock net = do
|
arbitraryBlock net ctx = do
|
||||||
h <- arbitraryBlockHeader
|
h <- arbitraryBlockHeader
|
||||||
c <- choose (0, 10)
|
c <- choose (0, 10)
|
||||||
txs <- vectorOf c (arbitraryTx net)
|
txs <- vectorOf c (arbitraryTx net ctx)
|
||||||
return $ Block h txs
|
return $ Block h txs
|
||||||
|
|
||||||
-- | Block header with random hash.
|
-- | Block header with random hash.
|
||||||
arbitraryBlockHeader :: Gen BlockHeader
|
arbitraryBlockHeader :: Gen BlockHeader
|
||||||
arbitraryBlockHeader =
|
arbitraryBlockHeader =
|
||||||
BlockHeader <$> arbitrary
|
BlockHeader
|
||||||
<*> arbitraryBlockHash
|
<$> arbitrary
|
||||||
<*> arbitraryHash256
|
<*> arbitraryBlockHash
|
||||||
<*> arbitrary
|
<*> arbitraryHash256
|
||||||
<*> arbitrary
|
<*> arbitrary
|
||||||
<*> arbitrary
|
<*> arbitrary
|
||||||
|
<*> arbitrary
|
||||||
|
|
||||||
-- | Arbitrary block hash.
|
-- | Arbitrary block hash.
|
||||||
arbitraryBlockHash :: Gen BlockHash
|
arbitraryBlockHash :: Gen BlockHash
|
||||||
@ -42,45 +43,45 @@ arbitraryBlockHash = BlockHash <$> arbitraryHash256
|
|||||||
-- | Arbitrary 'GetBlocks' object with at least one block hash.
|
-- | Arbitrary 'GetBlocks' object with at least one block hash.
|
||||||
arbitraryGetBlocks :: Gen GetBlocks
|
arbitraryGetBlocks :: Gen GetBlocks
|
||||||
arbitraryGetBlocks =
|
arbitraryGetBlocks =
|
||||||
GetBlocks <$> arbitrary
|
GetBlocks
|
||||||
<*> listOf1 arbitraryBlockHash
|
<$> arbitrary
|
||||||
<*> arbitraryBlockHash
|
<*> listOf1 arbitraryBlockHash
|
||||||
|
<*> arbitraryBlockHash
|
||||||
|
|
||||||
-- | Arbitrary 'GetHeaders' object with at least one block header.
|
-- | Arbitrary 'GetHeaders' object with at least one block header.
|
||||||
arbitraryGetHeaders :: Gen GetHeaders
|
arbitraryGetHeaders :: Gen GetHeaders
|
||||||
arbitraryGetHeaders =
|
arbitraryGetHeaders =
|
||||||
GetHeaders <$> arbitrary
|
GetHeaders
|
||||||
<*> listOf1 arbitraryBlockHash
|
<$> arbitrary
|
||||||
<*> arbitraryBlockHash
|
<*> listOf1 arbitraryBlockHash
|
||||||
|
<*> arbitraryBlockHash
|
||||||
|
|
||||||
-- | Arbitrary 'Headers' object with at least one block header.
|
-- | Arbitrary 'Headers' object with at least one block header.
|
||||||
arbitraryHeaders :: Gen Headers
|
arbitraryHeaders :: Gen Headers
|
||||||
arbitraryHeaders =
|
arbitraryHeaders =
|
||||||
Headers <$> listOf1 ((,) <$> arbitraryBlockHeader <*> arbitraryVarInt)
|
Headers <$> listOf1 ((,) <$> arbitraryBlockHeader <*> arbitraryVarInt)
|
||||||
|
|
||||||
-- | Arbitrary 'MerkleBlock' with at least one hash.
|
-- | Arbitrary 'MerkleBlock' with at least one hash.
|
||||||
arbitraryMerkleBlock :: Gen MerkleBlock
|
arbitraryMerkleBlock :: Gen MerkleBlock
|
||||||
arbitraryMerkleBlock = do
|
arbitraryMerkleBlock = do
|
||||||
bh <- arbitraryBlockHeader
|
bh <- arbitraryBlockHeader
|
||||||
ntx <- arbitrary
|
ntx <- arbitrary
|
||||||
hashes <- listOf1 arbitraryHash256
|
hashes <- listOf1 arbitraryHash256
|
||||||
c <- choose (1, 10)
|
c <- choose (1, 10)
|
||||||
flags <- vectorOf (c * 8) arbitrary
|
flags <- vectorOf (c * 8) arbitrary
|
||||||
return $ MerkleBlock bh ntx hashes flags
|
return $ MerkleBlock bh ntx hashes flags
|
||||||
|
|
||||||
-- | Arbitrary 'BlockNode'
|
-- | Arbitrary 'BlockNode'
|
||||||
arbitraryBlockNode :: Gen BlockNode
|
arbitraryBlockNode :: Gen BlockNode
|
||||||
arbitraryBlockNode =
|
arbitraryBlockNode =
|
||||||
oneof
|
BlockNode
|
||||||
[ BlockNode
|
<$> arbitraryBlockHeader
|
||||||
<$> arbitraryBlockHeader
|
<*> choose (0, maxBound)
|
||||||
<*> choose (0, maxBound)
|
<*> arbitrarySizedNatural
|
||||||
<*> arbitrarySizedNatural
|
<*> arbitraryBlockHash
|
||||||
<*> arbitraryBlockHash
|
|
||||||
]
|
|
||||||
|
|
||||||
-- | Arbitrary 'HeaderMemory'
|
-- | Arbitrary 'HeaderMemory'
|
||||||
arbitraryHeaderMemory :: Gen HeaderMemory
|
arbitraryHeaderMemory :: Gen HeaderMemory
|
||||||
arbitraryHeaderMemory = do
|
arbitraryHeaderMemory = do
|
||||||
ls <- listOf $ (,) <$> arbitrary <*> arbitraryBSS
|
ls <- listOf $ (,) <$> arbitrary <*> arbitraryBSS
|
||||||
HeaderMemory (HashMap.fromList ls) <$> arbitraryBlockNode
|
HeaderMemory (HashMap.fromList ls) <$> arbitraryBlockNode
|
||||||
|
@ -1,11 +1,10 @@
|
|||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Test.Crypto
|
-- Module : Haskoin.Test.Crypto
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
-}
|
|
||||||
module Haskoin.Util.Arbitrary.Crypto where
|
module Haskoin.Util.Arbitrary.Crypto where
|
||||||
|
|
||||||
import Haskoin.Crypto.Hash
|
import Haskoin.Crypto.Hash
|
||||||
@ -15,19 +14,19 @@ import Test.QuickCheck
|
|||||||
-- | Arbitrary 160-bit hash.
|
-- | Arbitrary 160-bit hash.
|
||||||
arbitraryHash160 :: Gen Hash160
|
arbitraryHash160 :: Gen Hash160
|
||||||
arbitraryHash160 =
|
arbitraryHash160 =
|
||||||
ripemd160 <$> arbitraryBSn 20
|
ripemd160 <$> arbitraryBSn 20
|
||||||
|
|
||||||
-- | Arbitrary 256-bit hash.
|
-- | Arbitrary 256-bit hash.
|
||||||
arbitraryHash256 :: Gen Hash256
|
arbitraryHash256 :: Gen Hash256
|
||||||
arbitraryHash256 =
|
arbitraryHash256 =
|
||||||
sha256 <$> arbitraryBSn 32
|
sha256 <$> arbitraryBSn 32
|
||||||
|
|
||||||
-- | Arbitrary 512-bit hash.
|
-- | Arbitrary 512-bit hash.
|
||||||
arbitraryHash512 :: Gen Hash512
|
arbitraryHash512 :: Gen Hash512
|
||||||
arbitraryHash512 =
|
arbitraryHash512 =
|
||||||
sha512 <$> arbitraryBSn 64
|
sha512 <$> arbitraryBSn 64
|
||||||
|
|
||||||
-- | Arbitrary 32-bit checksum.
|
-- | Arbitrary 32-bit checksum.
|
||||||
arbitraryCheckSum32 :: Gen CheckSum32
|
arbitraryCheckSum32 :: Gen CheckSum32
|
||||||
arbitraryCheckSum32 =
|
arbitraryCheckSum32 =
|
||||||
checkSum32 <$> arbitraryBSn 4
|
checkSum32 <$> arbitraryBSn 4
|
||||||
|
@ -1,33 +1,34 @@
|
|||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Test.Keys
|
-- Module : Haskoin.Test.Keys
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
-}
|
|
||||||
module Haskoin.Util.Arbitrary.Keys where
|
module Haskoin.Util.Arbitrary.Keys where
|
||||||
|
|
||||||
|
import Crypto.Secp256k1
|
||||||
import Data.Bits (clearBit)
|
import Data.Bits (clearBit)
|
||||||
import Data.Coerce (coerce)
|
import Data.Coerce (coerce)
|
||||||
import Data.List (foldl')
|
import Data.List (foldl')
|
||||||
import Data.Word (Word32)
|
import Data.Word (Word32)
|
||||||
import Haskoin.Crypto
|
import Haskoin.Crypto.Hash
|
||||||
import Haskoin.Keys.Common
|
import Haskoin.Crypto.Keys.Common
|
||||||
import Haskoin.Keys.Extended
|
import Haskoin.Crypto.Keys.Extended
|
||||||
import Haskoin.Keys.Extended.Internal (Fingerprint (..))
|
import Haskoin.Crypto.Keys.Extended.Internal (Fingerprint (..))
|
||||||
|
import Haskoin.Crypto.Signature
|
||||||
import Haskoin.Util.Arbitrary.Crypto
|
import Haskoin.Util.Arbitrary.Crypto
|
||||||
import Test.QuickCheck
|
import Test.QuickCheck
|
||||||
|
|
||||||
-- | Arbitrary private key with arbitrary compressed flag.
|
-- | Arbitrary private key with arbitrary compressed flag.
|
||||||
arbitrarySecKeyI :: Gen SecKeyI
|
arbitraryPrivateKey :: Gen PrivateKey
|
||||||
arbitrarySecKeyI = wrapSecKey <$> arbitrary <*> arbitrary
|
arbitraryPrivateKey = wrapSecKey <$> arbitrary <*> arbitrary
|
||||||
|
|
||||||
-- | Arbitrary keypair, both either compressed or not.
|
-- | Arbitrary keypair, both either compressed or not.
|
||||||
arbitraryKeyPair :: Gen (SecKeyI, PubKeyI)
|
arbitraryKeyPair :: Ctx -> Gen (PrivateKey, PublicKey)
|
||||||
arbitraryKeyPair = do
|
arbitraryKeyPair ctx = do
|
||||||
k <- arbitrarySecKeyI
|
k <- arbitraryPrivateKey
|
||||||
return (k, derivePubKeyI k)
|
return (k, derivePublicKey ctx k)
|
||||||
|
|
||||||
arbitraryFingerprint :: Gen Fingerprint
|
arbitraryFingerprint :: Gen Fingerprint
|
||||||
arbitraryFingerprint = Fingerprint <$> arbitrary
|
arbitraryFingerprint = Fingerprint <$> arbitrary
|
||||||
@ -35,15 +36,16 @@ arbitraryFingerprint = Fingerprint <$> arbitrary
|
|||||||
-- | Arbitrary extended private key.
|
-- | Arbitrary extended private key.
|
||||||
arbitraryXPrvKey :: Gen XPrvKey
|
arbitraryXPrvKey :: Gen XPrvKey
|
||||||
arbitraryXPrvKey =
|
arbitraryXPrvKey =
|
||||||
XPrvKey <$> arbitrary
|
XPrvKey
|
||||||
<*> arbitraryFingerprint
|
<$> arbitrary
|
||||||
<*> arbitrary
|
<*> arbitraryFingerprint
|
||||||
<*> arbitraryHash256
|
<*> arbitrary
|
||||||
<*> arbitrary
|
<*> arbitraryHash256
|
||||||
|
<*> arbitrary
|
||||||
|
|
||||||
-- | Arbitrary extended public key with its corresponding private key.
|
-- | Arbitrary extended public key with its corresponding private key.
|
||||||
arbitraryXPubKey :: Gen (XPrvKey, XPubKey)
|
arbitraryXPubKey :: Ctx -> Gen (XPrvKey, XPubKey)
|
||||||
arbitraryXPubKey = (\k -> (k, deriveXPubKey k)) <$> arbitraryXPrvKey
|
arbitraryXPubKey ctx = (\k -> (k, deriveXPubKey ctx k)) <$> arbitraryXPrvKey
|
||||||
|
|
||||||
{- Custom derivations -}
|
{- Custom derivations -}
|
||||||
|
|
||||||
@ -54,10 +56,10 @@ genIndex = (`clearBit` 31) <$> arbitrary
|
|||||||
-- | Arbitrary BIP-32 path index. Can be hardened or not.
|
-- | Arbitrary BIP-32 path index. Can be hardened or not.
|
||||||
arbitraryBip32PathIndex :: Gen Bip32PathIndex
|
arbitraryBip32PathIndex :: Gen Bip32PathIndex
|
||||||
arbitraryBip32PathIndex =
|
arbitraryBip32PathIndex =
|
||||||
oneof
|
oneof
|
||||||
[ Bip32SoftIndex <$> genIndex
|
[ Bip32SoftIndex <$> genIndex,
|
||||||
, Bip32HardIndex <$> genIndex
|
Bip32HardIndex <$> genIndex
|
||||||
]
|
]
|
||||||
|
|
||||||
-- | Arbitrary BIP-32 derivation path composed of only hardened derivations.
|
-- | Arbitrary BIP-32 derivation path composed of only hardened derivations.
|
||||||
arbitraryHardPath :: Gen HardPath
|
arbitraryHardPath :: Gen HardPath
|
||||||
@ -71,24 +73,22 @@ arbitrarySoftPath = foldl' (:/) Deriv <$> listOf genIndex
|
|||||||
arbitraryDerivPath :: Gen DerivPath
|
arbitraryDerivPath :: Gen DerivPath
|
||||||
arbitraryDerivPath = concatBip32Segments <$> listOf arbitraryBip32PathIndex
|
arbitraryDerivPath = concatBip32Segments <$> listOf arbitraryBip32PathIndex
|
||||||
|
|
||||||
{- | Arbitrary parsed derivation path. Can contain 'ParsedPrv', 'ParsedPub' or
|
-- | Arbitrary parsed derivation path. Can contain 'ParsedPrv', 'ParsedPub' or
|
||||||
'ParsedEmpty' elements.
|
-- 'ParsedEmpty' elements.
|
||||||
-}
|
|
||||||
arbitraryParsedPath :: Gen ParsedPath
|
arbitraryParsedPath :: Gen ParsedPath
|
||||||
arbitraryParsedPath =
|
arbitraryParsedPath =
|
||||||
oneof
|
oneof
|
||||||
[ ParsedPrv <$> arbitraryDerivPath
|
[ ParsedPrv <$> arbitraryDerivPath,
|
||||||
, ParsedPub <$> arbitraryDerivPath
|
ParsedPub <$> arbitraryDerivPath,
|
||||||
, ParsedEmpty <$> arbitraryDerivPath
|
ParsedEmpty <$> arbitraryDerivPath
|
||||||
]
|
]
|
||||||
|
|
||||||
{- | Arbitrary message hash, private key, nonce and corresponding signature. The
|
-- | Arbitrary message hash, private key, nonce and corresponding signature. The
|
||||||
signature is generated with a random message, random private key and a random
|
-- signature is generated with a random message, random private key and a random
|
||||||
nonce.
|
-- nonce.
|
||||||
-}
|
arbitrarySignature :: Ctx -> Gen (Hash256, SecKey, Sig)
|
||||||
arbitrarySignature :: Gen (Hash256, SecKey, Sig)
|
arbitrarySignature ctx = do
|
||||||
arbitrarySignature = do
|
m <- arbitraryHash256
|
||||||
m <- arbitraryHash256
|
key <- arbitrary
|
||||||
key <- arbitrary
|
let sig = signHash ctx key m
|
||||||
let sig = signHash key m
|
return (m, key, sig)
|
||||||
return (m, key, sig)
|
|
||||||
|
@ -1,14 +1,14 @@
|
|||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Test.Message
|
-- Module : Haskoin.Test.Message
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
-}
|
|
||||||
module Haskoin.Util.Arbitrary.Message where
|
module Haskoin.Util.Arbitrary.Message where
|
||||||
|
|
||||||
import Haskoin.Data
|
import Haskoin.Crypto (Ctx)
|
||||||
|
import Haskoin.Network.Data
|
||||||
import Haskoin.Network.Message
|
import Haskoin.Network.Message
|
||||||
import Haskoin.Util.Arbitrary.Block
|
import Haskoin.Util.Arbitrary.Block
|
||||||
import Haskoin.Util.Arbitrary.Crypto
|
import Haskoin.Util.Arbitrary.Crypto
|
||||||
@ -19,34 +19,35 @@ import Test.QuickCheck
|
|||||||
-- | Arbitrary 'MessageHeader'.
|
-- | Arbitrary 'MessageHeader'.
|
||||||
arbitraryMessageHeader :: Gen MessageHeader
|
arbitraryMessageHeader :: Gen MessageHeader
|
||||||
arbitraryMessageHeader =
|
arbitraryMessageHeader =
|
||||||
MessageHeader <$> arbitrary
|
MessageHeader
|
||||||
<*> arbitraryMessageCommand
|
<$> arbitrary
|
||||||
<*> arbitrary
|
<*> arbitraryMessageCommand
|
||||||
<*> arbitraryCheckSum32
|
<*> arbitrary
|
||||||
|
<*> arbitraryCheckSum32
|
||||||
|
|
||||||
-- | Arbitrary 'Message'.
|
-- | Arbitrary 'Message'.
|
||||||
arbitraryMessage :: Network -> Gen Message
|
arbitraryMessage :: Network -> Ctx -> Gen Message
|
||||||
arbitraryMessage net =
|
arbitraryMessage net ctx =
|
||||||
oneof
|
oneof
|
||||||
[ MVersion <$> arbitraryVersion
|
[ MVersion <$> arbitraryVersion,
|
||||||
, return MVerAck
|
return MVerAck,
|
||||||
, MAddr <$> arbitraryAddr1
|
MAddr <$> arbitraryAddr1,
|
||||||
, MInv <$> arbitraryInv1
|
MInv <$> arbitraryInv1,
|
||||||
, MGetData <$> arbitraryGetData
|
MGetData <$> arbitraryGetData,
|
||||||
, MNotFound <$> arbitraryNotFound
|
MNotFound <$> arbitraryNotFound,
|
||||||
, MGetBlocks <$> arbitraryGetBlocks
|
MGetBlocks <$> arbitraryGetBlocks,
|
||||||
, MGetHeaders <$> arbitraryGetHeaders
|
MGetHeaders <$> arbitraryGetHeaders,
|
||||||
, MTx <$> arbitraryTx net
|
MTx <$> arbitraryTx net ctx,
|
||||||
, MBlock <$> arbitraryBlock net
|
MBlock <$> arbitraryBlock net ctx,
|
||||||
, MMerkleBlock <$> arbitraryMerkleBlock
|
MMerkleBlock <$> arbitraryMerkleBlock,
|
||||||
, MHeaders <$> arbitraryHeaders
|
MHeaders <$> arbitraryHeaders,
|
||||||
, return MGetAddr
|
return MGetAddr,
|
||||||
, MFilterLoad <$> arbitraryFilterLoad
|
MFilterLoad <$> arbitraryFilterLoad,
|
||||||
, MFilterAdd <$> arbitraryFilterAdd
|
MFilterAdd <$> arbitraryFilterAdd,
|
||||||
, return MFilterClear
|
return MFilterClear,
|
||||||
, MPing <$> arbitraryPing
|
MPing <$> arbitraryPing,
|
||||||
, MPong <$> arbitraryPong
|
MPong <$> arbitraryPong,
|
||||||
, MAlert <$> arbitraryAlert
|
MAlert <$> arbitraryAlert,
|
||||||
, MReject <$> arbitraryReject
|
MReject <$> arbitraryReject,
|
||||||
, return MSendHeaders
|
return MSendHeaders
|
||||||
]
|
]
|
||||||
|
@ -1,11 +1,10 @@
|
|||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Test.Network
|
-- Module : Haskoin.Test.Network
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
-}
|
|
||||||
module Haskoin.Util.Arbitrary.Network where
|
module Haskoin.Util.Arbitrary.Network where
|
||||||
|
|
||||||
import qualified Data.ByteString as BS (empty, pack)
|
import qualified Data.ByteString as BS (empty, pack)
|
||||||
@ -28,20 +27,20 @@ arbitraryVarString = VarString <$> arbitraryBS
|
|||||||
-- | Arbitrary 'NetworkAddress'.
|
-- | Arbitrary 'NetworkAddress'.
|
||||||
arbitraryNetworkAddress :: Gen NetworkAddress
|
arbitraryNetworkAddress :: Gen NetworkAddress
|
||||||
arbitraryNetworkAddress = do
|
arbitraryNetworkAddress = do
|
||||||
s <- arbitrary
|
s <- arbitrary
|
||||||
a <- arbitrary
|
a <- arbitrary
|
||||||
p <- arbitrary
|
p <- arbitrary
|
||||||
d <-
|
d <-
|
||||||
oneof
|
oneof
|
||||||
[ do
|
[ do
|
||||||
b <- arbitrary
|
b <- arbitrary
|
||||||
c <- arbitrary
|
c <- arbitrary
|
||||||
d <- arbitrary
|
d <- arbitrary
|
||||||
return $ SockAddrInet6 (fromIntegral p) 0 (a, b, c, d) 0
|
return $ SockAddrInet6 (fromIntegral p) 0 (a, b, c, d) 0,
|
||||||
, return $ SockAddrInet (fromIntegral (p :: Word16)) a
|
return $ SockAddrInet (fromIntegral (p :: Word16)) a
|
||||||
]
|
]
|
||||||
let n = sockToHostAddress d
|
let n = sockToHostAddress d
|
||||||
return $ NetworkAddress s n
|
return $ NetworkAddress s n
|
||||||
|
|
||||||
-- | Arbitrary 'NetworkAddressTime'.
|
-- | Arbitrary 'NetworkAddressTime'.
|
||||||
arbitraryNetworkAddressTime :: Gen (Word32, NetworkAddress)
|
arbitraryNetworkAddressTime :: Gen (Word32, NetworkAddress)
|
||||||
@ -62,52 +61,52 @@ arbitraryInv1 = Inv <$> listOf1 arbitraryInvVector
|
|||||||
-- | Arbitrary 'Version'.
|
-- | Arbitrary 'Version'.
|
||||||
arbitraryVersion :: Gen Version
|
arbitraryVersion :: Gen Version
|
||||||
arbitraryVersion =
|
arbitraryVersion =
|
||||||
Version <$> arbitrary
|
Version
|
||||||
<*> arbitrary
|
<$> arbitrary
|
||||||
<*> arbitrary
|
<*> arbitrary
|
||||||
<*> arbitraryNetworkAddress
|
<*> arbitrary
|
||||||
<*> arbitraryNetworkAddress
|
<*> arbitraryNetworkAddress
|
||||||
<*> arbitrary
|
<*> arbitraryNetworkAddress
|
||||||
<*> arbitraryVarString
|
<*> arbitrary
|
||||||
<*> arbitrary
|
<*> arbitraryVarString
|
||||||
<*> arbitrary
|
<*> arbitrary
|
||||||
|
<*> arbitrary
|
||||||
|
|
||||||
-- | Arbitrary non-empty 'Addr'.
|
-- | Arbitrary non-empty 'Addr'.
|
||||||
arbitraryAddr1 :: Gen Addr
|
arbitraryAddr1 :: Gen Addr
|
||||||
arbitraryAddr1 = Addr <$> listOf1 arbitraryNetworkAddressTime
|
arbitraryAddr1 = Addr <$> listOf1 arbitraryNetworkAddressTime
|
||||||
|
|
||||||
{- | Arbitrary 'Alert' with random payload and signature. Signature is not
|
-- | Arbitrary 'Alert' with random payload and signature. Signature is not
|
||||||
valid.
|
-- valid.
|
||||||
-}
|
|
||||||
arbitraryAlert :: Gen Alert
|
arbitraryAlert :: Gen Alert
|
||||||
arbitraryAlert = Alert <$> arbitraryVarString <*> arbitraryVarString
|
arbitraryAlert = Alert <$> arbitraryVarString <*> arbitraryVarString
|
||||||
|
|
||||||
-- | Arbitrary 'Reject'.
|
-- | Arbitrary 'Reject'.
|
||||||
arbitraryReject :: Gen Reject
|
arbitraryReject :: Gen Reject
|
||||||
arbitraryReject = do
|
arbitraryReject = do
|
||||||
m <- arbitraryMessageCommand
|
m <- arbitraryMessageCommand
|
||||||
c <- arbitraryRejectCode
|
c <- arbitraryRejectCode
|
||||||
s <- arbitraryVarString
|
s <- arbitraryVarString
|
||||||
d <-
|
d <-
|
||||||
oneof
|
oneof
|
||||||
[ return BS.empty
|
[ return BS.empty,
|
||||||
, BS.pack <$> vectorOf 32 arbitrary
|
BS.pack <$> vectorOf 32 arbitrary
|
||||||
]
|
]
|
||||||
return $ Reject m c s d
|
return $ Reject m c s d
|
||||||
|
|
||||||
-- | Arbitrary 'RejectCode'.
|
-- | Arbitrary 'RejectCode'.
|
||||||
arbitraryRejectCode :: Gen RejectCode
|
arbitraryRejectCode :: Gen RejectCode
|
||||||
arbitraryRejectCode =
|
arbitraryRejectCode =
|
||||||
elements
|
elements
|
||||||
[ RejectMalformed
|
[ RejectMalformed,
|
||||||
, RejectInvalid
|
RejectInvalid,
|
||||||
, RejectInvalid
|
RejectInvalid,
|
||||||
, RejectDuplicate
|
RejectDuplicate,
|
||||||
, RejectNonStandard
|
RejectNonStandard,
|
||||||
, RejectDust
|
RejectDust,
|
||||||
, RejectInsufficientFee
|
RejectInsufficientFee,
|
||||||
, RejectCheckpoint
|
RejectCheckpoint
|
||||||
]
|
]
|
||||||
|
|
||||||
-- | Arbitrary non-empty 'GetData'.
|
-- | Arbitrary non-empty 'GetData'.
|
||||||
arbitraryGetData :: Gen GetData
|
arbitraryGetData :: Gen GetData
|
||||||
@ -128,28 +127,27 @@ arbitraryPong = Pong <$> arbitrary
|
|||||||
-- | Arbitrary bloom filter flags.
|
-- | Arbitrary bloom filter flags.
|
||||||
arbitraryBloomFlags :: Gen BloomFlags
|
arbitraryBloomFlags :: Gen BloomFlags
|
||||||
arbitraryBloomFlags =
|
arbitraryBloomFlags =
|
||||||
elements
|
elements
|
||||||
[ BloomUpdateNone
|
[ BloomUpdateNone,
|
||||||
, BloomUpdateAll
|
BloomUpdateAll,
|
||||||
, BloomUpdateP2PubKeyOnly
|
BloomUpdateP2PubKeyOnly
|
||||||
]
|
]
|
||||||
|
|
||||||
{- | Arbitrary bloom filter with its corresponding number of elements
|
-- | Arbitrary bloom filter with its corresponding number of elements
|
||||||
and false positive rate.
|
-- and false positive rate.
|
||||||
-}
|
|
||||||
arbitraryBloomFilter :: Gen (Int, Double, BloomFilter)
|
arbitraryBloomFilter :: Gen (Int, Double, BloomFilter)
|
||||||
arbitraryBloomFilter = do
|
arbitraryBloomFilter = do
|
||||||
n <- choose (0, 100000)
|
n <- choose (0, 100000)
|
||||||
fp <- choose (1e-8, 1)
|
fp <- choose (1e-8, 1)
|
||||||
tweak <- arbitrary
|
tweak <- arbitrary
|
||||||
fl <- arbitraryBloomFlags
|
fl <- arbitraryBloomFlags
|
||||||
return (n, fp, bloomCreate n fp tweak fl)
|
return (n, fp, bloomCreate n fp tweak fl)
|
||||||
|
|
||||||
-- | Arbitrary 'FilterLoad'.
|
-- | Arbitrary 'FilterLoad'.
|
||||||
arbitraryFilterLoad :: Gen FilterLoad
|
arbitraryFilterLoad :: Gen FilterLoad
|
||||||
arbitraryFilterLoad = do
|
arbitraryFilterLoad = do
|
||||||
(_, _, bf) <- arbitraryBloomFilter
|
(_, _, bf) <- arbitraryBloomFilter
|
||||||
return $ FilterLoad bf
|
return $ FilterLoad bf
|
||||||
|
|
||||||
-- | Arbitrary 'FilterAdd'.
|
-- | Arbitrary 'FilterAdd'.
|
||||||
arbitraryFilterAdd :: Gen FilterAdd
|
arbitraryFilterAdd :: Gen FilterAdd
|
||||||
@ -158,26 +156,26 @@ arbitraryFilterAdd = FilterAdd <$> arbitraryBS
|
|||||||
-- | Arbitrary 'MessageCommand'.
|
-- | Arbitrary 'MessageCommand'.
|
||||||
arbitraryMessageCommand :: Gen MessageCommand
|
arbitraryMessageCommand :: Gen MessageCommand
|
||||||
arbitraryMessageCommand = do
|
arbitraryMessageCommand = do
|
||||||
ASCIIString str <- arbitrary
|
ASCIIString str <- arbitrary
|
||||||
elements
|
elements
|
||||||
[ MCVersion
|
[ MCVersion,
|
||||||
, MCVerAck
|
MCVerAck,
|
||||||
, MCAddr
|
MCAddr,
|
||||||
, MCInv
|
MCInv,
|
||||||
, MCGetData
|
MCGetData,
|
||||||
, MCNotFound
|
MCNotFound,
|
||||||
, MCGetBlocks
|
MCGetBlocks,
|
||||||
, MCGetHeaders
|
MCGetHeaders,
|
||||||
, MCTx
|
MCTx,
|
||||||
, MCBlock
|
MCBlock,
|
||||||
, MCMerkleBlock
|
MCMerkleBlock,
|
||||||
, MCHeaders
|
MCHeaders,
|
||||||
, MCGetAddr
|
MCGetAddr,
|
||||||
, MCFilterLoad
|
MCFilterLoad,
|
||||||
, MCFilterAdd
|
MCFilterAdd,
|
||||||
, MCFilterClear
|
MCFilterClear,
|
||||||
, MCPing
|
MCPing,
|
||||||
, MCPong
|
MCPong,
|
||||||
, MCAlert
|
MCAlert,
|
||||||
, MCOther (C8.take 12 (C8.pack (filter (/= '\NUL') str)))
|
MCOther (C8.take 12 (C8.pack (filter (/= '\NUL') str)))
|
||||||
]
|
]
|
||||||
|
@ -1,23 +1,25 @@
|
|||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
|
|
||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Test.Script
|
-- Module : Haskoin.Test.Script
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
-}
|
|
||||||
module Haskoin.Util.Arbitrary.Script where
|
module Haskoin.Util.Arbitrary.Script where
|
||||||
|
|
||||||
import Crypto.Secp256k1
|
import Crypto.Secp256k1
|
||||||
import qualified Data.ByteString as B
|
import Data.ByteString qualified as B
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Word
|
import Data.Word
|
||||||
import Haskoin.Address
|
import Haskoin.Address
|
||||||
import Haskoin.Constants
|
import Haskoin.Crypto.Keys.Common
|
||||||
import Haskoin.Data
|
import Haskoin.Network.Constants
|
||||||
import Haskoin.Keys.Common
|
import Haskoin.Network.Data
|
||||||
import Haskoin.Script
|
import Haskoin.Script
|
||||||
import Haskoin.Transaction.Common
|
import Haskoin.Transaction.Common
|
||||||
import Haskoin.Util
|
import Haskoin.Util
|
||||||
@ -34,156 +36,156 @@ arbitraryScript = Script <$> listOf arbitraryScriptOp
|
|||||||
-- | Arbitrary 'ScriptOp' (push operations have random data).
|
-- | Arbitrary 'ScriptOp' (push operations have random data).
|
||||||
arbitraryScriptOp :: Gen ScriptOp
|
arbitraryScriptOp :: Gen ScriptOp
|
||||||
arbitraryScriptOp =
|
arbitraryScriptOp =
|
||||||
oneof
|
oneof
|
||||||
-- Pushing Data
|
-- Pushing Data
|
||||||
[ opPushData <$> arbitraryBS1
|
[ opPushData <$> arbitraryBS1,
|
||||||
, return OP_0
|
return OP_0,
|
||||||
, return OP_1NEGATE
|
return OP_1NEGATE,
|
||||||
, return OP_RESERVED
|
return OP_RESERVED,
|
||||||
, return OP_1
|
return OP_1,
|
||||||
, return OP_2
|
return OP_2,
|
||||||
, return OP_3
|
return OP_3,
|
||||||
, return OP_4
|
return OP_4,
|
||||||
, return OP_5
|
return OP_5,
|
||||||
, return OP_6
|
return OP_6,
|
||||||
, return OP_7
|
return OP_7,
|
||||||
, return OP_8
|
return OP_8,
|
||||||
, return OP_9
|
return OP_9,
|
||||||
, return OP_10
|
return OP_10,
|
||||||
, return OP_11
|
return OP_11,
|
||||||
, return OP_12
|
return OP_12,
|
||||||
, return OP_13
|
return OP_13,
|
||||||
, return OP_14
|
return OP_14,
|
||||||
, return OP_15
|
return OP_15,
|
||||||
, return OP_16
|
return OP_16,
|
||||||
, -- Flow control
|
-- Flow control
|
||||||
return OP_NOP
|
return OP_NOP,
|
||||||
, return OP_VER
|
return OP_VER,
|
||||||
, return OP_IF
|
return OP_IF,
|
||||||
, return OP_NOTIF
|
return OP_NOTIF,
|
||||||
, return OP_VERIF
|
return OP_VERIF,
|
||||||
, return OP_VERNOTIF
|
return OP_VERNOTIF,
|
||||||
, return OP_ELSE
|
return OP_ELSE,
|
||||||
, return OP_ENDIF
|
return OP_ENDIF,
|
||||||
, return OP_VERIFY
|
return OP_VERIFY,
|
||||||
, return OP_RETURN
|
return OP_RETURN,
|
||||||
, -- Stack operations
|
-- Stack operations
|
||||||
return OP_TOALTSTACK
|
return OP_TOALTSTACK,
|
||||||
, return OP_FROMALTSTACK
|
return OP_FROMALTSTACK,
|
||||||
, return OP_IFDUP
|
return OP_IFDUP,
|
||||||
, return OP_DEPTH
|
return OP_DEPTH,
|
||||||
, return OP_DROP
|
return OP_DROP,
|
||||||
, return OP_DUP
|
return OP_DUP,
|
||||||
, return OP_NIP
|
return OP_NIP,
|
||||||
, return OP_OVER
|
return OP_OVER,
|
||||||
, return OP_PICK
|
return OP_PICK,
|
||||||
, return OP_ROLL
|
return OP_ROLL,
|
||||||
, return OP_ROT
|
return OP_ROT,
|
||||||
, return OP_SWAP
|
return OP_SWAP,
|
||||||
, return OP_TUCK
|
return OP_TUCK,
|
||||||
, return OP_2DROP
|
return OP_2DROP,
|
||||||
, return OP_2DUP
|
return OP_2DUP,
|
||||||
, return OP_3DUP
|
return OP_3DUP,
|
||||||
, return OP_2OVER
|
return OP_2OVER,
|
||||||
, return OP_2ROT
|
return OP_2ROT,
|
||||||
, return OP_2SWAP
|
return OP_2SWAP,
|
||||||
, -- Splice
|
-- Splice
|
||||||
return OP_CAT
|
return OP_CAT,
|
||||||
, return OP_SUBSTR
|
return OP_SUBSTR,
|
||||||
, return OP_LEFT
|
return OP_LEFT,
|
||||||
, return OP_RIGHT
|
return OP_RIGHT,
|
||||||
, return OP_SIZE
|
return OP_SIZE,
|
||||||
, -- Bitwise logic
|
-- Bitwise logic
|
||||||
return OP_INVERT
|
return OP_INVERT,
|
||||||
, return OP_AND
|
return OP_AND,
|
||||||
, return OP_OR
|
return OP_OR,
|
||||||
, return OP_XOR
|
return OP_XOR,
|
||||||
, return OP_EQUAL
|
return OP_EQUAL,
|
||||||
, return OP_EQUALVERIFY
|
return OP_EQUALVERIFY,
|
||||||
, return OP_RESERVED1
|
return OP_RESERVED1,
|
||||||
, return OP_RESERVED2
|
return OP_RESERVED2,
|
||||||
, -- Arithmetic
|
-- Arithmetic
|
||||||
return OP_1ADD
|
return OP_1ADD,
|
||||||
, return OP_1SUB
|
return OP_1SUB,
|
||||||
, return OP_2MUL
|
return OP_2MUL,
|
||||||
, return OP_2DIV
|
return OP_2DIV,
|
||||||
, return OP_NEGATE
|
return OP_NEGATE,
|
||||||
, return OP_ABS
|
return OP_ABS,
|
||||||
, return OP_NOT
|
return OP_NOT,
|
||||||
, return OP_0NOTEQUAL
|
return OP_0NOTEQUAL,
|
||||||
, return OP_ADD
|
return OP_ADD,
|
||||||
, return OP_SUB
|
return OP_SUB,
|
||||||
, return OP_MUL
|
return OP_MUL,
|
||||||
, return OP_DIV
|
return OP_DIV,
|
||||||
, return OP_MOD
|
return OP_MOD,
|
||||||
, return OP_LSHIFT
|
return OP_LSHIFT,
|
||||||
, return OP_RSHIFT
|
return OP_RSHIFT,
|
||||||
, return OP_BOOLAND
|
return OP_BOOLAND,
|
||||||
, return OP_BOOLOR
|
return OP_BOOLOR,
|
||||||
, return OP_NUMEQUAL
|
return OP_NUMEQUAL,
|
||||||
, return OP_NUMEQUALVERIFY
|
return OP_NUMEQUALVERIFY,
|
||||||
, return OP_NUMNOTEQUAL
|
return OP_NUMNOTEQUAL,
|
||||||
, return OP_LESSTHAN
|
return OP_LESSTHAN,
|
||||||
, return OP_GREATERTHAN
|
return OP_GREATERTHAN,
|
||||||
, return OP_LESSTHANOREQUAL
|
return OP_LESSTHANOREQUAL,
|
||||||
, return OP_GREATERTHANOREQUAL
|
return OP_GREATERTHANOREQUAL,
|
||||||
, return OP_MIN
|
return OP_MIN,
|
||||||
, return OP_MAX
|
return OP_MAX,
|
||||||
, return OP_WITHIN
|
return OP_WITHIN,
|
||||||
, -- Crypto
|
-- Crypto
|
||||||
return OP_RIPEMD160
|
return OP_RIPEMD160,
|
||||||
, return OP_SHA1
|
return OP_SHA1,
|
||||||
, return OP_SHA256
|
return OP_SHA256,
|
||||||
, return OP_HASH160
|
return OP_HASH160,
|
||||||
, return OP_HASH256
|
return OP_HASH256,
|
||||||
, return OP_CODESEPARATOR
|
return OP_CODESEPARATOR,
|
||||||
, return OP_CHECKSIG
|
return OP_CHECKSIG,
|
||||||
, return OP_CHECKSIGVERIFY
|
return OP_CHECKSIGVERIFY,
|
||||||
, return OP_CHECKMULTISIG
|
return OP_CHECKMULTISIG,
|
||||||
, return OP_CHECKMULTISIGVERIFY
|
return OP_CHECKMULTISIGVERIFY,
|
||||||
, -- Expansion
|
-- Expansion
|
||||||
return OP_NOP1
|
return OP_NOP1,
|
||||||
, return OP_CHECKLOCKTIMEVERIFY
|
return OP_CHECKLOCKTIMEVERIFY,
|
||||||
, return OP_CHECKSEQUENCEVERIFY
|
return OP_CHECKSEQUENCEVERIFY,
|
||||||
, return OP_NOP4
|
return OP_NOP4,
|
||||||
, return OP_NOP5
|
return OP_NOP5,
|
||||||
, return OP_NOP6
|
return OP_NOP6,
|
||||||
, return OP_NOP7
|
return OP_NOP7,
|
||||||
, return OP_NOP8
|
return OP_NOP8,
|
||||||
, return OP_NOP9
|
return OP_NOP9,
|
||||||
, return OP_NOP10
|
return OP_NOP10,
|
||||||
, -- Bitcoin Cash Nov 2018 hard fork
|
-- Bitcoin Cash Nov 2018 hard fork
|
||||||
return OP_CHECKDATASIG
|
return OP_CHECKDATASIG,
|
||||||
, return OP_CHECKDATASIGVERIFY
|
return OP_CHECKDATASIGVERIFY,
|
||||||
, -- Bitcoin Cash May 2020 hard fork
|
-- Bitcoin Cash May 2020 hard fork
|
||||||
return OP_REVERSEBYTES
|
return OP_REVERSEBYTES,
|
||||||
, -- Other
|
-- Other
|
||||||
return OP_PUBKEYHASH
|
return OP_PUBKEYHASH,
|
||||||
, return OP_PUBKEY
|
return OP_PUBKEY,
|
||||||
, return $ OP_INVALIDOPCODE 0xff
|
return $ OP_INVALIDOPCODE 0xff
|
||||||
]
|
]
|
||||||
|
|
||||||
-- | Arbtirary 'ScriptOp' with a value in @[OP_1 .. OP_16]@.
|
-- | Arbtirary 'ScriptOp' with a value in @[OP_1 .. OP_16]@.
|
||||||
arbitraryIntScriptOp :: Gen ScriptOp
|
arbitraryIntScriptOp :: Gen ScriptOp
|
||||||
arbitraryIntScriptOp =
|
arbitraryIntScriptOp =
|
||||||
elements
|
elements
|
||||||
[ OP_1
|
[ OP_1,
|
||||||
, OP_2
|
OP_2,
|
||||||
, OP_3
|
OP_3,
|
||||||
, OP_4
|
OP_4,
|
||||||
, OP_5
|
OP_5,
|
||||||
, OP_6
|
OP_6,
|
||||||
, OP_7
|
OP_7,
|
||||||
, OP_8
|
OP_8,
|
||||||
, OP_9
|
OP_9,
|
||||||
, OP_10
|
OP_10,
|
||||||
, OP_11
|
OP_11,
|
||||||
, OP_12
|
OP_12,
|
||||||
, OP_13
|
OP_13,
|
||||||
, OP_14
|
OP_14,
|
||||||
, OP_15
|
OP_15,
|
||||||
, OP_16
|
OP_16
|
||||||
]
|
]
|
||||||
|
|
||||||
-- | Arbitrary 'PushDataType'.
|
-- | Arbitrary 'PushDataType'.
|
||||||
arbitraryPushDataType :: Gen PushDataType
|
arbitraryPushDataType :: Gen PushDataType
|
||||||
@ -196,88 +198,86 @@ arbitrarySigHash = fromIntegral <$> (arbitrary :: Gen Word32)
|
|||||||
-- | Arbitrary valid 'SigHash'.
|
-- | Arbitrary valid 'SigHash'.
|
||||||
arbitraryValidSigHash :: Network -> Gen SigHash
|
arbitraryValidSigHash :: Network -> Gen SigHash
|
||||||
arbitraryValidSigHash net = do
|
arbitraryValidSigHash net = do
|
||||||
sh <- elements [sigHashAll, sigHashNone, sigHashSingle]
|
sh <- elements [sigHashAll, sigHashNone, sigHashSingle]
|
||||||
f1 <-
|
f1 <-
|
||||||
elements $
|
elements $
|
||||||
if isJust (getSigHashForkId net)
|
if isJust net.sigHashForkId
|
||||||
then [id, setForkIdFlag]
|
then [id, setForkIdFlag]
|
||||||
else [id]
|
else [id]
|
||||||
f2 <- elements [id, setAnyoneCanPayFlag]
|
f2 <- elements [id, setAnyoneCanPay]
|
||||||
return $ f1 $ f2 sh
|
return $ f1 $ f2 sh
|
||||||
|
|
||||||
arbitrarySigHashFlag :: Gen SigHashFlag
|
arbitrarySigHashFlag :: Gen SigHashFlag
|
||||||
arbitrarySigHashFlag =
|
arbitrarySigHashFlag =
|
||||||
elements
|
elements
|
||||||
[ SIGHASH_ALL
|
[ SIGHASH_ALL,
|
||||||
, SIGHASH_NONE
|
SIGHASH_NONE,
|
||||||
, SIGHASH_SINGLE
|
SIGHASH_SINGLE,
|
||||||
, SIGHASH_FORKID
|
SIGHASH_FORKID,
|
||||||
, SIGHASH_ANYONECANPAY
|
SIGHASH_ANYONECANPAY
|
||||||
]
|
]
|
||||||
|
|
||||||
{- | Arbitrary message hash, private key and corresponding 'TxSignature'. The
|
-- | Arbitrary message hash, private key and corresponding 'TxSignature'. The
|
||||||
signature is generated deterministically using a random message and a random
|
-- signature is generated deterministically using a random message and a random
|
||||||
private key.
|
-- private key.
|
||||||
-}
|
arbitraryTxSignature :: Network -> Ctx -> Gen (TxHash, SecKey, TxSignature)
|
||||||
arbitraryTxSignature :: Network -> Gen (TxHash, SecKey, TxSignature)
|
arbitraryTxSignature net ctx = do
|
||||||
arbitraryTxSignature net = do
|
(m, key, sig) <- arbitrarySignature ctx
|
||||||
(m, key, sig) <- arbitrarySignature
|
sh <- (fromIntegral <$> (arbitrary :: Gen Word8)) `suchThat` filterBad
|
||||||
sh <- (fromIntegral <$> (arbitrary :: Gen Word8)) `suchThat` filterBad
|
let txsig = TxSignature sig sh
|
||||||
let txsig = TxSignature sig sh
|
return (TxHash m, key, txsig)
|
||||||
return (TxHash m, key, txsig)
|
|
||||||
where
|
where
|
||||||
filterBad sh =
|
filterBad sh =
|
||||||
not $
|
not $
|
||||||
isSigHashUnknown sh
|
isSigHashUnknown sh
|
||||||
|| isNothing (getSigHashForkId net) && hasForkIdFlag sh
|
|| isNothing net.sigHashForkId && hasForkIdFlag sh
|
||||||
|
|
||||||
-- | Arbitrary transaction signature that could also be empty.
|
-- | Arbitrary transaction signature that could also be empty.
|
||||||
arbitraryTxSignatureEmpty :: Network -> Gen TxSignature
|
arbitraryTxSignatureEmpty :: Network -> Ctx -> Gen TxSignature
|
||||||
arbitraryTxSignatureEmpty net =
|
arbitraryTxSignatureEmpty net ctx =
|
||||||
frequency
|
frequency
|
||||||
[ (1, return TxSignatureEmpty)
|
[ (1, return TxSignatureEmpty),
|
||||||
, (10, lst3 <$> arbitraryTxSignature net)
|
(10, lst3 <$> arbitraryTxSignature net ctx)
|
||||||
]
|
]
|
||||||
|
|
||||||
-- | Arbitrary m of n parameters.
|
-- | Arbitrary m of n parameters.
|
||||||
arbitraryMSParam :: Gen (Int, Int)
|
arbitraryMSParam :: Gen (Int, Int)
|
||||||
arbitraryMSParam = do
|
arbitraryMSParam = do
|
||||||
m <- choose (1, 16)
|
m <- choose (1, 16)
|
||||||
n <- choose (m, 16)
|
n <- choose (m, 16)
|
||||||
return (m, n)
|
return (m, n)
|
||||||
|
|
||||||
-- | Arbitrary 'ScriptOutput' (Can by any valid type).
|
-- | Arbitrary 'ScriptOutput' (Can by any valid type).
|
||||||
arbitraryScriptOutput :: Network -> Gen ScriptOutput
|
arbitraryScriptOutput :: Network -> Ctx -> Gen ScriptOutput
|
||||||
arbitraryScriptOutput net =
|
arbitraryScriptOutput net ctx =
|
||||||
oneof $
|
oneof $
|
||||||
[ arbitraryPKOutput
|
[ arbitraryPKOutput ctx,
|
||||||
, arbitraryPKHashOutput
|
arbitraryPKHashOutput,
|
||||||
, arbitraryMSOutput
|
arbitraryMSOutput ctx,
|
||||||
, arbitrarySHOutput
|
arbitrarySHOutput,
|
||||||
, arbitraryDCOutput
|
arbitraryDCOutput
|
||||||
]
|
]
|
||||||
++ if getSegWit net
|
++ if net.segWit
|
||||||
then
|
then
|
||||||
[ arbitraryWPKHashOutput
|
[ arbitraryWPKHashOutput,
|
||||||
, arbitraryWSHOutput
|
arbitraryWSHOutput,
|
||||||
, arbitraryWitOutput
|
arbitraryWitOutput
|
||||||
]
|
]
|
||||||
else []
|
else []
|
||||||
|
|
||||||
{- | Arbitrary 'ScriptOutput' of type 'PayPK', 'PayPKHash' or 'PayMS'
|
-- | Arbitrary 'ScriptOutput' of type 'PayPK', 'PayPKHash' or 'PayMS'
|
||||||
(Not 'PayScriptHash', 'DataCarrier', or SegWit)
|
-- (Not 'PayScriptHash', 'DataCarrier', or SegWit)
|
||||||
-}
|
arbitrarySimpleOutput :: Ctx -> Gen ScriptOutput
|
||||||
arbitrarySimpleOutput :: Gen ScriptOutput
|
arbitrarySimpleOutput ctx =
|
||||||
arbitrarySimpleOutput =
|
oneof
|
||||||
oneof
|
[ arbitraryPKOutput ctx,
|
||||||
[ arbitraryPKOutput
|
arbitraryPKHashOutput,
|
||||||
, arbitraryPKHashOutput
|
arbitraryMSOutput ctx
|
||||||
, arbitraryMSOutput
|
]
|
||||||
]
|
|
||||||
|
|
||||||
-- | Arbitrary 'ScriptOutput' of type 'PayPK'
|
-- | Arbitrary 'ScriptOutput' of type 'PayPK'
|
||||||
arbitraryPKOutput :: Gen ScriptOutput
|
arbitraryPKOutput :: Ctx -> Gen ScriptOutput
|
||||||
arbitraryPKOutput = PayPK . snd <$> arbitraryKeyPair
|
arbitraryPKOutput ctx = PayPK . snd <$> arbitraryKeyPair ctx
|
||||||
|
|
||||||
-- | Arbitrary 'ScriptOutput' of type 'PayPKHash'
|
-- | Arbitrary 'ScriptOutput' of type 'PayPKHash'
|
||||||
arbitraryPKHashOutput :: Gen ScriptOutput
|
arbitraryPKHashOutput :: Gen ScriptOutput
|
||||||
@ -293,131 +293,128 @@ arbitraryWSHOutput = PayWitnessScriptHash <$> arbitraryHash256
|
|||||||
|
|
||||||
arbitraryWitOutput :: Gen ScriptOutput
|
arbitraryWitOutput :: Gen ScriptOutput
|
||||||
arbitraryWitOutput = do
|
arbitraryWitOutput = do
|
||||||
ver <- choose (1, 16)
|
ver <- choose (1, 16)
|
||||||
len <- choose (2, 40)
|
len <- choose (2, 40)
|
||||||
ws <- vectorOf len arbitrary
|
ws <- vectorOf len arbitrary
|
||||||
let bs = B.pack ws
|
let bs = B.pack ws
|
||||||
return $ PayWitness ver bs
|
return $ PayWitness ver bs
|
||||||
|
|
||||||
-- | Arbitrary 'ScriptOutput' of type 'PayMS'.
|
-- | Arbitrary 'ScriptOutput' of type 'PayMS'.
|
||||||
arbitraryMSOutput :: Gen ScriptOutput
|
arbitraryMSOutput :: Ctx -> Gen ScriptOutput
|
||||||
arbitraryMSOutput = do
|
arbitraryMSOutput ctx = do
|
||||||
(m, n) <- arbitraryMSParam
|
(m, n) <- arbitraryMSParam
|
||||||
keys <- map snd <$> vectorOf n arbitraryKeyPair
|
keys <- map snd <$> vectorOf n (arbitraryKeyPair ctx)
|
||||||
return $ PayMulSig keys m
|
return $ PayMulSig keys m
|
||||||
|
|
||||||
-- | Arbitrary 'ScriptOutput' of type 'PayMS', only using compressed keys.
|
-- | Arbitrary 'ScriptOutput' of type 'PayMS', only using compressed keys.
|
||||||
arbitraryMSOutputC :: Gen ScriptOutput
|
arbitraryMSOutputC :: Ctx -> Gen ScriptOutput
|
||||||
arbitraryMSOutputC = do
|
arbitraryMSOutputC ctx = do
|
||||||
(m, n) <- arbitraryMSParam
|
(m, n) <- arbitraryMSParam
|
||||||
keys <-
|
keys <-
|
||||||
map snd
|
map snd
|
||||||
<$> vectorOf n (arbitraryKeyPair `suchThat` (pubKeyCompressed . snd))
|
<$> vectorOf n (arbitraryKeyPair ctx `suchThat` ((.compress) . snd))
|
||||||
return $ PayMulSig keys m
|
return $ PayMulSig keys m
|
||||||
|
|
||||||
-- | Arbitrary 'ScriptOutput' of type 'PayScriptHash'.
|
-- | Arbitrary 'ScriptOutput' of type 'PayScriptHash'.
|
||||||
arbitrarySHOutput :: Gen ScriptOutput
|
arbitrarySHOutput :: Gen ScriptOutput
|
||||||
arbitrarySHOutput = PayScriptHash . getAddrHash160 <$> arbitraryScriptAddress
|
arbitrarySHOutput = PayScriptHash . (.hash160) <$> arbitraryScriptAddress
|
||||||
|
|
||||||
-- | Arbitrary 'ScriptOutput' of type 'DataCarrier'.
|
-- | Arbitrary 'ScriptOutput' of type 'DataCarrier'.
|
||||||
arbitraryDCOutput :: Gen ScriptOutput
|
arbitraryDCOutput :: Gen ScriptOutput
|
||||||
arbitraryDCOutput = DataCarrier <$> arbitraryBS1
|
arbitraryDCOutput = DataCarrier <$> arbitraryBS1
|
||||||
|
|
||||||
-- | Arbitrary 'ScriptInput'.
|
-- | Arbitrary 'ScriptInput'.
|
||||||
arbitraryScriptInput :: Network -> Gen ScriptInput
|
arbitraryScriptInput :: Network -> Ctx -> Gen ScriptInput
|
||||||
arbitraryScriptInput net =
|
arbitraryScriptInput net ctx =
|
||||||
oneof
|
oneof
|
||||||
[ arbitraryPKInput net
|
[ arbitraryPKInput net ctx,
|
||||||
, arbitraryPKHashInput net
|
arbitraryPKHashInput net ctx,
|
||||||
, arbitraryMSInput net
|
arbitraryMSInput net ctx,
|
||||||
, arbitrarySHInput net
|
arbitrarySHInput net ctx
|
||||||
]
|
]
|
||||||
|
|
||||||
{- | Arbitrary 'ScriptInput' of type 'SpendPK', 'SpendPKHash' or 'SpendMulSig'
|
-- | Arbitrary 'ScriptInput' of type 'SpendPK', 'SpendPKHash' or 'SpendMulSig'
|
||||||
(not 'ScriptHashInput')
|
-- (not 'ScriptHashInput')
|
||||||
-}
|
arbitrarySimpleInput :: Network -> Ctx -> Gen ScriptInput
|
||||||
arbitrarySimpleInput :: Network -> Gen ScriptInput
|
arbitrarySimpleInput net ctx =
|
||||||
arbitrarySimpleInput net =
|
oneof
|
||||||
oneof
|
[ arbitraryPKInput net ctx,
|
||||||
[ arbitraryPKInput net
|
arbitraryPKHashInput net ctx,
|
||||||
, arbitraryPKHashInput net
|
arbitraryMSInput net ctx
|
||||||
, arbitraryMSInput net
|
]
|
||||||
]
|
|
||||||
|
|
||||||
-- | Arbitrary 'ScriptInput' of type 'SpendPK'.
|
-- | Arbitrary 'ScriptInput' of type 'SpendPK'.
|
||||||
arbitraryPKInput :: Network -> Gen ScriptInput
|
arbitraryPKInput :: Network -> Ctx -> Gen ScriptInput
|
||||||
arbitraryPKInput net = RegularInput . SpendPK <$> arbitraryTxSignatureEmpty net
|
arbitraryPKInput net ctx = RegularInput . SpendPK <$> arbitraryTxSignatureEmpty net ctx
|
||||||
|
|
||||||
-- | Arbitrary 'ScriptInput' of type 'SpendPK'.
|
-- | Arbitrary 'ScriptInput' of type 'SpendPK'.
|
||||||
arbitraryPKHashInput :: Network -> Gen ScriptInput
|
arbitraryPKHashInput :: Network -> Ctx -> Gen ScriptInput
|
||||||
arbitraryPKHashInput net = do
|
arbitraryPKHashInput net ctx = do
|
||||||
sig <- arbitraryTxSignatureEmpty net
|
sig <- arbitraryTxSignatureEmpty net ctx
|
||||||
key <- snd <$> arbitraryKeyPair
|
key <- snd <$> arbitraryKeyPair ctx
|
||||||
return $ RegularInput $ SpendPKHash sig key
|
return $ RegularInput $ SpendPKHash sig key
|
||||||
|
|
||||||
-- | Like 'arbitraryPKHashInput' without empty signatures.
|
-- | Like 'arbitraryPKHashInput' without empty signatures.
|
||||||
arbitraryPKHashInputFull :: Network -> Gen ScriptInput
|
arbitraryPKHashInputFull :: Network -> Ctx -> Gen ScriptInput
|
||||||
arbitraryPKHashInputFull net = do
|
arbitraryPKHashInputFull net ctx = do
|
||||||
sig <- lst3 <$> arbitraryTxSignature net
|
sig <- lst3 <$> arbitraryTxSignature net ctx
|
||||||
key <- snd <$> arbitraryKeyPair
|
key <- snd <$> arbitraryKeyPair ctx
|
||||||
return $ RegularInput $ SpendPKHash sig key
|
return $ RegularInput $ SpendPKHash sig key
|
||||||
|
|
||||||
-- | Like above but only compressed.
|
-- | Like above but only compressed.
|
||||||
arbitraryPKHashInputFullC :: Network -> Gen ScriptInput
|
arbitraryPKHashInputFullC :: Network -> Ctx -> Gen ScriptInput
|
||||||
arbitraryPKHashInputFullC net = do
|
arbitraryPKHashInputFullC net ctx = do
|
||||||
sig <- lst3 <$> arbitraryTxSignature net
|
sig <- lst3 <$> arbitraryTxSignature net ctx
|
||||||
key <- fmap snd $ arbitraryKeyPair `suchThat` (pubKeyCompressed . snd)
|
key <- fmap snd $ arbitraryKeyPair ctx `suchThat` ((.compress) . snd)
|
||||||
return $ RegularInput $ SpendPKHash sig key
|
return $ RegularInput $ SpendPKHash sig key
|
||||||
|
|
||||||
-- | Arbitrary 'ScriptInput' of type 'SpendMulSig'.
|
-- | Arbitrary 'ScriptInput' of type 'SpendMulSig'.
|
||||||
arbitraryMSInput :: Network -> Gen ScriptInput
|
arbitraryMSInput :: Network -> Ctx -> Gen ScriptInput
|
||||||
arbitraryMSInput net = do
|
arbitraryMSInput net ctx = do
|
||||||
m <- fst <$> arbitraryMSParam
|
m <- fst <$> arbitraryMSParam
|
||||||
sigs <- vectorOf m (arbitraryTxSignatureEmpty net)
|
sigs <- vectorOf m (arbitraryTxSignatureEmpty net ctx)
|
||||||
return $ RegularInput $ SpendMulSig sigs
|
return $ RegularInput $ SpendMulSig sigs
|
||||||
|
|
||||||
-- | Arbitrary 'ScriptInput' of type 'ScriptHashInput'.
|
-- | Arbitrary 'ScriptInput' of type 'ScriptHashInput'.
|
||||||
arbitrarySHInput :: Network -> Gen ScriptInput
|
arbitrarySHInput :: Network -> Ctx -> Gen ScriptInput
|
||||||
arbitrarySHInput net = do
|
arbitrarySHInput net ctx = do
|
||||||
i <- arbitrarySimpleInput net
|
i <- arbitrarySimpleInput net ctx
|
||||||
ScriptHashInput (getRegularInput i) <$> arbitrarySimpleOutput
|
ScriptHashInput i.get <$> arbitrarySimpleOutput ctx
|
||||||
|
|
||||||
{- | Arbitrary 'ScriptInput' of type 'ScriptHashInput' containing a
|
-- | Arbitrary 'ScriptInput' of type 'ScriptHashInput' containing a
|
||||||
'RedeemScript' of type 'PayMulSig' and an input of type 'SpendMulSig'.
|
-- 'RedeemScript' of type 'PayMulSig' and an input of type 'SpendMulSig'.
|
||||||
-}
|
arbitraryMulSigSHInput :: Network -> Ctx -> Gen ScriptInput
|
||||||
arbitraryMulSigSHInput :: Network -> Gen ScriptInput
|
arbitraryMulSigSHInput net ctx =
|
||||||
arbitraryMulSigSHInput net =
|
arbitraryMSOutput ctx >>= \case
|
||||||
arbitraryMSOutput >>= \case
|
rdm@(PayMulSig _ m) -> do
|
||||||
rdm@(PayMulSig _ m) -> do
|
sigs <- vectorOf m (arbitraryTxSignatureEmpty net ctx)
|
||||||
sigs <- vectorOf m (arbitraryTxSignatureEmpty net)
|
return $ ScriptHashInput (SpendMulSig sigs) rdm
|
||||||
return $ ScriptHashInput (SpendMulSig sigs) rdm
|
_ -> undefined
|
||||||
_ -> undefined
|
|
||||||
|
|
||||||
{- | Arbitrary 'ScriptInput' of type 'ScriptHashInput' containing a
|
-- | Arbitrary 'ScriptInput' of type 'ScriptHashInput' containing a
|
||||||
'RedeemScript' of type 'PayMulSig' and an input of type 'SpendMulSig'.
|
-- 'RedeemScript' of type 'PayMulSig' and an input of type 'SpendMulSig'.
|
||||||
-}
|
arbitraryMulSigSHInputC :: Network -> Ctx -> Gen ScriptInput
|
||||||
arbitraryMulSigSHInputC :: Network -> Gen ScriptInput
|
arbitraryMulSigSHInputC net ctx =
|
||||||
arbitraryMulSigSHInputC net =
|
arbitraryMSOutputC ctx >>= \case
|
||||||
arbitraryMSOutputC >>= \case
|
rdm@(PayMulSig _ m) -> do
|
||||||
rdm@(PayMulSig _ m) -> do
|
sigs <- vectorOf m (arbitraryTxSignatureEmpty net ctx)
|
||||||
sigs <- vectorOf m (arbitraryTxSignatureEmpty net)
|
return $ ScriptHashInput (SpendMulSig sigs) rdm
|
||||||
return $ ScriptHashInput (SpendMulSig sigs) rdm
|
_ -> undefined
|
||||||
_ -> undefined
|
|
||||||
|
|
||||||
-- | Like 'arbitraryMulSigSHCInput' with no empty signatures.
|
-- | Like 'arbitraryMulSigSHCInput' with no empty signatures.
|
||||||
arbitraryMulSigSHInputFull :: Network -> Gen ScriptInput
|
arbitraryMulSigSHInputFull :: Network -> Ctx -> Gen ScriptInput
|
||||||
arbitraryMulSigSHInputFull net =
|
arbitraryMulSigSHInputFull net ctx =
|
||||||
arbitraryMSOutput >>= \case
|
arbitraryMSOutput ctx >>= \case
|
||||||
rdm@(PayMulSig _ m) -> do
|
rdm@(PayMulSig _ m) -> do
|
||||||
sigs <- map lst3 <$> vectorOf m (arbitraryTxSignature net)
|
sigs <- map lst3 <$> vectorOf m (arbitraryTxSignature net ctx)
|
||||||
return $ ScriptHashInput (SpendMulSig sigs) rdm
|
return $ ScriptHashInput (SpendMulSig sigs) rdm
|
||||||
_ -> undefined
|
_ -> undefined
|
||||||
|
|
||||||
-- | Like 'arbitraryMulSigSHCInput' with no empty signatures.
|
-- | Like 'arbitraryMulSigSHCInput' with no empty signatures.
|
||||||
arbitraryMulSigSHInputFullC :: Network -> Gen ScriptInput
|
arbitraryMulSigSHInputFullC :: Network -> Ctx -> Gen ScriptInput
|
||||||
arbitraryMulSigSHInputFullC net =
|
arbitraryMulSigSHInputFullC net ctx =
|
||||||
arbitraryMSOutputC >>= \case
|
arbitraryMSOutputC ctx >>= \case
|
||||||
rdm@(PayMulSig _ m) -> do
|
rdm@(PayMulSig _ m) -> do
|
||||||
sigs <- map lst3 <$> vectorOf m (arbitraryTxSignature net)
|
sigs <- map lst3 <$> vectorOf m (arbitraryTxSignature net ctx)
|
||||||
return $ ScriptHashInput (SpendMulSig sigs) rdm
|
return $ ScriptHashInput (SpendMulSig sigs) rdm
|
||||||
_ -> undefined
|
_ -> undefined
|
||||||
|
@ -1,24 +1,29 @@
|
|||||||
{- |
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
Module : Haskoin.Test.Transaction
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
Copyright : No rights reserved
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
License : MIT
|
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- |
|
||||||
Stability : experimental
|
-- Module : Haskoin.Test.Transaction
|
||||||
Portability : POSIX
|
-- Copyright : No rights reserved
|
||||||
-}
|
-- License : MIT
|
||||||
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
|
-- Stability : experimental
|
||||||
|
-- Portability : POSIX
|
||||||
module Haskoin.Util.Arbitrary.Transaction where
|
module Haskoin.Util.Arbitrary.Transaction where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import qualified Data.ByteString as BS
|
import Data.ByteString qualified as BS
|
||||||
import Data.Either (fromRight)
|
import Data.Either (fromRight)
|
||||||
import Data.List (nub, nubBy, permutations)
|
import Data.List (nub, nubBy, permutations)
|
||||||
import Data.Word (Word64)
|
import Data.Word (Word64)
|
||||||
import Haskoin.Address
|
import Haskoin.Address
|
||||||
import Haskoin.Constants
|
import Haskoin.Crypto (Ctx)
|
||||||
import Haskoin.Data
|
import Haskoin.Crypto.Keys.Common
|
||||||
import Haskoin.Keys.Common
|
import Haskoin.Network.Constants
|
||||||
|
import Haskoin.Network.Data
|
||||||
import Haskoin.Script
|
import Haskoin.Script
|
||||||
import Haskoin.Transaction
|
import Haskoin.Transaction
|
||||||
|
import Haskoin.Util
|
||||||
import Haskoin.Util.Arbitrary.Crypto
|
import Haskoin.Util.Arbitrary.Crypto
|
||||||
import Haskoin.Util.Arbitrary.Keys
|
import Haskoin.Util.Arbitrary.Keys
|
||||||
import Haskoin.Util.Arbitrary.Script
|
import Haskoin.Util.Arbitrary.Script
|
||||||
@ -27,10 +32,10 @@ import Test.QuickCheck
|
|||||||
|
|
||||||
-- | Wrapped coin value for testing.
|
-- | Wrapped coin value for testing.
|
||||||
newtype TestCoin = TestCoin {getTestCoin :: Word64}
|
newtype TestCoin = TestCoin {getTestCoin :: Word64}
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
instance Coin TestCoin where
|
instance Coin TestCoin where
|
||||||
coinValue = getTestCoin
|
coinValue = getTestCoin
|
||||||
|
|
||||||
-- | Arbitrary transaction hash (for non-existent transaction).
|
-- | Arbitrary transaction hash (for non-existent transaction).
|
||||||
arbitraryTxHash :: Gen TxHash
|
arbitraryTxHash :: Gen TxHash
|
||||||
@ -38,244 +43,241 @@ arbitraryTxHash = TxHash <$> arbitraryHash256
|
|||||||
|
|
||||||
-- | Arbitrary amount of Satoshi as 'Word64' (Between 1 and 21e14)
|
-- | Arbitrary amount of Satoshi as 'Word64' (Between 1 and 21e14)
|
||||||
arbitrarySatoshi :: Network -> Gen TestCoin
|
arbitrarySatoshi :: Network -> Gen TestCoin
|
||||||
arbitrarySatoshi net = TestCoin <$> choose (1, getMaxSatoshi net)
|
arbitrarySatoshi net = TestCoin <$> choose (1, net.maxSatoshi)
|
||||||
|
|
||||||
-- | Arbitrary 'OutPoint'.
|
-- | Arbitrary 'OutPoint'.
|
||||||
arbitraryOutPoint :: Gen OutPoint
|
arbitraryOutPoint :: Gen OutPoint
|
||||||
arbitraryOutPoint = OutPoint <$> arbitraryTxHash <*> arbitrary
|
arbitraryOutPoint = OutPoint <$> arbitraryTxHash <*> arbitrary
|
||||||
|
|
||||||
-- | Arbitrary 'TxOut'.
|
-- | Arbitrary 'TxOut'.
|
||||||
arbitraryTxOut :: Network -> Gen TxOut
|
arbitraryTxOut :: Network -> Ctx -> Gen TxOut
|
||||||
arbitraryTxOut net =
|
arbitraryTxOut net ctx =
|
||||||
TxOut <$> (getTestCoin <$> arbitrarySatoshi net)
|
TxOut
|
||||||
<*> (encodeOutputBS <$> arbitraryScriptOutput net)
|
<$> (getTestCoin <$> arbitrarySatoshi net)
|
||||||
|
<*> (marshal ctx <$> arbitraryScriptOutput net ctx)
|
||||||
|
|
||||||
-- | Arbitrary 'TxIn'.
|
-- | Arbitrary 'TxIn'.
|
||||||
arbitraryTxIn :: Network -> Gen TxIn
|
arbitraryTxIn :: Network -> Ctx -> Gen TxIn
|
||||||
arbitraryTxIn net =
|
arbitraryTxIn net ctx =
|
||||||
TxIn <$> arbitraryOutPoint
|
TxIn
|
||||||
<*> (encodeInputBS <$> arbitraryScriptInput net)
|
<$> arbitraryOutPoint
|
||||||
<*> arbitrary
|
<*> (marshal (net, ctx) <$> arbitraryScriptInput net ctx)
|
||||||
|
<*> arbitrary
|
||||||
|
|
||||||
-- | Arbitrary transaction. Can be regular or with witnesses.
|
-- | Arbitrary transaction. Can be regular or with witnesses.
|
||||||
arbitraryTx :: Network -> Gen Tx
|
arbitraryTx :: Network -> Ctx -> Gen Tx
|
||||||
arbitraryTx net = oneof [arbitraryLegacyTx net, arbitraryWitnessTx net]
|
arbitraryTx net ctx =
|
||||||
|
oneof [arbitraryLegacyTx net ctx, arbitraryWitnessTx net ctx]
|
||||||
|
|
||||||
-- | Arbitrary regular transaction.
|
-- | Arbitrary regular transaction.
|
||||||
arbitraryLegacyTx :: Network -> Gen Tx
|
arbitraryLegacyTx :: Network -> Ctx -> Gen Tx
|
||||||
arbitraryLegacyTx net = arbitraryWLTx net False
|
arbitraryLegacyTx net ctx = arbitraryWLTx net ctx False
|
||||||
|
|
||||||
-- | Arbitrary witness transaction (witness data is fake).
|
-- | Arbitrary witness transaction (witness data is fake).
|
||||||
arbitraryWitnessTx :: Network -> Gen Tx
|
arbitraryWitnessTx :: Network -> Ctx -> Gen Tx
|
||||||
arbitraryWitnessTx net = arbitraryWLTx net True
|
arbitraryWitnessTx net ctx = arbitraryWLTx net ctx True
|
||||||
|
|
||||||
-- | Arbitrary witness or legacy transaction.
|
-- | Arbitrary witness or legacy transaction.
|
||||||
arbitraryWLTx :: Network -> Bool -> Gen Tx
|
arbitraryWLTx :: Network -> Ctx -> Bool -> Gen Tx
|
||||||
arbitraryWLTx net wit = do
|
arbitraryWLTx net ctx wit = do
|
||||||
ni <- choose (1, 5)
|
ni <- choose (1, 5)
|
||||||
no <- choose (1, 5)
|
no <- choose (1, 5)
|
||||||
inps <- vectorOf ni (arbitraryTxIn net)
|
inps <- vectorOf ni (arbitraryTxIn net ctx)
|
||||||
outs <- vectorOf no (arbitraryTxOut net)
|
outs <- vectorOf no (arbitraryTxOut net ctx)
|
||||||
let uniqueInps = nubBy (\a b -> prevOutput a == prevOutput b) inps
|
let uniqueInps = nubBy (\a b -> a.outpoint == b.outpoint) inps
|
||||||
w <-
|
w <-
|
||||||
if wit
|
if wit
|
||||||
then vectorOf (length uniqueInps) (listOf arbitraryBS)
|
then vectorOf (length uniqueInps) (listOf arbitraryBS)
|
||||||
else return []
|
else return []
|
||||||
Tx <$> arbitrary <*> pure uniqueInps <*> pure outs <*> pure w <*> arbitrary
|
Tx <$> arbitrary <*> pure uniqueInps <*> pure outs <*> pure w <*> arbitrary
|
||||||
|
|
||||||
{- | Arbitrary transaction containing only inputs of type 'SpendPKHash',
|
-- | Arbitrary transaction containing only inputs of type 'SpendPKHash',
|
||||||
'SpendScriptHash' (multisig) and outputs of type 'PayPKHash' and 'PaySH'.
|
-- 'SpendScriptHash' (multisig) and outputs of type 'PayPKHash' and 'PaySH'.
|
||||||
Only compressed public keys are used.
|
-- Only compressed public keys are used.
|
||||||
-}
|
arbitraryAddrOnlyTx :: Network -> Ctx -> Gen Tx
|
||||||
arbitraryAddrOnlyTx :: Network -> Gen Tx
|
arbitraryAddrOnlyTx net ctx = do
|
||||||
arbitraryAddrOnlyTx net = do
|
ni <- choose (1, 5)
|
||||||
ni <- choose (1, 5)
|
no <- choose (1, 5)
|
||||||
no <- choose (1, 5)
|
inps <- vectorOf ni (arbitraryAddrOnlyTxIn net ctx)
|
||||||
inps <- vectorOf ni (arbitraryAddrOnlyTxIn net)
|
outs <- vectorOf no (arbitraryAddrOnlyTxOut net ctx)
|
||||||
outs <- vectorOf no (arbitraryAddrOnlyTxOut net)
|
Tx <$> arbitrary <*> pure inps <*> pure outs <*> pure [] <*> arbitrary
|
||||||
Tx <$> arbitrary <*> pure inps <*> pure outs <*> pure [] <*> arbitrary
|
|
||||||
|
|
||||||
-- | Like 'arbitraryAddrOnlyTx' without empty signatures in the inputs.
|
-- | Like 'arbitraryAddrOnlyTx' without empty signatures in the inputs.
|
||||||
arbitraryAddrOnlyTxFull :: Network -> Gen Tx
|
arbitraryAddrOnlyTxFull :: Network -> Ctx -> Gen Tx
|
||||||
arbitraryAddrOnlyTxFull net = do
|
arbitraryAddrOnlyTxFull net ctx = do
|
||||||
ni <- choose (1, 5)
|
ni <- choose (1, 5)
|
||||||
no <- choose (1, 5)
|
no <- choose (1, 5)
|
||||||
inps <- vectorOf ni (arbitraryAddrOnlyTxInFull net)
|
inps <- vectorOf ni (arbitraryAddrOnlyTxInFull net ctx)
|
||||||
outs <- vectorOf no (arbitraryAddrOnlyTxOut net)
|
outs <- vectorOf no (arbitraryAddrOnlyTxOut net ctx)
|
||||||
Tx <$> arbitrary <*> pure inps <*> pure outs <*> pure [] <*> arbitrary
|
Tx <$> arbitrary <*> pure inps <*> pure outs <*> pure [] <*> arbitrary
|
||||||
|
|
||||||
{- | Arbitrary TxIn that can only be of type 'SpendPKHash' or 'SpendScriptHash'
|
-- | Arbitrary TxIn that can only be of type 'SpendPKHash' or 'SpendScriptHash'
|
||||||
(multisig). Only compressed public keys are used.
|
-- (multisig). Only compressed public keys are used.
|
||||||
-}
|
arbitraryAddrOnlyTxIn :: Network -> Ctx -> Gen TxIn
|
||||||
arbitraryAddrOnlyTxIn :: Network -> Gen TxIn
|
arbitraryAddrOnlyTxIn net ctx = do
|
||||||
arbitraryAddrOnlyTxIn net = do
|
inp <- oneof [arbitraryPKHashInput net ctx, arbitraryMulSigSHInput net ctx]
|
||||||
inp <- oneof [arbitraryPKHashInput net, arbitraryMulSigSHInput net]
|
TxIn <$> arbitraryOutPoint <*> pure (marshal (net, ctx) inp) <*> arbitrary
|
||||||
TxIn <$> arbitraryOutPoint <*> pure (encodeInputBS inp) <*> arbitrary
|
|
||||||
|
|
||||||
-- | like 'arbitraryAddrOnlyTxIn' with no empty signatures.
|
-- | like 'arbitraryAddrOnlyTxIn' with no empty signatures.
|
||||||
arbitraryAddrOnlyTxInFull :: Network -> Gen TxIn
|
arbitraryAddrOnlyTxInFull :: Network -> Ctx -> Gen TxIn
|
||||||
arbitraryAddrOnlyTxInFull net = do
|
arbitraryAddrOnlyTxInFull net ctx = do
|
||||||
inp <-
|
inp <-
|
||||||
oneof [arbitraryPKHashInputFullC net, arbitraryMulSigSHInputFullC net]
|
oneof [arbitraryPKHashInputFullC net ctx, arbitraryMulSigSHInputFullC net ctx]
|
||||||
TxIn <$> arbitraryOutPoint <*> pure (encodeInputBS inp) <*> arbitrary
|
TxIn <$> arbitraryOutPoint <*> pure (marshal (net, ctx) inp) <*> arbitrary
|
||||||
|
|
||||||
-- | Arbitrary 'TxOut' that can only be of type 'PayPKHash' or 'PaySH'.
|
-- | Arbitrary 'TxOut' that can only be of type 'PayPKHash' or 'PaySH'.
|
||||||
arbitraryAddrOnlyTxOut :: Network -> Gen TxOut
|
arbitraryAddrOnlyTxOut :: Network -> Ctx -> Gen TxOut
|
||||||
arbitraryAddrOnlyTxOut net = do
|
arbitraryAddrOnlyTxOut net ctx = do
|
||||||
v <- getTestCoin <$> arbitrarySatoshi net
|
v <- getTestCoin <$> arbitrarySatoshi net
|
||||||
out <- oneof [arbitraryPKHashOutput, arbitrarySHOutput]
|
out <- oneof [arbitraryPKHashOutput, arbitrarySHOutput]
|
||||||
return $ TxOut v $ encodeOutputBS out
|
return $ TxOut v $ marshal ctx out
|
||||||
|
|
||||||
{- | Arbitrary 'SigInput' with the corresponding private keys used
|
-- | Arbitrary 'SigInput' with the corresponding private keys used
|
||||||
to generate the 'ScriptOutput' or 'RedeemScript'.
|
-- to generate the 'ScriptOutput' or 'RedeemScript'.
|
||||||
-}
|
arbitrarySigInput :: Network -> Ctx -> Gen (SigInput, [PrivateKey])
|
||||||
arbitrarySigInput :: Network -> Gen (SigInput, [SecKeyI])
|
arbitrarySigInput net ctx =
|
||||||
arbitrarySigInput net =
|
oneof
|
||||||
oneof
|
[ wrapKey <$> arbitraryPKSigInput net ctx,
|
||||||
[ wrapKey <$> arbitraryPKSigInput net
|
wrapKey <$> arbitraryPKHashSigInput net ctx,
|
||||||
, wrapKey <$> arbitraryPKHashSigInput net
|
arbitraryMSSigInput net ctx,
|
||||||
, arbitraryMSSigInput net
|
arbitrarySHSigInput net ctx,
|
||||||
, arbitrarySHSigInput net
|
wrapKey <$> arbitraryWPKHSigInput net ctx,
|
||||||
, wrapKey <$> arbitraryWPKHSigInput net
|
arbitraryWSHSigInput net ctx
|
||||||
, arbitraryWSHSigInput net
|
]
|
||||||
]
|
|
||||||
|
|
||||||
-- | Arbitrary 'SigInput' with a 'ScriptOutput' of type 'PayPK'.
|
-- | Arbitrary 'SigInput' with a 'ScriptOutput' of type 'PayPK'.
|
||||||
arbitraryPKSigInput :: Network -> Gen (SigInput, SecKeyI)
|
arbitraryPKSigInput :: Network -> Ctx -> Gen (SigInput, PrivateKey)
|
||||||
arbitraryPKSigInput net = arbitraryAnyInput net False
|
arbitraryPKSigInput net ctx = arbitraryAnyInput net ctx False
|
||||||
|
|
||||||
-- | Arbitrary 'SigInput' with a 'ScriptOutput' of type 'PayPKHash'.
|
-- | Arbitrary 'SigInput' with a 'ScriptOutput' of type 'PayPKHash'.
|
||||||
arbitraryPKHashSigInput :: Network -> Gen (SigInput, SecKeyI)
|
arbitraryPKHashSigInput :: Network -> Ctx -> Gen (SigInput, PrivateKey)
|
||||||
arbitraryPKHashSigInput net = arbitraryAnyInput net True
|
arbitraryPKHashSigInput net ctx = arbitraryAnyInput net ctx True
|
||||||
|
|
||||||
-- | Arbitrary 'SigInput'.
|
-- | Arbitrary 'SigInput'.
|
||||||
arbitraryAnyInput :: Network -> Bool -> Gen (SigInput, SecKeyI)
|
arbitraryAnyInput :: Network -> Ctx -> Bool -> Gen (SigInput, PrivateKey)
|
||||||
arbitraryAnyInput net pkh = do
|
arbitraryAnyInput net ctx pkh = do
|
||||||
(k, p) <- arbitraryKeyPair
|
(k, p) <- arbitraryKeyPair ctx
|
||||||
let out
|
let out
|
||||||
| pkh = PayPKHash $ getAddrHash160 $ pubKeyAddr p
|
| pkh = PayPKHash (pubKeyAddr ctx p).hash160
|
||||||
| otherwise = PayPK p
|
| otherwise = PayPK p
|
||||||
(val, op, sh) <- arbitraryInputStuff net
|
(val, op, sh) <- arbitraryInputStuff net
|
||||||
return (SigInput out val op sh Nothing, k)
|
return (SigInput out val op sh Nothing, k)
|
||||||
|
|
||||||
-- | Arbitrary value, out point and sighash for an input.
|
-- | Arbitrary value, out point and sighash for an input.
|
||||||
arbitraryInputStuff :: Network -> Gen (Word64, OutPoint, SigHash)
|
arbitraryInputStuff :: Network -> Gen (Word64, OutPoint, SigHash)
|
||||||
arbitraryInputStuff net = do
|
arbitraryInputStuff net = do
|
||||||
val <- getTestCoin <$> arbitrarySatoshi net
|
val <- getTestCoin <$> arbitrarySatoshi net
|
||||||
op <- arbitraryOutPoint
|
op <- arbitraryOutPoint
|
||||||
sh <- arbitraryValidSigHash net
|
sh <- arbitraryValidSigHash net
|
||||||
return (val, op, sh)
|
return (val, op, sh)
|
||||||
|
|
||||||
-- | Arbitrary 'SigInput' with a 'ScriptOutput' of type 'PayMulSig'.
|
-- | Arbitrary 'SigInput' with a 'ScriptOutput' of type 'PayMulSig'.
|
||||||
arbitraryMSSigInput :: Network -> Gen (SigInput, [SecKeyI])
|
arbitraryMSSigInput :: Network -> Ctx -> Gen (SigInput, [PrivateKey])
|
||||||
arbitraryMSSigInput net = do
|
arbitraryMSSigInput net ctx = do
|
||||||
(m, n) <- arbitraryMSParam
|
(m, n) <- arbitraryMSParam
|
||||||
ks <- vectorOf n arbitraryKeyPair
|
ks <- vectorOf n (arbitraryKeyPair ctx)
|
||||||
let out = PayMulSig (map snd ks) m
|
let out = PayMulSig (map snd ks) m
|
||||||
(val, op, sh) <- arbitraryInputStuff net
|
(val, op, sh) <- arbitraryInputStuff net
|
||||||
perm <- choose (0, n - 1)
|
perm <- choose (0, n - 1)
|
||||||
let ksPerm = map fst $ take m $ permutations ks !! perm
|
let ksPerm = map fst $ take m $ permutations ks !! perm
|
||||||
return (SigInput out val op sh Nothing, ksPerm)
|
return (SigInput out val op sh Nothing, ksPerm)
|
||||||
|
|
||||||
{- | Arbitrary 'SigInput' with 'ScriptOutput' of type 'PaySH' and a
|
-- | Arbitrary 'SigInput' with 'ScriptOutput' of type 'PaySH' and a
|
||||||
'RedeemScript'.
|
-- 'RedeemScript'.
|
||||||
-}
|
arbitrarySHSigInput :: Network -> Ctx -> Gen (SigInput, [PrivateKey])
|
||||||
arbitrarySHSigInput :: Network -> Gen (SigInput, [SecKeyI])
|
arbitrarySHSigInput net ctx = do
|
||||||
arbitrarySHSigInput net = do
|
(SigInput rdm val op sh _, ks) <-
|
||||||
(SigInput rdm val op sh _, ks) <-
|
oneof
|
||||||
oneof
|
[ wrapKey <$> arbitraryPKSigInput net ctx,
|
||||||
[ wrapKey <$> arbitraryPKSigInput net
|
wrapKey <$> arbitraryPKHashSigInput net ctx,
|
||||||
, wrapKey <$> arbitraryPKHashSigInput net
|
arbitraryMSSigInput net ctx
|
||||||
, arbitraryMSSigInput net
|
]
|
||||||
]
|
let out = PayScriptHash (payToScriptAddress ctx rdm).hash160
|
||||||
let out = PayScriptHash $ getAddrHash160 $ payToScriptAddress rdm
|
return (SigInput out val op sh $ Just rdm, ks)
|
||||||
return (SigInput out val op sh $ Just rdm, ks)
|
|
||||||
|
|
||||||
arbitraryWPKHSigInput :: Network -> Gen (SigInput, SecKeyI)
|
arbitraryWPKHSigInput :: Network -> Ctx -> Gen (SigInput, PrivateKey)
|
||||||
arbitraryWPKHSigInput net = do
|
arbitraryWPKHSigInput net ctx = do
|
||||||
(k, p) <- arbitraryKeyPair
|
(k, p) <- arbitraryKeyPair ctx
|
||||||
(val, op, sh) <- arbitraryInputStuff net
|
(val, op, sh) <- arbitraryInputStuff net
|
||||||
let out = PayWitnessPKHash . getAddrHash160 $ pubKeyAddr p
|
let out = PayWitnessPKHash (pubKeyAddr ctx p).hash160
|
||||||
return (SigInput out val op sh Nothing, k)
|
return (SigInput out val op sh Nothing, k)
|
||||||
|
|
||||||
arbitraryWSHSigInput :: Network -> Gen (SigInput, [SecKeyI])
|
arbitraryWSHSigInput :: Network -> Ctx -> Gen (SigInput, [PrivateKey])
|
||||||
arbitraryWSHSigInput net = do
|
arbitraryWSHSigInput net ctx = do
|
||||||
(SigInput rdm val op sh _, ks) <-
|
(SigInput rdm val op sh _, ks) <-
|
||||||
oneof
|
oneof
|
||||||
[ wrapKey <$> arbitraryPKSigInput net
|
[ wrapKey <$> arbitraryPKSigInput net ctx,
|
||||||
, wrapKey <$> arbitraryPKHashSigInput net
|
wrapKey <$> arbitraryPKHashSigInput net ctx,
|
||||||
, arbitraryMSSigInput net
|
arbitraryMSSigInput net ctx
|
||||||
]
|
]
|
||||||
let out = PayWitnessScriptHash . getAddrHash256 $ payToWitnessScriptAddress rdm
|
let out = PayWitnessScriptHash (payToWitnessScriptAddress ctx rdm).hash256
|
||||||
return (SigInput out val op sh $ Just rdm, ks)
|
return (SigInput out val op sh $ Just rdm, ks)
|
||||||
|
|
||||||
{- | Arbitrary 'Tx' (empty 'TxIn'), 'SigInputs' and private keys that can be
|
-- | Arbitrary 'Tx' (empty 'TxIn'), 'SigInputs' and private keys that can be
|
||||||
passed to 'signTx' or 'detSignTx' to fully sign the 'Tx'.
|
-- passed to 'signTx' or 'detSignTx' to fully sign the 'Tx'.
|
||||||
-}
|
arbitrarySigningData :: Network -> Ctx -> Gen (Tx, [SigInput], [PrivateKey])
|
||||||
arbitrarySigningData :: Network -> Gen (Tx, [SigInput], [SecKeyI])
|
arbitrarySigningData net ctx = do
|
||||||
arbitrarySigningData net = do
|
v <- arbitrary
|
||||||
v <- arbitrary
|
ni <- choose (1, 5)
|
||||||
ni <- choose (1, 5)
|
no <- choose (1, 5)
|
||||||
no <- choose (1, 5)
|
sigis <- vectorOf ni (arbitrarySigInput net ctx)
|
||||||
sigis <- vectorOf ni (arbitrarySigInput net)
|
let uSigis = nubBy (\(a, _) (b, _) -> a.outpoint == b.outpoint) sigis
|
||||||
let uSigis = nubBy (\(a, _) (b, _) -> sigInputOP a == sigInputOP b) sigis
|
inps <- forM uSigis $ \(s, _) -> TxIn s.outpoint BS.empty <$> arbitrary
|
||||||
inps <- forM uSigis $ \(s, _) -> TxIn (sigInputOP s) BS.empty <$> arbitrary
|
outs <- vectorOf no (arbitraryTxOut net ctx)
|
||||||
outs <- vectorOf no (arbitraryTxOut net)
|
l <- arbitrary
|
||||||
l <- arbitrary
|
perm <- choose (0, length inps - 1)
|
||||||
perm <- choose (0, length inps - 1)
|
let tx = Tx v (permutations inps !! perm) outs [] l
|
||||||
let tx = Tx v (permutations inps !! perm) outs [] l
|
keys = concatMap snd uSigis
|
||||||
keys = concatMap snd uSigis
|
return (tx, map fst uSigis, keys)
|
||||||
return (tx, map fst uSigis, keys)
|
|
||||||
|
|
||||||
-- | Arbitrary transaction with empty inputs.
|
-- | Arbitrary transaction with empty inputs.
|
||||||
arbitraryEmptyTx :: Network -> Gen Tx
|
arbitraryEmptyTx :: Network -> Ctx -> Gen Tx
|
||||||
arbitraryEmptyTx net = do
|
arbitraryEmptyTx net ctx = do
|
||||||
v <- arbitrary
|
v <- arbitrary
|
||||||
no <- choose (1, 5)
|
no <- choose (1, 5)
|
||||||
ni <- choose (1, 5)
|
ni <- choose (1, 5)
|
||||||
outs <- vectorOf no (arbitraryTxOut net)
|
outs <- vectorOf no (arbitraryTxOut net ctx)
|
||||||
ops <- vectorOf ni arbitraryOutPoint
|
ops <- vectorOf ni arbitraryOutPoint
|
||||||
t <- arbitrary
|
t <- arbitrary
|
||||||
s <- arbitrary
|
s <- arbitrary
|
||||||
return $ Tx v (map (\op -> TxIn op BS.empty s) (nub ops)) outs [] t
|
return $ Tx v (map (\op -> TxIn op BS.empty s) (nub ops)) outs [] t
|
||||||
|
|
||||||
-- | Arbitrary partially-signed transactions.
|
-- | Arbitrary partially-signed transactions.
|
||||||
arbitraryPartialTxs ::
|
arbitraryPartialTxs ::
|
||||||
Network -> Gen ([Tx], [(ScriptOutput, Word64, OutPoint, Int, Int)])
|
Network -> Ctx -> Gen ([Tx], [(ScriptOutput, Word64, OutPoint, Int, Int)])
|
||||||
arbitraryPartialTxs net = do
|
arbitraryPartialTxs net ctx = do
|
||||||
tx <- arbitraryEmptyTx net
|
tx <- arbitraryEmptyTx net ctx
|
||||||
res <-
|
res <-
|
||||||
forM (map prevOutput $ txIn tx) $ \op -> do
|
forM (map (.outpoint) tx.inputs) $ \op -> do
|
||||||
(so, val, rdmM, prvs, m, n) <- arbitraryData
|
(so, val, rdmM, prvs, m, n) <- arbitraryData
|
||||||
txs <- mapM (singleSig so val rdmM tx op . secKeyData) prvs
|
txs <- mapM (singleSig so val rdmM tx op . (.key)) prvs
|
||||||
return (txs, (so, val, op, m, n))
|
return (txs, (so, val, op, m, n))
|
||||||
return (concatMap fst res, map snd res)
|
return (concatMap fst res, map snd res)
|
||||||
where
|
where
|
||||||
singleSig so val rdmM tx op prv = do
|
singleSig so val rdmM tx op prv = do
|
||||||
sh <- arbitraryValidSigHash net
|
sh <- arbitraryValidSigHash net
|
||||||
let sigi = SigInput so val op sh rdmM
|
let sigi = SigInput so val op sh rdmM
|
||||||
return . fromRight (error "Could not decode transaction") $
|
return . fromRight (error "Could not decode transaction") $
|
||||||
signTx net tx [sigi] [prv]
|
signTx net ctx tx [sigi] [prv]
|
||||||
arbitraryData = do
|
arbitraryData = do
|
||||||
(m, n) <- arbitraryMSParam
|
(m, n) <- arbitraryMSParam
|
||||||
val <- getTestCoin <$> arbitrarySatoshi net
|
val <- getTestCoin <$> arbitrarySatoshi net
|
||||||
nPrv <- choose (m, n)
|
nPrv <- choose (m, n)
|
||||||
keys <- vectorOf n arbitraryKeyPair
|
keys <- vectorOf n (arbitraryKeyPair ctx)
|
||||||
perm <- choose (0, length keys - 1)
|
perm <- choose (0, length keys - 1)
|
||||||
let pubKeys = map snd keys
|
let pubKeys = map snd keys
|
||||||
prvKeys = take nPrv $ permutations (map fst keys) !! perm
|
prvKeys = take nPrv $ permutations (map fst keys) !! perm
|
||||||
let so = PayMulSig pubKeys m
|
let so = PayMulSig pubKeys m
|
||||||
elements
|
elements
|
||||||
[ (so, val, Nothing, prvKeys, m, n)
|
[ (so, val, Nothing, prvKeys, m, n),
|
||||||
,
|
( PayScriptHash (payToScriptAddress ctx so).hash160,
|
||||||
( PayScriptHash $ getAddrHash160 $ payToScriptAddress so
|
val,
|
||||||
, val
|
Just so,
|
||||||
, Just so
|
prvKeys,
|
||||||
, prvKeys
|
m,
|
||||||
, m
|
n
|
||||||
, n
|
)
|
||||||
)
|
]
|
||||||
]
|
|
||||||
|
|
||||||
wrapKey :: (SigInput, SecKeyI) -> (SigInput, [SecKeyI])
|
wrapKey :: (SigInput, PrivateKey) -> (SigInput, [PrivateKey])
|
||||||
wrapKey (s, k) = (s, [k])
|
wrapKey (s, k) = (s, [k])
|
||||||
|
@ -1,16 +1,15 @@
|
|||||||
{-# LANGUAGE ExistentialQuantification #-}
|
{-# LANGUAGE ExistentialQuantification #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
{- |
|
-- |
|
||||||
Module : Haskoin.Test.Util
|
-- Module : Haskoin.Test.Util
|
||||||
Copyright : No rights reserved
|
-- Copyright : No rights reserved
|
||||||
License : MIT
|
-- License : MIT
|
||||||
Maintainer : jprupp@protonmail.ch
|
-- Maintainer : jprupp@protonmail.ch
|
||||||
Stability : experimental
|
-- Stability : experimental
|
||||||
Portability : POSIX
|
-- Portability : POSIX
|
||||||
-}
|
module Haskoin.Util.Arbitrary.Util
|
||||||
module Haskoin.Util.Arbitrary.Util (
|
( arbitraryBS,
|
||||||
arbitraryBS,
|
|
||||||
arbitraryBS1,
|
arbitraryBS1,
|
||||||
arbitraryBSn,
|
arbitraryBSn,
|
||||||
arbitraryBSS,
|
arbitraryBSS,
|
||||||
@ -30,15 +29,16 @@ module Haskoin.Util.Arbitrary.Util (
|
|||||||
testNetJson,
|
testNetJson,
|
||||||
arbitraryNetData,
|
arbitraryNetData,
|
||||||
genNetData,
|
genNetData,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Monad (forM_, (<=<))
|
import Control.Monad (forM_, (<=<))
|
||||||
import qualified Data.Aeson as A
|
import qualified Data.Aeson as A
|
||||||
import qualified Data.Aeson.Encoding as A
|
import qualified Data.Aeson.Encoding as A
|
||||||
import qualified Data.Aeson.Types as A
|
import qualified Data.Aeson.Types as A
|
||||||
import Data.ByteString (ByteString, pack)
|
import Data.ByteString (ByteString, pack)
|
||||||
import qualified Data.ByteString.Short as BSS
|
|
||||||
import Data.ByteString.Lazy (fromStrict, toStrict)
|
import Data.ByteString.Lazy (fromStrict, toStrict)
|
||||||
|
import qualified Data.ByteString.Short as BSS
|
||||||
import Data.Bytes.Get
|
import Data.Bytes.Get
|
||||||
import Data.Bytes.Put
|
import Data.Bytes.Put
|
||||||
import Data.Bytes.Serial
|
import Data.Bytes.Serial
|
||||||
@ -48,8 +48,8 @@ import Data.Time.Clock (UTCTime (..))
|
|||||||
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
|
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
|
||||||
import qualified Data.Typeable as T
|
import qualified Data.Typeable as T
|
||||||
import Data.Word (Word32)
|
import Data.Word (Word32)
|
||||||
import Haskoin.Constants
|
import Haskoin.Network.Constants
|
||||||
import Haskoin.Data
|
import Haskoin.Network.Data
|
||||||
import Test.Hspec (Spec, describe, shouldBe, shouldSatisfy)
|
import Test.Hspec (Spec, describe, shouldBe, shouldSatisfy)
|
||||||
import Test.Hspec.QuickCheck (prop)
|
import Test.Hspec.QuickCheck (prop)
|
||||||
import Test.QuickCheck
|
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
|
-- | Arbitrary UTCTime that generates dates after 01 Jan 1970 01:00:00 CET
|
||||||
arbitraryUTCTime :: Gen UTCTime
|
arbitraryUTCTime :: Gen UTCTime
|
||||||
arbitraryUTCTime = do
|
arbitraryUTCTime = do
|
||||||
w <- arbitrary :: Gen Word32
|
w <- arbitrary :: Gen Word32
|
||||||
return $ posixSecondsToUTCTime $ realToFrac w
|
return $ posixSecondsToUTCTime $ realToFrac w
|
||||||
|
|
||||||
-- | Generate a Maybe from a Gen a
|
-- | Generate a Maybe from a Gen a
|
||||||
arbitraryMaybe :: Gen a -> Gen (Maybe a)
|
arbitraryMaybe :: Gen a -> Gen (Maybe a)
|
||||||
arbitraryMaybe g =
|
arbitraryMaybe g =
|
||||||
frequency
|
frequency
|
||||||
[ (1, return Nothing)
|
[ (1, return Nothing),
|
||||||
, (5, Just <$> g)
|
(5, Just <$> g)
|
||||||
]
|
]
|
||||||
|
|
||||||
-- | Generate an Network
|
-- | Generate an Network
|
||||||
arbitraryNetwork :: Gen Network
|
arbitraryNetwork :: Gen Network
|
||||||
@ -99,51 +99,55 @@ arbitraryNetwork = elements allNets
|
|||||||
-- Helpers for creating Serial and JSON Identity tests
|
-- Helpers for creating Serial and JSON Identity tests
|
||||||
|
|
||||||
data SerialBox
|
data SerialBox
|
||||||
= forall a.
|
= forall a.
|
||||||
(Show a, Eq a, T.Typeable a, Serial a) =>
|
(Show a, Eq a, T.Typeable a, Serial a) =>
|
||||||
SerialBox (Gen a)
|
SerialBox (Gen a)
|
||||||
|
|
||||||
data ReadBox
|
data ReadBox
|
||||||
= forall a.
|
= forall a.
|
||||||
(Read a, Show a, Eq a, T.Typeable a) =>
|
(Read a, Show a, Eq a, T.Typeable a) =>
|
||||||
ReadBox (Gen a)
|
ReadBox (Gen a)
|
||||||
|
|
||||||
data JsonBox
|
data JsonBox
|
||||||
= forall a.
|
= forall a.
|
||||||
(Show a, Eq a, T.Typeable a, A.ToJSON a, A.FromJSON a) =>
|
(Show a, Eq a, T.Typeable a, A.ToJSON a, A.FromJSON a) =>
|
||||||
JsonBox (Gen a)
|
JsonBox (Gen a)
|
||||||
|
|
||||||
data NetBox
|
data NetBox
|
||||||
= forall a.
|
= forall a.
|
||||||
(Show a, Eq a, T.Typeable a) =>
|
(Show a, Eq a, T.Typeable a) =>
|
||||||
NetBox
|
NetBox
|
||||||
( Network -> a -> A.Value
|
( Network -> a -> A.Value,
|
||||||
, Network -> a -> A.Encoding
|
Network -> a -> A.Encoding,
|
||||||
, Network -> A.Value -> A.Parser a
|
Network -> A.Value -> A.Parser a,
|
||||||
, Gen (Network, a)
|
Gen (Network, a)
|
||||||
)
|
)
|
||||||
|
|
||||||
testIdentity :: [SerialBox] -> [ReadBox] -> [JsonBox] -> [NetBox] -> Spec
|
testIdentity :: [SerialBox] -> [ReadBox] -> [JsonBox] -> [NetBox] -> Spec
|
||||||
testIdentity serialVals readVals jsonVals netVals = do
|
testIdentity serialVals readVals jsonVals netVals = do
|
||||||
describe "Binary Encoding" $
|
describe "Binary Encoding" $
|
||||||
forM_ serialVals $ \(SerialBox g) -> testSerial g
|
forM_ serialVals $
|
||||||
describe "Read/Show Encoding" $
|
\(SerialBox g) -> testSerial g
|
||||||
forM_ readVals $ \(ReadBox g) -> testRead g
|
describe "Read/Show Encoding" $
|
||||||
describe "Data.Aeson Encoding" $
|
forM_ readVals $
|
||||||
forM_ jsonVals $ \(JsonBox g) -> testJson g
|
\(ReadBox g) -> testRead g
|
||||||
describe "Data.Aeson Encoding with Network" $
|
describe "Data.Aeson Encoding" $
|
||||||
forM_ netVals $ \(NetBox (j, e, p, g)) -> testNetJson j e p g
|
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
|
-- | Generate binary identity tests
|
||||||
testSerial ::
|
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 =
|
testSerial gen =
|
||||||
prop ("Binary encoding/decoding identity for " <> name) $
|
prop ("Binary encoding/decoding identity for " <> name) $
|
||||||
forAll gen $ \x -> do
|
forAll gen $ \x -> do
|
||||||
(runGetL deserialize . runPutL . serialize) x `shouldBe` x
|
(runGetL deserialize . runPutL . serialize) x `shouldBe` x
|
||||||
(runGetL deserialize . fromStrict . runPutS . serialize) x `shouldBe` x
|
(runGetL deserialize . fromStrict . runPutS . serialize) x `shouldBe` x
|
||||||
(runGetS deserialize . runPutS . serialize) x `shouldBe` Right x
|
(runGetS deserialize . runPutS . serialize) x `shouldBe` Right x
|
||||||
(runGetS deserialize . toStrict . runPutL . serialize) x `shouldBe` Right x
|
(runGetS deserialize . toStrict . runPutL . serialize) x `shouldBe` Right x
|
||||||
where
|
where
|
||||||
name = show $ T.typeRep $ proxy gen
|
name = show $ T.typeRep $ proxy gen
|
||||||
proxy :: Gen a -> Proxy a
|
proxy :: Gen a -> Proxy a
|
||||||
@ -151,10 +155,11 @@ testSerial gen =
|
|||||||
|
|
||||||
-- | Generate Read/Show identity tests
|
-- | Generate Read/Show identity tests
|
||||||
testRead ::
|
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 =
|
testRead gen =
|
||||||
prop ("read/show identity for " <> name) $
|
prop ("read/show identity for " <> name) $
|
||||||
forAll gen $ \x -> (read . show) x `shouldBe` x
|
forAll gen $
|
||||||
|
\x -> (read . show) x `shouldBe` x
|
||||||
where
|
where
|
||||||
name = show $ T.typeRep $ proxy gen
|
name = show $ T.typeRep $ proxy gen
|
||||||
proxy :: Gen a -> Proxy a
|
proxy :: Gen a -> Proxy a
|
||||||
@ -162,34 +167,36 @@ testRead gen =
|
|||||||
|
|
||||||
-- | Generate Data.Aeson identity tests
|
-- | Generate Data.Aeson identity tests
|
||||||
testJson ::
|
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
|
testJson gen = do
|
||||||
prop ("Data.Aeson toJSON/fromJSON identity for " <> name) $
|
prop ("Data.Aeson toJSON/fromJSON identity for " <> name) $
|
||||||
forAll gen (`shouldSatisfy` jsonID)
|
forAll gen (`shouldSatisfy` jsonID)
|
||||||
prop ("Data.Aeson toEncoding/fromJSON identity for " <> name) $
|
prop ("Data.Aeson toEncoding/fromJSON identity for " <> name) $
|
||||||
forAll gen (`shouldSatisfy` encodingID)
|
forAll gen (`shouldSatisfy` encodingID)
|
||||||
where
|
where
|
||||||
name = show $ T.typeRep $ proxy gen
|
name = show $ T.typeRep $ proxy gen
|
||||||
proxy :: Gen a -> Proxy a
|
proxy :: Gen a -> Proxy a
|
||||||
proxy = const Proxy
|
proxy = const Proxy
|
||||||
jsonID x = (A.fromJSON . A.toJSON) (toMap x) == A.Success (toMap x)
|
jsonID x = (A.fromJSON . A.toJSON) (toMap x) == A.Success (toMap x)
|
||||||
encodingID x =
|
encodingID x =
|
||||||
(A.decode . A.encodingToLazyByteString . A.toEncoding) (toMap x)
|
(A.decode . A.encodingToLazyByteString . A.toEncoding) (toMap x)
|
||||||
== Just (toMap x)
|
== Just (toMap x)
|
||||||
|
|
||||||
-- | Generate Data.Aeson identity tests for type that need the @Network@
|
-- | Generate Data.Aeson identity tests for type that need the @Network@
|
||||||
testNetJson ::
|
testNetJson ::
|
||||||
(Eq a, Show a, T.Typeable a) =>
|
(Eq a, Show a, T.Typeable a) =>
|
||||||
(Network -> a -> A.Value) ->
|
(Network -> a -> A.Value) ->
|
||||||
(Network -> a -> A.Encoding) ->
|
(Network -> a -> A.Encoding) ->
|
||||||
(Network -> A.Value -> A.Parser a) ->
|
(Network -> A.Value -> A.Parser a) ->
|
||||||
Gen (Network, a) ->
|
Gen (Network, a) ->
|
||||||
Spec
|
Spec
|
||||||
testNetJson j e p g = do
|
testNetJson j e p g = do
|
||||||
prop ("Data.Aeson toJSON/fromJSON identity (with network) for " <> name) $
|
prop ("Data.Aeson toJSON/fromJSON identity (with network) for " <> name) $
|
||||||
forAll g $ \(net, x) -> dec net (encVal net x) `shouldBe` Just x
|
forAll g $
|
||||||
prop ("Data.Aeson toEncoding/fromJSON identity (with network) for " <> name) $
|
\(net, x) -> dec net (encVal net x) `shouldBe` Just x
|
||||||
forAll g $ \(net, x) -> dec net (encEnc 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
|
where
|
||||||
encVal net = A.encode . toMap . j net
|
encVal net = A.encode . toMap . j net
|
||||||
encEnc net = A.encodingToLazyByteString . toMapE . e 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 :: (Network -> a -> A.Value) -> Proxy a
|
||||||
proxy = const Proxy
|
proxy = const Proxy
|
||||||
|
|
||||||
arbitraryNetData :: Arbitrary a => Gen (Network, a)
|
arbitraryNetData :: (Arbitrary a) => Gen (Network, a)
|
||||||
arbitraryNetData = do
|
arbitraryNetData = do
|
||||||
net <- arbitraryNetwork
|
net <- arbitraryNetwork
|
||||||
x <- arbitrary
|
x <- arbitrary
|
||||||
return (net, x)
|
return (net, x)
|
||||||
|
|
||||||
genNetData :: Gen a -> Gen (Network, a)
|
genNetData :: Gen a -> Gen (Network, a)
|
||||||
genNetData gen = do
|
genNetData gen = do
|
||||||
net <- arbitraryNetwork
|
net <- arbitraryNetwork
|
||||||
x <- gen
|
x <- gen
|
||||||
return (net, x)
|
return (net, x)
|
||||||
|
|
||||||
toMap :: a -> Map.Map String a
|
toMap :: a -> Map.Map String a
|
||||||
toMap = Map.singleton "object"
|
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:
|
nix:
|
||||||
packages:
|
packages:
|
||||||
- secp256k1
|
- secp256k1
|
||||||
- pkg-config
|
- pkg-config
|
||||||
extra-deps:
|
extra-deps:
|
||||||
- base16-1.0@sha256:9b72a280a7af75a5026fa25a1b8ae18ec10200a070947723f1fd61dc8d407862,2472
|
- 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:
|
original:
|
||||||
hackage: base16-1.0@sha256:9b72a280a7af75a5026fa25a1b8ae18ec10200a070947723f1fd61dc8d407862,2472
|
hackage: base16-1.0@sha256:9b72a280a7af75a5026fa25a1b8ae18ec10200a070947723f1fd61dc8d407862,2472
|
||||||
- completed:
|
- completed:
|
||||||
hackage: secp256k1-haskell-0.7.0@sha256:1585601c67d7c62c698402ffe8462de216a499608521a8136d0aa15f0a03a23f,2140
|
hackage: secp256k1-haskell-1.0.0@sha256:42e1dc0ddba74b752bddf7d55c19aa10b24ff6f51889a53bc07c2ff2107aca16,2082
|
||||||
pantry-tree:
|
pantry-tree:
|
||||||
sha256: a7726275193ac4ef14c9d97378222d3ca494524c48354edf69214513def7d48d
|
sha256: 7846a02f6292cb0179cdf7252b3832f74b3109079e45248c931791f951355702
|
||||||
size: 599
|
size: 600
|
||||||
original:
|
original:
|
||||||
hackage: secp256k1-haskell-0.7.0@sha256:1585601c67d7c62c698402ffe8462de216a499608521a8136d0aa15f0a03a23f,2140
|
hackage: secp256k1-haskell-1.0.0@sha256:42e1dc0ddba74b752bddf7d55c19aa10b24ff6f51889a53bc07c2ff2107aca16,2082
|
||||||
snapshots:
|
snapshots:
|
||||||
- completed:
|
- completed:
|
||||||
sha256: 1867d84255dff8c87373f5dd03e5a5cb1c10a99587e26c8793e750c54e83ffdc
|
sha256: caa77fdbc5b9f698262b21ee78030133272ec53116ad6ddbefdc4c321f668e0c
|
||||||
size: 639139
|
size: 640014
|
||||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/0.yaml
|
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/4.yaml
|
||||||
original: lts-21.0
|
original: lts-21.4
|
||||||
|
@ -1,18 +1,17 @@
|
|||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Haskoin.Address.Bech32Spec (
|
module Haskoin.Address.Bech32Spec (spec) where
|
||||||
spec,
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Data.Bits (xor)
|
import Data.Bits (xor)
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
import qualified Data.ByteString as B
|
import Data.ByteString qualified as ByteString
|
||||||
import Data.Char (chr, ord, toLower)
|
import Data.Char (chr, ord, toLower)
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.String.Conversions
|
import Data.String.Conversions
|
||||||
import Data.Text (Text, append, pack, snoc, uncons)
|
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 Data.Word (Word8)
|
||||||
import Haskoin.Address
|
import Haskoin.Address
|
||||||
import Haskoin.Address.Bech32
|
import Haskoin.Address.Bech32
|
||||||
@ -21,238 +20,225 @@ import Test.HUnit
|
|||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
|
|
||||||
spec = do
|
spec = do
|
||||||
describe "bech32 checksum" $ do
|
describe "bech32 checksum" $ do
|
||||||
it "should be valid" $
|
it "should be valid" $
|
||||||
forM_ validChecksums (uncurry testValidChecksum)
|
forM_ validChecksums (uncurry testValidChecksum)
|
||||||
it "should be invalid" $
|
it "should be invalid" $
|
||||||
forM_ invalidChecksums testInvalidChecksum
|
forM_ invalidChecksums testInvalidChecksum
|
||||||
it "should be case-insensitive" $
|
it "should be case-insensitive" $
|
||||||
all (== Just "test12hrzfj") $
|
all ((== Just "test12hrzfj") . flip (bech32Encode Bech32) []) hrpCaseVariants
|
||||||
map (flip (bech32Encode Bech32) []) hrpCaseVariants
|
describe "bech32 address" $ do
|
||||||
describe "bech32 address" $ do
|
it "should be valid" $
|
||||||
it "should be valid" $
|
forM_ validChecksums (uncurry testValidChecksum)
|
||||||
forM_ validChecksums (uncurry testValidChecksum)
|
it "should be invalid" $
|
||||||
it "should be invalid" $
|
forM_ invalidChecksums testInvalidChecksum
|
||||||
forM_ invalidChecksums testInvalidChecksum
|
it "should be case-insensitive" $
|
||||||
it "should be case-insensitive" $
|
all ((== Just "test12hrzfj") . flip (bech32Encode Bech32) []) hrpCaseVariants
|
||||||
all (== Just "test12hrzfj") $
|
describe "bech32 encoding/decoding" $ do
|
||||||
map (flip (bech32Encode Bech32) []) hrpCaseVariants
|
it "should not encode long data string" $
|
||||||
describe "bech32 encoding/decoding" $ do
|
assert . isNothing $
|
||||||
it "should not encode long data string" $
|
bech32Encode Bech32 "bc" (replicate 82 (word5 (1 :: Word8)))
|
||||||
assert . isNothing $
|
it "should not encode bad version number" $
|
||||||
bech32Encode Bech32 "bc" (replicate 82 (word5 (1 :: Word8)))
|
assert $
|
||||||
it "should not encode bad version number" $
|
isNothing $
|
||||||
assert $ isNothing $ segwitEncode "bc" 17 []
|
segwitEncode "bc" 17 []
|
||||||
it "should not encode invalid length for version 0" $
|
it "should not encode invalid length for version 0" $
|
||||||
assert $ isNothing $ segwitEncode "bc" 0 (replicate 30 1)
|
assert $
|
||||||
it "should relax length restrictions for versions other than 0" $
|
isNothing $
|
||||||
assert $ isJust $ segwitEncode "bc" 1 (replicate 30 1)
|
segwitEncode "bc" 0 (replicate 30 1)
|
||||||
it "should not encode another long data string" $
|
it "should relax length restrictions for versions other than 0" $
|
||||||
assert $ isNothing $ segwitEncode "bc" 1 (replicate 41 1)
|
assert $
|
||||||
it "should not encode empty human readable part" $
|
isJust $
|
||||||
assert $ isNothing $ bech32Encode Bech32 "" []
|
segwitEncode "bc" 1 (replicate 30 1)
|
||||||
it "should not decode empty human-readable part" $
|
it "should not encode another long data string" $
|
||||||
assert $ isNothing $ bech32Decode "10a06t8"
|
assert $
|
||||||
it "human-readable part should be case-insensitive" $
|
isNothing $
|
||||||
bech32Encode Bech32 "HRP" [] `shouldBe` bech32Encode Bech32 "hrp" []
|
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 :: Bech32Encoding -> Bech32 -> Assertion
|
||||||
testValidChecksum enc checksum = case bech32Decode checksum of
|
testValidChecksum enc checksum = case bech32Decode checksum of
|
||||||
Nothing -> assertFailure (show checksum)
|
Nothing -> assertFailure (show checksum)
|
||||||
Just (enc', resultHRP, resultData) -> do
|
Just (enc', resultHRP, resultData) -> do
|
||||||
assertEqual (show checksum ++ " encoding incorrect") enc enc'
|
assertEqual (show checksum ++ " encoding incorrect") enc enc'
|
||||||
-- test that a corrupted checksum fails decoding.
|
-- test that a corrupted checksum fails decoding.
|
||||||
let (hrp, rest) = T.breakOnEnd "1" checksum
|
let (hrp, rest) = Text.breakOnEnd "1" checksum
|
||||||
Just (first, rest') = uncons rest
|
Just (first, rest') = uncons rest
|
||||||
checksumCorrupted = (hrp `snoc` chr (ord first `xor` 1)) `append` rest'
|
checksumCorrupted = (hrp `snoc` chr (ord first `xor` 1)) `append` rest'
|
||||||
assertBool (show checksum ++ " corrupted") $
|
assertBool (show checksum ++ " corrupted") $
|
||||||
isNothing (bech32Decode checksumCorrupted)
|
isNothing (bech32Decode checksumCorrupted)
|
||||||
-- test that re-encoding the decoded checksum results in the same checksum.
|
-- test that re-encoding the decoded checksum results in the same checksum.
|
||||||
let checksumEncoded = bech32Encode enc' resultHRP resultData
|
let checksumEncoded = bech32Encode enc' resultHRP resultData
|
||||||
expectedChecksum = Just $ T.toLower checksum
|
expectedChecksum = Just $ Text.toLower checksum
|
||||||
assertEqual
|
assertEqual
|
||||||
(show checksum ++ " re-encode")
|
(show checksum ++ " re-encode")
|
||||||
expectedChecksum
|
expectedChecksum
|
||||||
checksumEncoded
|
checksumEncoded
|
||||||
|
|
||||||
testInvalidChecksum :: Bech32 -> Assertion
|
testInvalidChecksum :: Bech32 -> Assertion
|
||||||
testInvalidChecksum checksum =
|
testInvalidChecksum checksum =
|
||||||
assertBool (show checksum) (isNothing $ bech32Decode checksum)
|
assertBool (show checksum) (isNothing $ bech32Decode checksum)
|
||||||
|
|
||||||
testValidAddress :: (Text, Text) -> Assertion
|
testValidAddress :: (Text, Text) -> Assertion
|
||||||
testValidAddress (address, hexscript) = do
|
testValidAddress (address, hexscript) = do
|
||||||
let address' = T.toLower address
|
let address' = Text.toLower address
|
||||||
hrp = T.take 2 address'
|
hrp = Text.take 2 address'
|
||||||
case segwitDecode hrp address of
|
case segwitDecode hrp address of
|
||||||
Nothing ->
|
Nothing ->
|
||||||
assertFailure (T.unpack address <> ": decode failed")
|
assertFailure (Text.unpack address <> ": decode failed")
|
||||||
Just (witver, witprog) -> do
|
Just (witver, witprog) -> do
|
||||||
assertEqual
|
assertEqual
|
||||||
(show address)
|
(show address)
|
||||||
(decodeHex hexscript)
|
(decodeHex hexscript)
|
||||||
(Just $ segwitScriptPubkey witver witprog)
|
(Just $ segwitScriptPubkey witver witprog)
|
||||||
assertEqual
|
assertEqual
|
||||||
(show address)
|
(show address)
|
||||||
(Just address')
|
(Just address')
|
||||||
(segwitEncode hrp witver witprog)
|
(segwitEncode hrp witver witprog)
|
||||||
|
|
||||||
testInvalidAddress :: Text -> Assertion
|
testInvalidAddress :: Text -> Assertion
|
||||||
testInvalidAddress address = do
|
testInvalidAddress address = do
|
||||||
assertBool (show address) (isNothing $ segwitDecode "bc" address)
|
assertBool (show address) (isNothing $ segwitDecode "bc" address)
|
||||||
assertBool (show address) (isNothing $ segwitDecode "tb" address)
|
assertBool (show address) (isNothing $ segwitDecode "tb" address)
|
||||||
|
|
||||||
segwitScriptPubkey :: Word8 -> [Word8] -> ByteString
|
segwitScriptPubkey :: Word8 -> [Word8] -> ByteString
|
||||||
segwitScriptPubkey witver witprog =
|
segwitScriptPubkey witver witprog =
|
||||||
B.pack $ witver' : fromIntegral (length witprog) : witprog
|
ByteString.pack $ witver' : fromIntegral (length witprog) : witprog
|
||||||
where
|
where
|
||||||
witver' = if witver == 0 then 0 else witver + 0x50
|
witver' = if witver == 0 then 0 else witver + 0x50
|
||||||
|
|
||||||
validChecksums :: [(Bech32Encoding, Text)]
|
validChecksums :: [(Bech32Encoding, Text)]
|
||||||
validChecksums =
|
validChecksums =
|
||||||
[
|
[ ( Bech32,
|
||||||
( Bech32
|
"A12UEL5L"
|
||||||
, "A12UEL5L"
|
),
|
||||||
)
|
( Bech32,
|
||||||
,
|
"an83characterlonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1tt5tgs"
|
||||||
( Bech32
|
),
|
||||||
, "an83characterlonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1tt5tgs"
|
( Bech32,
|
||||||
)
|
"abcdef1qpzry9x8gf2tvdw0s3jn54khce6mua7lmqqqxw"
|
||||||
,
|
),
|
||||||
( Bech32
|
( Bech32,
|
||||||
, "abcdef1qpzry9x8gf2tvdw0s3jn54khce6mua7lmqqqxw"
|
"11qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqc8247j"
|
||||||
)
|
),
|
||||||
,
|
( Bech32,
|
||||||
( Bech32
|
"split1checkupstagehandshakeupstreamerranterredcaperred2y9e3w"
|
||||||
, "11qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqc8247j"
|
),
|
||||||
)
|
( Bech32m,
|
||||||
,
|
"A1LQFN3A"
|
||||||
( Bech32
|
),
|
||||||
, "split1checkupstagehandshakeupstreamerranterredcaperred2y9e3w"
|
( Bech32m,
|
||||||
)
|
"a1lqfn3a"
|
||||||
,
|
),
|
||||||
( Bech32m
|
( Bech32m,
|
||||||
, "A1LQFN3A"
|
"an83characterlonghumanreadablepartthatcontainsthetheexcludedcharactersbioandnumber11sg7hg6"
|
||||||
)
|
),
|
||||||
,
|
( Bech32m,
|
||||||
( Bech32m
|
"abcdef1l7aum6echk45nj3s0wdvt2fg8x9yrzpqzd3ryx"
|
||||||
, "a1lqfn3a"
|
),
|
||||||
)
|
( Bech32m,
|
||||||
,
|
"11llllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllludsr8"
|
||||||
( Bech32m
|
),
|
||||||
, "an83characterlonghumanreadablepartthatcontainsthetheexcludedcharactersbioandnumber11sg7hg6"
|
( Bech32m,
|
||||||
)
|
"split1checkupstagehandshakeupstreamerranterredcaperredlc445v"
|
||||||
,
|
),
|
||||||
( Bech32m
|
( Bech32m,
|
||||||
, "abcdef1l7aum6echk45nj3s0wdvt2fg8x9yrzpqzd3ryx"
|
"?1v759aa"
|
||||||
)
|
)
|
||||||
,
|
]
|
||||||
( Bech32m
|
|
||||||
, "11llllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllludsr8"
|
|
||||||
)
|
|
||||||
,
|
|
||||||
( Bech32m
|
|
||||||
, "split1checkupstagehandshakeupstreamerranterredcaperredlc445v"
|
|
||||||
)
|
|
||||||
,
|
|
||||||
( Bech32m
|
|
||||||
, "?1v759aa"
|
|
||||||
)
|
|
||||||
]
|
|
||||||
|
|
||||||
invalidChecksums :: [Text]
|
invalidChecksums :: [Text]
|
||||||
invalidChecksums =
|
invalidChecksums =
|
||||||
[ " 1nwldj5"
|
[ " 1nwldj5",
|
||||||
, "\DEL1axkwrx"
|
"\DEL1axkwrx",
|
||||||
, "an84characterslonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1569pvx"
|
"an84characterslonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1569pvx",
|
||||||
, "pzry9x0s0muk"
|
"pzry9x0s0muk",
|
||||||
, "1pzry9x0s0muk"
|
"1pzry9x0s0muk",
|
||||||
, "x1b4n0q5v"
|
"x1b4n0q5v",
|
||||||
, "li1dgmt3"
|
"li1dgmt3",
|
||||||
, "de1lg7wt\xFF"
|
"de1lg7wt\xFF"
|
||||||
]
|
]
|
||||||
|
|
||||||
validAddresses :: [(Text, Text)]
|
validAddresses :: [(Text, Text)]
|
||||||
validAddresses =
|
validAddresses =
|
||||||
[
|
[ ( "BC1QW508D6QEJXTDG4Y5R3ZARVARY0C5XW7KV8F3T4",
|
||||||
( "BC1QW508D6QEJXTDG4Y5R3ZARVARY0C5XW7KV8F3T4"
|
"0014751e76e8199196d454941c45d1b3a323f1433bd6"
|
||||||
, "0014751e76e8199196d454941c45d1b3a323f1433bd6"
|
),
|
||||||
)
|
( "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sl5k7",
|
||||||
,
|
"00201863143c14c5166804bd19203356da136c985678cd4d27a1b8c6329604903262"
|
||||||
( "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sl5k7"
|
),
|
||||||
, "00201863143c14c5166804bd19203356da136c985678cd4d27a1b8c6329604903262"
|
( "tb1qqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesrxh6hy",
|
||||||
)
|
"0020000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433"
|
||||||
,
|
),
|
||||||
( "tb1qqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesrxh6hy"
|
( "BC1QW508D6QEJXTDG4Y5R3ZARVARY0C5XW7KV8F3T4",
|
||||||
, "0020000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433"
|
"0014751e76e8199196d454941c45d1b3a323f1433bd6"
|
||||||
)
|
),
|
||||||
,
|
( "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sl5k7",
|
||||||
( "BC1QW508D6QEJXTDG4Y5R3ZARVARY0C5XW7KV8F3T4"
|
"00201863143c14c5166804bd19203356da136c985678cd4d27a1b8c6329604903262"
|
||||||
, "0014751e76e8199196d454941c45d1b3a323f1433bd6"
|
),
|
||||||
)
|
( "bc1pw508d6qejxtdg4y5r3zarvary0c5xw7kw508d6qejxtdg4y5r3zarvary0c5xw7kt5nd6y",
|
||||||
,
|
"5128751e76e8199196d454941c45d1b3a323f1433bd6751e76e8199196d454941c45d1b3a323f1433bd6"
|
||||||
( "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sl5k7"
|
),
|
||||||
, "00201863143c14c5166804bd19203356da136c985678cd4d27a1b8c6329604903262"
|
( "BC1SW50QGDZ25J",
|
||||||
)
|
"6002751e"
|
||||||
,
|
),
|
||||||
( "bc1pw508d6qejxtdg4y5r3zarvary0c5xw7kw508d6qejxtdg4y5r3zarvary0c5xw7kt5nd6y"
|
( "bc1zw508d6qejxtdg4y5r3zarvaryvaxxpcs",
|
||||||
, "5128751e76e8199196d454941c45d1b3a323f1433bd6751e76e8199196d454941c45d1b3a323f1433bd6"
|
"5210751e76e8199196d454941c45d1b3a323"
|
||||||
)
|
),
|
||||||
,
|
( "tb1qqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesrxh6hy",
|
||||||
( "BC1SW50QGDZ25J"
|
"0020000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433"
|
||||||
, "6002751e"
|
),
|
||||||
)
|
( "tb1pqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesf3hn0c",
|
||||||
,
|
"5120000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433"
|
||||||
( "bc1zw508d6qejxtdg4y5r3zarvaryvaxxpcs"
|
),
|
||||||
, "5210751e76e8199196d454941c45d1b3a323"
|
( "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqzk5jj0",
|
||||||
)
|
"512079be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798"
|
||||||
,
|
)
|
||||||
( "tb1qqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesrxh6hy"
|
]
|
||||||
, "0020000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433"
|
|
||||||
)
|
|
||||||
,
|
|
||||||
( "tb1pqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesf3hn0c"
|
|
||||||
, "5120000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433"
|
|
||||||
)
|
|
||||||
,
|
|
||||||
( "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqzk5jj0"
|
|
||||||
, "512079be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798"
|
|
||||||
)
|
|
||||||
]
|
|
||||||
|
|
||||||
invalidAddresses :: [Text]
|
invalidAddresses :: [Text]
|
||||||
invalidAddresses =
|
invalidAddresses =
|
||||||
[ "tc1qw508d6qejxtdg4y5r3zarvary0c5xw7kg3g4ty"
|
[ "tc1qw508d6qejxtdg4y5r3zarvary0c5xw7kg3g4ty",
|
||||||
, "bc1qw508d6qejxtdg4y5r3zarvary0c5xw7kv8f3t5"
|
"bc1qw508d6qejxtdg4y5r3zarvary0c5xw7kv8f3t5",
|
||||||
, "BC13W508D6QEJXTDG4Y5R3ZARVARY0C5XW7KN40WF2"
|
"BC13W508D6QEJXTDG4Y5R3ZARVARY0C5XW7KN40WF2",
|
||||||
, "bc1rw5uspcuh"
|
"bc1rw5uspcuh",
|
||||||
, "bc10w508d6qejxtdg4y5r3zarvary0c5xw7kw508d6qejxtdg4y5r3zarvary0c5xw7kw5rljs90"
|
"bc10w508d6qejxtdg4y5r3zarvary0c5xw7kw508d6qejxtdg4y5r3zarvary0c5xw7kw5rljs90",
|
||||||
, "BC1QR508D6QEJXTDG4Y5R3ZARVARYV98GJ9P"
|
"BC1QR508D6QEJXTDG4Y5R3ZARVARYV98GJ9P",
|
||||||
, "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sL5k7"
|
"tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sL5k7",
|
||||||
, "bc1zw508d6qejxtdg4y5r3zarvaryvqyzf3du"
|
"bc1zw508d6qejxtdg4y5r3zarvaryvqyzf3du",
|
||||||
, "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3pjxtptv"
|
"tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3pjxtptv",
|
||||||
, "bc1gmk9yu"
|
"bc1gmk9yu",
|
||||||
, "tc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq5zuyut"
|
"tc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq5zuyut",
|
||||||
, "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqh2y7hd"
|
"bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqh2y7hd",
|
||||||
, "tb1z0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqglt7rf"
|
"tb1z0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqglt7rf",
|
||||||
, "BC1S0XLXVLHEMJA6C4DQV22UAPCTQUPFHLXM9H8Z3K2E72Q4K9HCZ7VQ54WELL"
|
"BC1S0XLXVLHEMJA6C4DQV22UAPCTQUPFHLXM9H8Z3K2E72Q4K9HCZ7VQ54WELL",
|
||||||
, "bc1qw508d6qejxtdg4y5r3zarvary0c5xw7kemeawh"
|
"bc1qw508d6qejxtdg4y5r3zarvary0c5xw7kemeawh",
|
||||||
, "tb1q0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq24jc47"
|
"tb1q0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq24jc47",
|
||||||
, "bc1p38j9r5y49hruaue7wxjce0updqjuyyx0kh56v8s25huc6995vvpql3jow4"
|
"bc1p38j9r5y49hruaue7wxjce0updqjuyyx0kh56v8s25huc6995vvpql3jow4",
|
||||||
, "BC130XLXVLHEMJA6C4DQV22UAPCTQUPFHLXM9H8Z3K2E72Q4K9HCZ7VQ7ZWS8R"
|
"BC130XLXVLHEMJA6C4DQV22UAPCTQUPFHLXM9H8Z3K2E72Q4K9HCZ7VQ7ZWS8R",
|
||||||
, "bc1pw5dgrnzv"
|
"bc1pw5dgrnzv",
|
||||||
, "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7v8n0nx0muaewav253zgeav"
|
"bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7v8n0nx0muaewav253zgeav",
|
||||||
, "tb1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq47Zagq"
|
"tb1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq47Zagq",
|
||||||
, "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7v07qwwzcrf"
|
"bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7v07qwwzcrf",
|
||||||
, "tb1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vpggkg4j"
|
"tb1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vpggkg4j"
|
||||||
]
|
]
|
||||||
|
|
||||||
hrpCaseVariants :: [Text]
|
hrpCaseVariants :: [Text]
|
||||||
hrpCaseVariants = map T.pack hrpTestPermutations
|
hrpCaseVariants = map Text.pack hrpTestPermutations
|
||||||
|
|
||||||
hrpTestPermutations :: [String]
|
hrpTestPermutations :: [String]
|
||||||
hrpTestPermutations = do
|
hrpTestPermutations = do
|
||||||
a <- ['t', 'T']
|
a <- ['t', 'T']
|
||||||
b <- ['e', 'E']
|
b <- ['e', 'E']
|
||||||
c <- ['s', 'S']
|
c <- ['s', 'S']
|
||||||
d <- ['t', 'T']
|
d <- ['t', 'T']
|
||||||
return [a, b, c, d]
|
return [a, b, c, d]
|
||||||
|
@ -1,347 +1,315 @@
|
|||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Haskoin.Address.CashAddrSpec (spec) where
|
module Haskoin.Address.CashAddrSpec (spec) where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import qualified Data.ByteString.Char8 as C
|
import Data.ByteString.Char8 qualified as Char8
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.String.Conversions
|
import Data.String.Conversions
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Haskoin.Address
|
import Haskoin.Address
|
||||||
import Haskoin.Constants
|
import Haskoin.Network.Constants
|
||||||
import Haskoin.Util
|
import Haskoin.Util
|
||||||
import Test.HUnit
|
import Test.HUnit
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = do
|
spec = do
|
||||||
describe "cashaddr checksum test vectors" $ do
|
describe "cashaddr checksum test vectors" $ do
|
||||||
it "prefix:x64nx6hz" $ do
|
it "prefix:x64nx6hz" $ do
|
||||||
let mpb = cash32decode "prefix:x64nx6hz"
|
let mpb = cash32decode "prefix:x64nx6hz"
|
||||||
mpb `shouldBe` Just ("prefix", "")
|
mpb `shouldBe` Just ("prefix", "")
|
||||||
it "p:gpf8m4h7" $ do
|
it "p:gpf8m4h7" $ do
|
||||||
let mpb = cash32decode "p:gpf8m4h7"
|
let mpb = cash32decode "p:gpf8m4h7"
|
||||||
mpb `shouldBe` Just ("p", "")
|
mpb `shouldBe` Just ("p", "")
|
||||||
it "bitcoincash:qpzry9x8gf2tvdw0s3jn54khce6mua7lcw20ayyn" $ do
|
it "bitcoincash:qpzry9x8gf2tvdw0s3jn54khce6mua7lcw20ayyn" $ do
|
||||||
let mpb =
|
let mpb =
|
||||||
cash32decode
|
cash32decode
|
||||||
"bitcoincash:qpzry9x8gf2tvdw0s3jn54khce6mua7lcw20ayyn"
|
"bitcoincash:qpzry9x8gf2tvdw0s3jn54khce6mua7lcw20ayyn"
|
||||||
mpb
|
mpb
|
||||||
`shouldBe` Just
|
`shouldBe` Just
|
||||||
( "bitcoincash"
|
( "bitcoincash",
|
||||||
, "\NULD2\DC4\199BT\182\&5\207\132e:V\215\198u\190w\223"
|
"\NULD2\DC4\199BT\182\&5\207\132e:V\215\198u\190w\223"
|
||||||
)
|
)
|
||||||
it "bchtest:testnetaddress4d6njnut" $ do
|
it "bchtest:testnetaddress4d6njnut" $ do
|
||||||
let mpb = cash32decode "bchtest:testnetaddress4d6njnut"
|
let mpb = cash32decode "bchtest:testnetaddress4d6njnut"
|
||||||
mpb `shouldBe` Just ("bchtest", "^`\185\229}kG\152")
|
mpb `shouldBe` Just ("bchtest", "^`\185\229}kG\152")
|
||||||
it "bchreg:555555555555555555555555555555555555555555555udxmlmrz" $ do
|
it "bchreg:555555555555555555555555555555555555555555555udxmlmrz" $ do
|
||||||
let mpb =
|
let mpb =
|
||||||
cash32decode
|
cash32decode
|
||||||
"bchreg:555555555555555555555555555555555555555555555udxmlmrz"
|
"bchreg:555555555555555555555555555555555555555555555udxmlmrz"
|
||||||
mpb
|
mpb
|
||||||
`shouldBe` Just
|
`shouldBe` Just
|
||||||
( "bchreg"
|
( "bchreg",
|
||||||
, "\165)JR\148\165)JR\148\165)JR\148\165)JR\148\165)JR\148\165)J"
|
"\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
|
describe "cashaddr to base58 translation test vectors" $ do
|
||||||
it "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu" $ do
|
it "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu" $ do
|
||||||
let addr =
|
let addr =
|
||||||
addrToText bch
|
addrToText bch
|
||||||
=<< textToAddr btc "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu"
|
=<< textToAddr btc "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu"
|
||||||
addr
|
addr
|
||||||
`shouldBe` Just "bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a"
|
`shouldBe` Just "bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a"
|
||||||
it "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR" $ do
|
it "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR" $ do
|
||||||
let addr =
|
let addr =
|
||||||
addrToText bch
|
addrToText bch
|
||||||
=<< textToAddr btc "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR"
|
=<< textToAddr btc "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR"
|
||||||
addr
|
addr
|
||||||
`shouldBe` Just "bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy"
|
`shouldBe` Just "bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy"
|
||||||
it "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb" $ do
|
it "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb" $ do
|
||||||
let addr =
|
let addr =
|
||||||
addrToText bch
|
addrToText bch
|
||||||
=<< textToAddr btc "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb"
|
=<< textToAddr btc "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb"
|
||||||
addr
|
addr
|
||||||
`shouldBe` Just "bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r"
|
`shouldBe` Just "bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r"
|
||||||
it "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC" $ do
|
it "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC" $ do
|
||||||
let addr =
|
let addr =
|
||||||
addrToText bch
|
addrToText bch
|
||||||
=<< textToAddr btc "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC"
|
=<< textToAddr btc "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC"
|
||||||
addr
|
addr
|
||||||
`shouldBe` Just "bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq"
|
`shouldBe` Just "bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq"
|
||||||
it "3LDsS579y7sruadqu11beEJoTjdFiFCdX4" $ do
|
it "3LDsS579y7sruadqu11beEJoTjdFiFCdX4" $ do
|
||||||
let addr =
|
let addr =
|
||||||
addrToText bch
|
addrToText bch
|
||||||
=<< textToAddr btc "3LDsS579y7sruadqu11beEJoTjdFiFCdX4"
|
=<< textToAddr btc "3LDsS579y7sruadqu11beEJoTjdFiFCdX4"
|
||||||
addr
|
addr
|
||||||
`shouldBe` Just "bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e"
|
`shouldBe` Just "bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e"
|
||||||
it "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw" $ do
|
it "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw" $ do
|
||||||
let addr =
|
let addr =
|
||||||
addrToText bch
|
addrToText bch
|
||||||
=<< textToAddr btc "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw"
|
=<< textToAddr btc "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw"
|
||||||
addr
|
addr
|
||||||
`shouldBe` Just "bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37"
|
`shouldBe` Just "bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37"
|
||||||
describe "base58 to cashaddr translation test vectors" $ do
|
describe "base58 to cashaddr translation test vectors" $ do
|
||||||
it "bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a" $ do
|
it "bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a" $ do
|
||||||
let addr =
|
let addr =
|
||||||
addrToText btc
|
addrToText btc
|
||||||
=<< textToAddr
|
=<< textToAddr
|
||||||
bch
|
bch
|
||||||
"bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a"
|
"bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a"
|
||||||
addr `shouldBe` Just "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu"
|
addr `shouldBe` Just "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu"
|
||||||
it "bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy" $ do
|
it "bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy" $ do
|
||||||
let addr =
|
let addr =
|
||||||
addrToText btc
|
addrToText btc
|
||||||
=<< textToAddr
|
=<< textToAddr
|
||||||
bch
|
bch
|
||||||
"bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy"
|
"bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy"
|
||||||
addr `shouldBe` Just "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR"
|
addr `shouldBe` Just "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR"
|
||||||
it "bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r" $ do
|
it "bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r" $ do
|
||||||
let addr =
|
let addr =
|
||||||
addrToText btc
|
addrToText btc
|
||||||
=<< textToAddr
|
=<< textToAddr
|
||||||
bch
|
bch
|
||||||
"bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r"
|
"bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r"
|
||||||
addr `shouldBe` Just "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb"
|
addr `shouldBe` Just "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb"
|
||||||
it "bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq" $ do
|
it "bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq" $ do
|
||||||
let addr =
|
let addr =
|
||||||
addrToText btc
|
addrToText btc
|
||||||
=<< textToAddr
|
=<< textToAddr
|
||||||
bch
|
bch
|
||||||
"bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq"
|
"bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq"
|
||||||
addr `shouldBe` Just "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC"
|
addr `shouldBe` Just "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC"
|
||||||
it "bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e" $ do
|
it "bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e" $ do
|
||||||
let addr =
|
let addr =
|
||||||
addrToText btc
|
addrToText btc
|
||||||
=<< textToAddr
|
=<< textToAddr
|
||||||
bch
|
bch
|
||||||
"bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e"
|
"bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e"
|
||||||
addr `shouldBe` Just "3LDsS579y7sruadqu11beEJoTjdFiFCdX4"
|
addr `shouldBe` Just "3LDsS579y7sruadqu11beEJoTjdFiFCdX4"
|
||||||
it "bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37" $ do
|
it "bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37" $ do
|
||||||
let addr =
|
let addr =
|
||||||
addrToText btc
|
addrToText btc
|
||||||
=<< textToAddr
|
=<< textToAddr
|
||||||
bch
|
bch
|
||||||
"bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37"
|
"bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37"
|
||||||
addr `shouldBe` Just "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw"
|
addr `shouldBe` Just "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw"
|
||||||
describe "cashaddr larger test vectors" $
|
describe "cashaddr larger test vectors" $
|
||||||
forM_ (zip [0 ..] vectors) $ \(i, vec) ->
|
forM_ (zip [0 ..] vectors) $ \(i, vec) ->
|
||||||
it ("cashaddr test vector " <> show (i :: Int)) $ testCashAddr vec
|
it ("cashaddr test vector " <> show (i :: Int)) $ testCashAddr vec
|
||||||
|
|
||||||
{- Various utilities -}
|
{- Various utilities -}
|
||||||
|
|
||||||
testCashAddr :: (Int, CashVersion, Cash32, Text) -> Assertion
|
testCashAddr :: (Int, CashVersion, Cash32, Text) -> Assertion
|
||||||
testCashAddr (len, typ, addr, hex) = do
|
testCashAddr (len, typ, addr, hex) = do
|
||||||
let mbs = decodeHex hex
|
let mbs = decodeHex hex
|
||||||
assertBool "Could not decode hex payload from test vector" (isJust mbs)
|
assertBool "Could not decode hex payload from test vector" (isJust mbs)
|
||||||
let mlow = cash32decode addr
|
let mlow = cash32decode addr
|
||||||
assertBool "Could not decode low level address" (isJust mlow)
|
assertBool "Could not decode low level address" (isJust mlow)
|
||||||
let Just (_, lbs) = mlow
|
let Just (_, lbs) = mlow
|
||||||
assertEqual "Low-level payload size incorrect" len (C.length lbs - 1)
|
assertEqual "Low-level payload size incorrect" len (Char8.length lbs - 1)
|
||||||
assertEqual "Low-level payload doesn't match" bs (C.tail lbs)
|
assertEqual "Low-level payload doesn't match" bs (Char8.tail lbs)
|
||||||
let mdec = cash32decodeType addr
|
let mdec = cash32decodeType addr
|
||||||
assertBool ("Could not decode test address: " <> cs addr) (isJust mdec)
|
assertBool ("Could not decode test address: " <> cs addr) (isJust mdec)
|
||||||
assertEqual "Length doesn't match" len (C.length pay)
|
assertEqual "Length doesn't match" len (Char8.length pay)
|
||||||
assertEqual "Version doesn't match" typ ver
|
assertEqual "Version doesn't match" typ ver
|
||||||
assertEqual "Payload doesn't match" bs pay
|
assertEqual "Payload doesn't match" bs pay
|
||||||
where
|
where
|
||||||
Just bs = decodeHex hex
|
Just bs = decodeHex hex
|
||||||
Just (_, ver, pay) = cash32decodeType addr
|
Just (_, ver, pay) = cash32decodeType addr
|
||||||
|
|
||||||
{- | All vectors starting with @pref@ had the wrong version in the spec
|
-- | All vectors starting with @pref@ had the wrong version in the spec
|
||||||
document.
|
-- document.
|
||||||
-}
|
|
||||||
vectors :: [(Int, CashVersion, Text, Text)]
|
vectors :: [(Int, CashVersion, Text, Text)]
|
||||||
vectors =
|
vectors =
|
||||||
[
|
[ ( 20,
|
||||||
( 20
|
0,
|
||||||
, 0
|
"bitcoincash:qr6m7j9njldwwzlg9v7v53unlr4jkmx6eylep8ekg2",
|
||||||
, "bitcoincash:qr6m7j9njldwwzlg9v7v53unlr4jkmx6eylep8ekg2"
|
"F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9"
|
||||||
, "F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9"
|
),
|
||||||
)
|
( 20,
|
||||||
,
|
1,
|
||||||
( 20
|
"bchtest:pr6m7j9njldwwzlg9v7v53unlr4jkmx6eyvwc0uz5t",
|
||||||
, 1
|
"F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9"
|
||||||
, "bchtest:pr6m7j9njldwwzlg9v7v53unlr4jkmx6eyvwc0uz5t"
|
),
|
||||||
, "F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9"
|
( 20,
|
||||||
)
|
1,
|
||||||
,
|
"pref:pr6m7j9njldwwzlg9v7v53unlr4jkmx6ey65nvtks5",
|
||||||
( 20
|
"F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9"
|
||||||
, 1
|
),
|
||||||
, "pref:pr6m7j9njldwwzlg9v7v53unlr4jkmx6ey65nvtks5"
|
( 20,
|
||||||
, "F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9"
|
15,
|
||||||
)
|
"prefix:0r6m7j9njldwwzlg9v7v53unlr4jkmx6ey3qnjwsrf",
|
||||||
,
|
"F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9"
|
||||||
( 20
|
),
|
||||||
, 15
|
( 24,
|
||||||
, "prefix:0r6m7j9njldwwzlg9v7v53unlr4jkmx6ey3qnjwsrf"
|
0,
|
||||||
, "F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9"
|
"bitcoincash:q9adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2ws4mr9g0",
|
||||||
)
|
"7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA"
|
||||||
,
|
),
|
||||||
( 24
|
( 24,
|
||||||
, 0
|
1,
|
||||||
, "bitcoincash:q9adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2ws4mr9g0"
|
"bchtest:p9adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2u94tsynr",
|
||||||
, "7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA"
|
"7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA"
|
||||||
)
|
),
|
||||||
,
|
( 24,
|
||||||
( 24
|
1,
|
||||||
, 1
|
"pref:p9adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2khlwwk5v",
|
||||||
, "bchtest:p9adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2u94tsynr"
|
"7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA"
|
||||||
, "7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA"
|
),
|
||||||
)
|
( 24,
|
||||||
,
|
15,
|
||||||
( 24
|
"prefix:09adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2p29kc2lp",
|
||||||
, 1
|
"7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA"
|
||||||
, "pref:p9adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2khlwwk5v"
|
),
|
||||||
, "7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA"
|
( 28,
|
||||||
)
|
0,
|
||||||
,
|
"bitcoincash:qgagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkcw59jxxuz",
|
||||||
( 24
|
"3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B"
|
||||||
, 15
|
),
|
||||||
, "prefix:09adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2p29kc2lp"
|
( 28,
|
||||||
, "7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA"
|
1,
|
||||||
)
|
"bchtest:pgagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkcvs7md7wt",
|
||||||
,
|
"3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B"
|
||||||
( 28
|
),
|
||||||
, 0
|
( 28,
|
||||||
, "bitcoincash:qgagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkcw59jxxuz"
|
1,
|
||||||
, "3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B"
|
"pref:pgagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkcrsr6gzkn",
|
||||||
)
|
"3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B"
|
||||||
,
|
),
|
||||||
( 28
|
( 28,
|
||||||
, 1
|
15,
|
||||||
, "bchtest:pgagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkcvs7md7wt"
|
"prefix:0gagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkc5djw8s9g",
|
||||||
, "3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B"
|
"3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B"
|
||||||
)
|
),
|
||||||
,
|
( 32,
|
||||||
( 28
|
0,
|
||||||
, 1
|
"bitcoincash:qvch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxq5nlegake",
|
||||||
, "pref:pgagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkcrsr6gzkn"
|
"3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060"
|
||||||
, "3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B"
|
),
|
||||||
)
|
( 32,
|
||||||
,
|
1,
|
||||||
( 28
|
"bchtest:pvch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxq7fqng6m6",
|
||||||
, 15
|
"3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060"
|
||||||
, "prefix:0gagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkc5djw8s9g"
|
),
|
||||||
, "3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B"
|
( 32,
|
||||||
)
|
1,
|
||||||
,
|
"pref:pvch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxq4k9m7qf9",
|
||||||
( 32
|
"3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060"
|
||||||
, 0
|
),
|
||||||
, "bitcoincash:qvch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxq5nlegake"
|
( 32,
|
||||||
, "3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060"
|
15,
|
||||||
)
|
"prefix:0vch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxqsh6jgp6w",
|
||||||
,
|
"3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060"
|
||||||
( 32
|
),
|
||||||
, 1
|
( 40,
|
||||||
, "bchtest:pvch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxq7fqng6m6"
|
0,
|
||||||
, "3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060"
|
"bitcoincash:qnq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklv39gr3uvz",
|
||||||
)
|
"C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB"
|
||||||
,
|
),
|
||||||
( 32
|
( 40,
|
||||||
, 1
|
1,
|
||||||
, "pref:pvch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxq4k9m7qf9"
|
"bchtest:pnq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklvmgm6ynej",
|
||||||
, "3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060"
|
"C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB"
|
||||||
)
|
),
|
||||||
,
|
( 40,
|
||||||
( 32
|
1,
|
||||||
, 15
|
"pref:pnq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklv0vx5z0w3",
|
||||||
, "prefix:0vch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxqsh6jgp6w"
|
"C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB"
|
||||||
, "3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060"
|
),
|
||||||
)
|
( 40,
|
||||||
,
|
15,
|
||||||
( 40
|
"prefix:0nq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklvwsvctzqy",
|
||||||
, 0
|
"C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB"
|
||||||
, "bitcoincash:qnq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklv39gr3uvz"
|
),
|
||||||
, "C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB"
|
( 48,
|
||||||
)
|
0,
|
||||||
,
|
"bitcoincash:qh3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqex2w82sl",
|
||||||
( 40
|
"E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C"
|
||||||
, 1
|
),
|
||||||
, "bchtest:pnq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklvmgm6ynej"
|
( 48,
|
||||||
, "C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB"
|
1,
|
||||||
)
|
"bchtest:ph3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqnzf7mt6x",
|
||||||
,
|
"E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C"
|
||||||
( 40
|
),
|
||||||
, 1
|
( 48,
|
||||||
, "pref:pnq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklv0vx5z0w3"
|
1,
|
||||||
, "C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB"
|
"pref:ph3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqjntdfcwg",
|
||||||
)
|
"E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C"
|
||||||
,
|
),
|
||||||
( 40
|
( 48,
|
||||||
, 15
|
15,
|
||||||
, "prefix:0nq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklvwsvctzqy"
|
"prefix:0h3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqakcssnmn",
|
||||||
, "C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB"
|
"E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C"
|
||||||
)
|
),
|
||||||
,
|
( 56,
|
||||||
( 48
|
0,
|
||||||
, 0
|
"bitcoincash:qmvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqscw8jd03f",
|
||||||
, "bitcoincash:qh3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqex2w82sl"
|
"D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041"
|
||||||
, "E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C"
|
),
|
||||||
)
|
( 56,
|
||||||
,
|
1,
|
||||||
( 48
|
"bchtest:pmvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqs6kgdsg2g",
|
||||||
, 1
|
"D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041"
|
||||||
, "bchtest:ph3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqnzf7mt6x"
|
),
|
||||||
, "E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C"
|
( 56,
|
||||||
)
|
1,
|
||||||
,
|
"pref:pmvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqsammyqffl",
|
||||||
( 48
|
"D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041"
|
||||||
, 1
|
),
|
||||||
, "pref:ph3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqjntdfcwg"
|
( 56,
|
||||||
, "E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C"
|
15,
|
||||||
)
|
"prefix:0mvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqsgjrqpnw8",
|
||||||
,
|
"D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041"
|
||||||
( 48
|
),
|
||||||
, 15
|
( 64,
|
||||||
, "prefix:0h3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqakcssnmn"
|
0,
|
||||||
, "E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C"
|
"bitcoincash:qlg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96mtky5sv5w",
|
||||||
)
|
"D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B"
|
||||||
,
|
),
|
||||||
( 56
|
( 64,
|
||||||
, 0
|
1,
|
||||||
, "bitcoincash:qmvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqscw8jd03f"
|
"bchtest:plg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96mc773cwez",
|
||||||
, "D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041"
|
"D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B"
|
||||||
)
|
),
|
||||||
,
|
( 64,
|
||||||
( 56
|
1,
|
||||||
, 1
|
"pref:plg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96mg7pj3lh8",
|
||||||
, "bchtest:pmvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqs6kgdsg2g"
|
"D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B"
|
||||||
, "D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041"
|
),
|
||||||
)
|
( 64,
|
||||||
,
|
15,
|
||||||
( 56
|
"prefix:0lg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96ms92w6845",
|
||||||
, 1
|
"D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B"
|
||||||
, "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 #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Haskoin.AddressSpec (spec) where
|
module Haskoin.AddressSpec (spec) where
|
||||||
|
|
||||||
import Data.ByteString (ByteString)
|
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.Maybe (fromJust, isJust)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as T
|
import Data.Text qualified as T
|
||||||
import Haskoin.Address
|
import Haskoin.Address
|
||||||
import Haskoin.Constants
|
import Haskoin.Crypto
|
||||||
import Haskoin.Data
|
import Haskoin.Network.Constants
|
||||||
import Haskoin.Keys
|
import Haskoin.Network.Data
|
||||||
import Haskoin.Util
|
import Haskoin.Util
|
||||||
import Haskoin.Util.Arbitrary
|
import Haskoin.Util.Arbitrary
|
||||||
import Test.HUnit
|
import Test.HUnit
|
||||||
@ -26,178 +27,172 @@ readVals = [ReadBox arbitraryAddressAll]
|
|||||||
|
|
||||||
netVals :: [NetBox]
|
netVals :: [NetBox]
|
||||||
netVals =
|
netVals =
|
||||||
[NetBox (addrToJSON, addrToEncoding, addrFromJSON, arbitraryNetAddress)]
|
[NetBox (marshalValue, marshalEncoding, unmarshalValue, arbitraryNetAddress)]
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = do
|
spec = prepareContext $ \ctx -> do
|
||||||
testIdentity serialVals readVals [] netVals
|
testIdentity serialVals readVals [] netVals
|
||||||
describe "Address properties" $ do
|
describe "Address properties" $ do
|
||||||
prop "encodes and decodes base58 bytestring" $
|
prop "encodes and decodes base58 bytestring" $
|
||||||
forAll arbitraryBS $ \bs ->
|
forAll arbitraryBS $ \bs ->
|
||||||
decodeBase58 (encodeBase58 bs) == Just bs
|
decodeBase58 (encodeBase58 bs) == Just bs
|
||||||
prop "encodes and decodes base58 bytestring with checksum" $
|
prop "encodes and decodes base58 bytestring with checksum" $
|
||||||
forAll arbitraryBS $ \bs ->
|
forAll arbitraryBS $ \bs ->
|
||||||
decodeBase58Check (encodeBase58Check bs) == Just bs
|
decodeBase58Check (encodeBase58Check bs) == Just bs
|
||||||
prop "textToAddr . addrToText identity" $
|
prop "textToAddr . addrToText identity" $
|
||||||
forAll arbitraryNetAddress $ \(net, a) ->
|
forAll arbitraryNetAddress $ \(net, a) ->
|
||||||
(textToAddr net =<< addrToText net a) == Just a
|
(textToAddr net =<< addrToText net a) == Just a
|
||||||
prop "outputAddress . addressToOutput identity" $
|
prop "outputAddress . addressToOutput identity" $
|
||||||
forAll arbitraryAddress $ \a ->
|
forAll arbitraryAddress $ \a ->
|
||||||
outputAddress (addressToOutput a) == Just a
|
outputAddress ctx (addressToOutput a) == Just a
|
||||||
describe "Address vectors" $ do
|
describe "Address vectors" $ do
|
||||||
it "Passes Base58 vectors 1" $
|
it "Passes Base58 vectors 1" $
|
||||||
mapM_ testVector vectors
|
mapM_ testVector vectors
|
||||||
it "Passes Base58 vectors 2" $
|
it "Passes Base58 vectors 2" $
|
||||||
mapM_ testBase58Vector base58Vectors
|
mapM_ testBase58Vector base58Vectors
|
||||||
it "Passes Base58 invalid decoding vectors" $
|
it "Passes Base58 invalid decoding vectors" $
|
||||||
mapM_ testBase58InvalidVector base58InvalidVectors
|
mapM_ testBase58InvalidVector base58InvalidVectors
|
||||||
it "Passes Base58Check invalid decoding vectors" $
|
it "Passes Base58Check invalid decoding vectors" $
|
||||||
mapM_ testBase58ChkInvalidVector base58ChkInvalidVectors
|
mapM_ testBase58ChkInvalidVector base58ChkInvalidVectors
|
||||||
it "Passes addresses witness p2sh(pwpkh) vectors" $
|
it "Passes addresses witness p2sh(pwpkh) vectors" $
|
||||||
mapM_ testCompatWitnessVector compatWitnessVectors
|
mapM_ (testCompatWitnessVector ctx) compatWitnessVectors
|
||||||
|
|
||||||
testVector :: (ByteString, Text, Text) -> Assertion
|
testVector :: (ByteString, Text, Text) -> Assertion
|
||||||
testVector (bs, e, chk) = do
|
testVector (bs, e, chk) = do
|
||||||
assertEqual "encodeBase58" e b58
|
assertEqual "encodeBase58" e b58
|
||||||
assertEqual "encodeBase58Check" chk b58Chk
|
assertEqual "encodeBase58Check" chk b58Chk
|
||||||
assertEqual "decodeBase58" (Just bs) (decodeBase58 b58)
|
assertEqual "decodeBase58" (Just bs) (decodeBase58 b58)
|
||||||
assertEqual "decodeBase58Check" (Just bs) (decodeBase58Check b58Chk)
|
assertEqual "decodeBase58Check" (Just bs) (decodeBase58Check b58Chk)
|
||||||
where
|
where
|
||||||
b58 = encodeBase58 bs
|
b58 = encodeBase58 bs
|
||||||
b58Chk = encodeBase58Check bs
|
b58Chk = encodeBase58Check bs
|
||||||
|
|
||||||
vectors :: [(ByteString, Text, Text)]
|
vectors :: [(ByteString, Text, Text)]
|
||||||
vectors =
|
vectors =
|
||||||
[ (BS.empty, "", "3QJmnh")
|
[ (B.empty, "", "3QJmnh"),
|
||||||
, (BS.pack [0], "1", "1Wh4bh")
|
(B.pack [0], "1", "1Wh4bh"),
|
||||||
, (BS.pack [0, 0, 0, 0], "1111", "11114bdQda")
|
(B.pack [0, 0, 0, 0], "1111", "11114bdQda"),
|
||||||
, (BS.pack [0, 0, 1, 0, 0], "11LUw", "113CUwsFVuo")
|
(B.pack [0, 0, 1, 0, 0], "11LUw", "113CUwsFVuo"),
|
||||||
, (BS.pack [255], "5Q", "VrZDWwe")
|
(B.pack [255], "5Q", "VrZDWwe"),
|
||||||
,
|
( B.pack [0, 0, 0, 0] `B.append` B.pack [1 .. 255],
|
||||||
( BS.pack [0, 0, 0, 0] `BS.append` BS.pack [1 .. 255]
|
"1111cWB5HCBdLjAuqGGReWE3R3CguuwSjw6RHn39s2yuDRTS5N\
|
||||||
, "1111cWB5HCBdLjAuqGGReWE3R3CguuwSjw6RHn39s2yuDRTS5N\
|
\sBgNiFpWgAnEx6VQi8csexkgYw3mdYrMHr8x9i7aEwP8kZ7vcc\
|
||||||
\sBgNiFpWgAnEx6VQi8csexkgYw3mdYrMHr8x9i7aEwP8kZ7vcc\
|
\XWqKDvGv3u1GxFKPuAkn8JCPPGDMf3vMMnbzm6Nh9zh1gcNsMv\
|
||||||
\XWqKDvGv3u1GxFKPuAkn8JCPPGDMf3vMMnbzm6Nh9zh1gcNsMv\
|
\H3ZNLmP5fSG6DGbbi2tuwMWPthr4boWwCxf7ewSgNQeacyozhK\
|
||||||
\H3ZNLmP5fSG6DGbbi2tuwMWPthr4boWwCxf7ewSgNQeacyozhK\
|
\DDQQ1qL5fQFUW52QKUZDZ5fw3KXNQJMcNTcaB723LchjeKun7M\
|
||||||
\DDQQ1qL5fQFUW52QKUZDZ5fw3KXNQJMcNTcaB723LchjeKun7M\
|
\uGW5qyCBZYzA1KjofN1gYBV3NqyhQJ3Ns746GNuf9N2pQPmHz4\
|
||||||
\uGW5qyCBZYzA1KjofN1gYBV3NqyhQJ3Ns746GNuf9N2pQPmHz4\
|
\xpnSrrfCvy6TVVz5d4PdrjeshsWQwpZsZGzvbdAdN8MKV5QsBDY",
|
||||||
\xpnSrrfCvy6TVVz5d4PdrjeshsWQwpZsZGzvbdAdN8MKV5QsBDY"
|
"111151KWPPBRzdWPr1ASeu172gVgLf1YfUp6VJyk6K9t4cLqYt\
|
||||||
, "111151KWPPBRzdWPr1ASeu172gVgLf1YfUp6VJyk6K9t4cLqYt\
|
\FHcMa2iX8S3NJEprUcW7W5LvaPRpz7UG7puBj5STE3nKhCGt5e\
|
||||||
\FHcMa2iX8S3NJEprUcW7W5LvaPRpz7UG7puBj5STE3nKhCGt5e\
|
\ckYq7mMn5nT7oTTic2BAX6zDdqrmGCnkszQkzkz8e5QLGDjf7K\
|
||||||
\ckYq7mMn5nT7oTTic2BAX6zDdqrmGCnkszQkzkz8e5QLGDjf7K\
|
\eQgtEDm4UER6DMSdBjFQVa6cHrrJn9myVyyhUrsVnfUk2WmNFZ\
|
||||||
\eQgtEDm4UER6DMSdBjFQVa6cHrrJn9myVyyhUrsVnfUk2WmNFZ\
|
\vkWv3Tnvzo2cJ1xW62XDfUgYz1pd97eUGGPuXvDFfLsBVd1dfd\
|
||||||
\vkWv3Tnvzo2cJ1xW62XDfUgYz1pd97eUGGPuXvDFfLsBVd1dfd\
|
\UhPwxW7pMPgdWHTmg5uqKGFF6vE4xXpAqZTbTxRZjCDdTn68c2\
|
||||||
\UhPwxW7pMPgdWHTmg5uqKGFF6vE4xXpAqZTbTxRZjCDdTn68c2\
|
\wrcxApm8hq3JX65Hix7VtcD13FF8b7BzBtwjXq1ze6NMjKgUcq\
|
||||||
\wrcxApm8hq3JX65Hix7VtcD13FF8b7BzBtwjXq1ze6NMjKgUcq\
|
\pJTN9vt"
|
||||||
\pJTN9vt"
|
)
|
||||||
)
|
]
|
||||||
]
|
|
||||||
|
|
||||||
-- Test vectors from:
|
-- Test vectors from:
|
||||||
-- https://github.com/bitcoin/bitcoin/blob/master/src/test/data/base58_encode_decode.json
|
-- https://github.com/bitcoin/bitcoin/blob/master/src/test/data/base58_encode_decode.json
|
||||||
|
|
||||||
testBase58Vector :: (Text, Text) -> Assertion
|
testBase58Vector :: (Text, Text) -> Assertion
|
||||||
testBase58Vector (a, b) = do
|
testBase58Vector (a, b) = do
|
||||||
assertEqual "encodeBase58 match" b (encodeBase58 bsA)
|
assertEqual "encodeBase58 match" b (encodeBase58 bsA)
|
||||||
assertEqual "decodeBase58 match" a (encodeHex bsB)
|
assertEqual "decodeBase58 match" a (encodeHex bsB)
|
||||||
assertEqual "bytestring match" bsA bsB
|
assertEqual "bytestring match" bsA bsB
|
||||||
where
|
where
|
||||||
bsA = fromJust $ decodeHex a
|
bsA = fromJust $ decodeHex a
|
||||||
bsB = fromJust $ decodeBase58 b
|
bsB = fromJust $ decodeBase58 b
|
||||||
|
|
||||||
base58Vectors :: [(Text, Text)]
|
base58Vectors :: [(Text, Text)]
|
||||||
base58Vectors =
|
base58Vectors =
|
||||||
[ ("", "")
|
[ ("", ""),
|
||||||
, ("61", "2g")
|
("61", "2g"),
|
||||||
, ("626262", "a3gV")
|
("626262", "a3gV"),
|
||||||
, ("636363", "aPEr")
|
("636363", "aPEr"),
|
||||||
,
|
( "73696d706c792061206c6f6e6720737472696e67",
|
||||||
( "73696d706c792061206c6f6e6720737472696e67"
|
"2cFupjhnEsSn59qHXstmK2ffpLv2"
|
||||||
, "2cFupjhnEsSn59qHXstmK2ffpLv2"
|
),
|
||||||
)
|
( "00eb15231dfceb60925886b67d065299925915aeb172c06647",
|
||||||
,
|
"1NS17iag9jJgTHD1VXjvLCEnZuQ3rJDE9L"
|
||||||
( "00eb15231dfceb60925886b67d065299925915aeb172c06647"
|
),
|
||||||
, "1NS17iag9jJgTHD1VXjvLCEnZuQ3rJDE9L"
|
("516b6fcd0f", "ABnLTmg"),
|
||||||
)
|
("bf4f89001e670274dd", "3SEo3LWLoPntC"),
|
||||||
, ("516b6fcd0f", "ABnLTmg")
|
("572e4794", "3EFU7m"),
|
||||||
, ("bf4f89001e670274dd", "3SEo3LWLoPntC")
|
("ecac89cad93923c02321", "EJDM8drfXA6uyA"),
|
||||||
, ("572e4794", "3EFU7m")
|
("10c8511e", "Rt5zm"),
|
||||||
, ("ecac89cad93923c02321", "EJDM8drfXA6uyA")
|
("00000000000000000000", "1111111111"),
|
||||||
, ("10c8511e", "Rt5zm")
|
( "000111d38e5fc9071ffcd20b4a763cc9ae4f252bb4e48fd66a835e252a\
|
||||||
, ("00000000000000000000", "1111111111")
|
\da93ff480d6dd43dc62a641155a5",
|
||||||
,
|
"123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
|
||||||
( "000111d38e5fc9071ffcd20b4a763cc9ae4f252bb4e48fd66a835e252a\
|
),
|
||||||
\da93ff480d6dd43dc62a641155a5"
|
( "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c\
|
||||||
, "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
|
\1d1e1f202122232425262728292a2b2c2d2e2f30313233343536373839\
|
||||||
)
|
\3a3b3c3d3e3f404142434445464748494a4b4c4d4e4f50515253545556\
|
||||||
,
|
\5758595a5b5c5d5e5f606162636465666768696a6b6c6d6e6f70717273\
|
||||||
( "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c\
|
\7475767778797a7b7c7d7e7f808182838485868788898a8b8c8d8e8f90\
|
||||||
\1d1e1f202122232425262728292a2b2c2d2e2f30313233343536373839\
|
\9192939495969798999a9b9c9d9e9fa0a1a2a3a4a5a6a7a8a9aaabacad\
|
||||||
\3a3b3c3d3e3f404142434445464748494a4b4c4d4e4f50515253545556\
|
\aeafb0b1b2b3b4b5b6b7b8b9babbbcbdbebfc0c1c2c3c4c5c6c7c8c9ca\
|
||||||
\5758595a5b5c5d5e5f606162636465666768696a6b6c6d6e6f70717273\
|
\cbcccdcecfd0d1d2d3d4d5d6d7d8d9dadbdcdddedfe0e1e2e3e4e5e6e7\
|
||||||
\7475767778797a7b7c7d7e7f808182838485868788898a8b8c8d8e8f90\
|
\e8e9eaebecedeeeff0f1f2f3f4f5f6f7f8f9fafbfcfdfeff",
|
||||||
\9192939495969798999a9b9c9d9e9fa0a1a2a3a4a5a6a7a8a9aaabacad\
|
"1cWB5HCBdLjAuqGGReWE3R3CguuwSjw6RHn39s2yuDRTS5NsBgNiFpWgAn\
|
||||||
\aeafb0b1b2b3b4b5b6b7b8b9babbbcbdbebfc0c1c2c3c4c5c6c7c8c9ca\
|
\Ex6VQi8csexkgYw3mdYrMHr8x9i7aEwP8kZ7vccXWqKDvGv3u1GxFKPuAk\
|
||||||
\cbcccdcecfd0d1d2d3d4d5d6d7d8d9dadbdcdddedfe0e1e2e3e4e5e6e7\
|
\n8JCPPGDMf3vMMnbzm6Nh9zh1gcNsMvH3ZNLmP5fSG6DGbbi2tuwMWPthr\
|
||||||
\e8e9eaebecedeeeff0f1f2f3f4f5f6f7f8f9fafbfcfdfeff"
|
\4boWwCxf7ewSgNQeacyozhKDDQQ1qL5fQFUW52QKUZDZ5fw3KXNQJMcNTc\
|
||||||
, "1cWB5HCBdLjAuqGGReWE3R3CguuwSjw6RHn39s2yuDRTS5NsBgNiFpWgAn\
|
\aB723LchjeKun7MuGW5qyCBZYzA1KjofN1gYBV3NqyhQJ3Ns746GNuf9N2\
|
||||||
\Ex6VQi8csexkgYw3mdYrMHr8x9i7aEwP8kZ7vccXWqKDvGv3u1GxFKPuAk\
|
\pQPmHz4xpnSrrfCvy6TVVz5d4PdrjeshsWQwpZsZGzvbdAdN8MKV5QsBDY"
|
||||||
\n8JCPPGDMf3vMMnbzm6Nh9zh1gcNsMvH3ZNLmP5fSG6DGbbi2tuwMWPthr\
|
)
|
||||||
\4boWwCxf7ewSgNQeacyozhKDDQQ1qL5fQFUW52QKUZDZ5fw3KXNQJMcNTc\
|
]
|
||||||
\aB723LchjeKun7MuGW5qyCBZYzA1KjofN1gYBV3NqyhQJ3Ns746GNuf9N2\
|
|
||||||
\pQPmHz4xpnSrrfCvy6TVVz5d4PdrjeshsWQwpZsZGzvbdAdN8MKV5QsBDY"
|
|
||||||
)
|
|
||||||
]
|
|
||||||
|
|
||||||
-- Test vectors from:
|
-- Test vectors from:
|
||||||
-- https://github.com/bitcoin/bitcoin/blob/master/src/test/base58_tests.cpp
|
-- https://github.com/bitcoin/bitcoin/blob/master/src/test/base58_tests.cpp
|
||||||
|
|
||||||
testBase58InvalidVector :: (Text, Maybe Text) -> Assertion
|
testBase58InvalidVector :: (Text, Maybe Text) -> Assertion
|
||||||
testBase58InvalidVector (a, resM) =
|
testBase58InvalidVector (a, resM) =
|
||||||
assertEqual "decodeBase58 invalid match" resM (encodeHex <$> decodeBase58 a)
|
assertEqual "decodeBase58 invalid match" resM (encodeHex <$> decodeBase58 a)
|
||||||
|
|
||||||
base58InvalidVectors :: [(Text, Maybe Text)]
|
base58InvalidVectors :: [(Text, Maybe Text)]
|
||||||
base58InvalidVectors =
|
base58InvalidVectors =
|
||||||
[ ("invalid", Nothing)
|
[ ("invalid", Nothing),
|
||||||
, ("\0invalid", Nothing)
|
("\0invalid", Nothing),
|
||||||
, ("good", Just "768320")
|
("good", Just "768320"),
|
||||||
, ("bad0IOl", Nothing)
|
("bad0IOl", Nothing),
|
||||||
, ("goodbad0IOl", Nothing)
|
("goodbad0IOl", Nothing),
|
||||||
, ("good\0bad0IOl", Nothing)
|
("good\0bad0IOl", Nothing)
|
||||||
-- Haskoin does not remove white spaces before decoding base58 strings
|
-- 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 a", Nothing)
|
||||||
-- , (" \t\n\v\f\r skip \r\f\v\n\t ", Just "971a55")
|
-- , (" \t\n\v\f\r skip \r\f\v\n\t ", Just "971a55")
|
||||||
]
|
]
|
||||||
|
|
||||||
testBase58ChkInvalidVector :: (Text, Maybe Text) -> Assertion
|
testBase58ChkInvalidVector :: (Text, Maybe Text) -> Assertion
|
||||||
testBase58ChkInvalidVector (a, resM) =
|
testBase58ChkInvalidVector (a, resM) =
|
||||||
assertEqual
|
assertEqual
|
||||||
"decodeBase58Check invalid match"
|
"decodeBase58Check invalid match"
|
||||||
resM
|
resM
|
||||||
(encodeHex <$> decodeBase58Check a)
|
(encodeHex <$> decodeBase58Check a)
|
||||||
|
|
||||||
base58ChkInvalidVectors :: [(Text, Maybe Text)]
|
base58ChkInvalidVectors :: [(Text, Maybe Text)]
|
||||||
base58ChkInvalidVectors =
|
base58ChkInvalidVectors =
|
||||||
[ ("3vQB7B6MrGQZaxCuFg4oh", Just "68656c6c6f20776f726c64")
|
[ ("3vQB7B6MrGQZaxCuFg4oh", Just "68656c6c6f20776f726c64"),
|
||||||
, ("3vQB7B6MrGQZaxCuFg4oi", Nothing)
|
("3vQB7B6MrGQZaxCuFg4oi", Nothing),
|
||||||
, ("3vQB7B6MrGQZaxCuFg4oh0IOl", Nothing)
|
("3vQB7B6MrGQZaxCuFg4oh0IOl", Nothing),
|
||||||
, ("3vQB7B6MrGQZaxCuFg4oh\00IOl", Nothing)
|
("3vQB7B6MrGQZaxCuFg4oh\00IOl", Nothing)
|
||||||
]
|
]
|
||||||
|
|
||||||
testCompatWitnessVector :: (Network, Text, Text) -> Assertion
|
testCompatWitnessVector :: Ctx -> (Network, Text, Text) -> Assertion
|
||||||
testCompatWitnessVector (net, seckey, addr) = do
|
testCompatWitnessVector ctx (net, seckey, addr) = do
|
||||||
let seckeyM = fromWif net seckey
|
let seckeyM = fromWif net seckey
|
||||||
assertBool "decode seckey" (isJust seckeyM)
|
assertBool "decode seckey" (isJust seckeyM)
|
||||||
let pubkey = derivePubKeyI (fromJust seckeyM)
|
let pubkey = derivePublicKey ctx (fromJust seckeyM)
|
||||||
let addrM = addrToText btcTest (pubKeyCompatWitnessAddr pubkey)
|
let addrM = addrToText btcTest (pubKeyCompatWitnessAddr ctx pubkey)
|
||||||
assertBool "address can be encoded" (isJust addrM)
|
assertBool "address can be encoded" (isJust addrM)
|
||||||
assertEqual "witness address matches" addr (fromJust addrM)
|
assertEqual "witness address matches" addr (fromJust addrM)
|
||||||
|
|
||||||
compatWitnessVectors :: [(Network, Text, Text)]
|
compatWitnessVectors :: [(Network, Text, Text)]
|
||||||
compatWitnessVectors =
|
compatWitnessVectors =
|
||||||
[
|
[ ( btcTest,
|
||||||
( btcTest
|
"cNUnpYpMsJXYCERYBciJnsWBpcYEFjdcbq6dxj4SskGhs7uHuJ7Q",
|
||||||
, "cNUnpYpMsJXYCERYBciJnsWBpcYEFjdcbq6dxj4SskGhs7uHuJ7Q"
|
"2N6PDTueBHvXzW61B4oe5SW1D3v2Z3Vpbvw"
|
||||||
, "2N6PDTueBHvXzW61B4oe5SW1D3v2Z3Vpbvw"
|
)
|
||||||
)
|
]
|
||||||
]
|
|
||||||
|
@ -1,8 +1,11 @@
|
|||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Haskoin.BlockSpec (
|
module Haskoin.BlockSpec
|
||||||
spec,
|
( spec,
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Monad.State.Strict
|
import Control.Monad.State.Strict
|
||||||
import Data.Either (fromRight)
|
import Data.Either (fromRight)
|
||||||
@ -12,9 +15,11 @@ import Data.String.Conversions (cs)
|
|||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Word (Word32)
|
import Data.Word (Word32)
|
||||||
import Haskoin.Block
|
import Haskoin.Block
|
||||||
import Haskoin.Constants
|
import Haskoin.Crypto
|
||||||
import Haskoin.Data
|
import Haskoin.Network.Constants
|
||||||
|
import Haskoin.Network.Data
|
||||||
import Haskoin.Transaction
|
import Haskoin.Transaction
|
||||||
|
import Haskoin.Util
|
||||||
import Haskoin.Util.Arbitrary
|
import Haskoin.Util.Arbitrary
|
||||||
import Test.HUnit hiding (State)
|
import Test.HUnit hiding (State)
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
@ -22,36 +27,36 @@ import Test.Hspec.QuickCheck
|
|||||||
import Test.QuickCheck
|
import Test.QuickCheck
|
||||||
import Text.Printf (printf)
|
import Text.Printf (printf)
|
||||||
|
|
||||||
serialVals :: [SerialBox]
|
serialVals :: Ctx -> [SerialBox]
|
||||||
serialVals =
|
serialVals ctx =
|
||||||
[ SerialBox (arbitraryBlock =<< arbitraryNetwork)
|
[ SerialBox (flip arbitraryBlock ctx =<< arbitraryNetwork),
|
||||||
, SerialBox arbitraryBlockHash
|
SerialBox arbitraryBlockHash,
|
||||||
, SerialBox arbitraryBlockHeader
|
SerialBox arbitraryBlockHeader,
|
||||||
, SerialBox arbitraryGetBlocks
|
SerialBox arbitraryGetBlocks,
|
||||||
, SerialBox arbitraryGetHeaders
|
SerialBox arbitraryGetHeaders,
|
||||||
, SerialBox arbitraryHeaders
|
SerialBox arbitraryHeaders,
|
||||||
, SerialBox arbitraryMerkleBlock
|
SerialBox arbitraryMerkleBlock,
|
||||||
, SerialBox arbitraryBlockNode
|
SerialBox arbitraryBlockNode
|
||||||
]
|
]
|
||||||
|
|
||||||
readVals :: [ReadBox]
|
readVals :: Ctx -> [ReadBox]
|
||||||
readVals =
|
readVals ctx =
|
||||||
[ ReadBox (arbitraryBlock =<< arbitraryNetwork)
|
[ ReadBox (flip arbitraryBlock ctx =<< arbitraryNetwork),
|
||||||
, ReadBox arbitraryBlockHash
|
ReadBox arbitraryBlockHash,
|
||||||
, ReadBox arbitraryBlockHeader
|
ReadBox arbitraryBlockHeader,
|
||||||
, ReadBox arbitraryGetBlocks
|
ReadBox arbitraryGetBlocks,
|
||||||
, ReadBox arbitraryGetHeaders
|
ReadBox arbitraryGetHeaders,
|
||||||
, ReadBox arbitraryHeaders
|
ReadBox arbitraryHeaders,
|
||||||
, ReadBox arbitraryMerkleBlock
|
ReadBox arbitraryMerkleBlock,
|
||||||
, ReadBox arbitraryBlockNode
|
ReadBox arbitraryBlockNode
|
||||||
]
|
]
|
||||||
|
|
||||||
jsonVals :: [JsonBox]
|
jsonVals :: Ctx -> [JsonBox]
|
||||||
jsonVals =
|
jsonVals ctx =
|
||||||
[ JsonBox (arbitraryBlock =<< arbitraryNetwork)
|
[ JsonBox (flip arbitraryBlock ctx =<< arbitraryNetwork),
|
||||||
, JsonBox arbitraryBlockHash
|
JsonBox arbitraryBlockHash,
|
||||||
, JsonBox arbitraryBlockHeader
|
JsonBox arbitraryBlockHeader
|
||||||
]
|
]
|
||||||
|
|
||||||
myTime :: Timestamp
|
myTime :: Timestamp
|
||||||
myTime = 1499083075
|
myTime = 1499083075
|
||||||
@ -59,66 +64,66 @@ myTime = 1499083075
|
|||||||
withChain :: Network -> State HeaderMemory a -> a
|
withChain :: Network -> State HeaderMemory a -> a
|
||||||
withChain net f = evalState f (initialChain net)
|
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
|
chain net bh i = do
|
||||||
bnsE <- connectBlocks net myTime bhs
|
bnsE <- connectBlocks net myTime bhs
|
||||||
either error (const $ return ()) bnsE
|
either error (const $ return ()) bnsE
|
||||||
where
|
where
|
||||||
bhs = appendBlocks net 6 bh i
|
bhs = appendBlocks net 6 bh i
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = do
|
spec = prepareContext $ \ctx -> do
|
||||||
testIdentity serialVals readVals jsonVals []
|
testIdentity (serialVals ctx) (readVals ctx) (jsonVals ctx) []
|
||||||
describe "blockchain headers" $ do
|
describe "blockchain headers" $ do
|
||||||
it "gets best block on bchRegTest" $
|
it "gets best block on bchRegTest" $
|
||||||
let net = bchRegTest
|
let net = bchRegTest
|
||||||
bb =
|
bb =
|
||||||
withChain net $ do
|
withChain net $ do
|
||||||
chain net (getGenesisHeader net) 100
|
chain net net.genesisHeader 100
|
||||||
getBestBlockHeader
|
getBestBlockHeader
|
||||||
in nodeHeight bb `shouldBe` 100
|
in bb.height `shouldBe` 100
|
||||||
it "builds a block locator on bchRegTest" $
|
it "builds a block locator on bchRegTest" $
|
||||||
let net = bchRegTest
|
let net = bchRegTest
|
||||||
loc =
|
loc =
|
||||||
withChain net $ do
|
withChain net $ do
|
||||||
chain net (getGenesisHeader net) 100
|
chain net net.genesisHeader 100
|
||||||
bb <- getBestBlockHeader
|
bb <- getBestBlockHeader
|
||||||
blockLocatorNodes bb
|
blockLocatorNodes bb
|
||||||
heights = map nodeHeight loc
|
heights = map (.height) loc
|
||||||
in heights `shouldBe` [100, 99 .. 90] <> [88, 84, 76, 60, 28, 0]
|
in heights `shouldBe` [100, 99 .. 90] <> [88, 84, 76, 60, 28, 0]
|
||||||
it "follows split chains on bchRegTest" $
|
it "follows split chains on bchRegTest" $
|
||||||
let net = bchRegTest
|
let net = bchRegTest
|
||||||
bb = withChain net $ splitChain net >> getBestBlockHeader
|
bb = withChain net $ splitChain net >> getBestBlockHeader
|
||||||
in nodeHeight bb `shouldBe` 4035
|
in bb.height `shouldBe` 4035
|
||||||
describe "block hash" $ do
|
describe "block hash" $ do
|
||||||
prop "encodes and decodes block hash" $
|
prop "encodes and decodes block hash" $
|
||||||
forAll arbitraryBlockHash $ \h ->
|
forAll arbitraryBlockHash $ \h ->
|
||||||
hexToBlockHash (blockHashToHex h) == Just h
|
hexToBlockHash (blockHashToHex h) == Just h
|
||||||
prop "from string block hash" $
|
prop "from string block hash" $
|
||||||
forAll arbitraryBlockHash $ \h ->
|
forAll arbitraryBlockHash $ \h ->
|
||||||
fromString (cs $ blockHashToHex h) == h
|
fromString (cs $ blockHashToHex h) == h
|
||||||
describe "merkle trees" $ do
|
describe "merkle trees" $ do
|
||||||
prop "builds tree of right width at height 1" testTreeWidth
|
prop "builds tree of right width at height 1" testTreeWidth
|
||||||
prop "builds tree of right width at height 0" testBaseWidth
|
prop "builds tree of right width at height 0" testBaseWidth
|
||||||
prop "builds and extracts partial merkle tree" $
|
prop "builds and extracts partial merkle tree" $
|
||||||
forAll arbitraryNetwork $ \net ->
|
forAll arbitraryNetwork $ \net ->
|
||||||
forAll
|
forAll
|
||||||
(listOf1 ((,) <$> arbitraryTxHash <*> arbitrary))
|
(listOf1 ((,) <$> arbitraryTxHash <*> arbitrary))
|
||||||
(buildExtractTree net)
|
(buildExtractTree net)
|
||||||
it "merkle root test vectors" $ mapM_ runMerkleVector merkleVectors
|
it "merkle root test vectors" $ mapM_ runMerkleVector merkleVectors
|
||||||
describe "compact number" $ do
|
describe "compact number" $ do
|
||||||
it "compact number local vectors" testCompact
|
it "compact number local vectors" testCompact
|
||||||
it "compact number imported vectors" testCompactBitcoinCore
|
it "compact number imported vectors" testCompactBitcoinCore
|
||||||
describe "asert" $
|
describe "asert" $
|
||||||
mapM_
|
mapM_
|
||||||
( \x ->
|
( \x ->
|
||||||
asertTests $
|
asertTests $
|
||||||
"test_vectors_aserti3-2d_run" ++ printf "%02d" x ++ ".txt"
|
"test_vectors_aserti3-2d_run" ++ printf "%02d" x ++ ".txt"
|
||||||
)
|
)
|
||||||
[(1 :: Int) .. 12]
|
[(1 :: Int) .. 12]
|
||||||
describe "helper functions" $ do
|
describe "helper functions" $ do
|
||||||
it "computes bitcoin block subsidy correctly" (testSubsidy btc)
|
it "computes bitcoin block subsidy correctly" (testSubsidy btc)
|
||||||
it "computes regtest block subsidy correctly" (testSubsidy btcRegTest)
|
it "computes regtest block subsidy correctly" (testSubsidy btcRegTest)
|
||||||
|
|
||||||
-- 0 → → 2015 → → → → → → → 4031
|
-- 0 → → 2015 → → → → → → → 4031
|
||||||
-- ↓
|
-- ↓
|
||||||
@ -127,40 +132,40 @@ spec = do
|
|||||||
-- → → 2185
|
-- → → 2185
|
||||||
splitChain :: Network -> State HeaderMemory ()
|
splitChain :: Network -> State HeaderMemory ()
|
||||||
splitChain net = do
|
splitChain net = do
|
||||||
start <- go 1 (getGenesisHeader net) 2015
|
start <- go 1 net.genesisHeader 2015
|
||||||
e 2015 (head start)
|
e 2015 (head start)
|
||||||
tail1 <- go 2 (nodeHeader $ head start) 2016
|
tail1 <- go 2 (head start).header 2016
|
||||||
e 4031 (head tail1)
|
e 4031 (head tail1)
|
||||||
tail2 <- go 3 (nodeHeader $ head start) 20
|
tail2 <- go 3 (head start).header 20
|
||||||
e 2035 (head tail2)
|
e 2035 (head tail2)
|
||||||
tail3 <- go 4 (nodeHeader $ head tail2) 2000
|
tail3 <- go 4 (head tail2).header 2000
|
||||||
e 4035 (head tail3)
|
e 4035 (head tail3)
|
||||||
tail4 <- go 5 (nodeHeader $ head tail2) 150
|
tail4 <- go 5 (head tail2).header 150
|
||||||
e 2185 (head tail4)
|
e 2185 (head tail4)
|
||||||
sp1 <- splitPoint (head tail1) (head tail3)
|
sp1 <- splitPoint (head tail1) (head tail3)
|
||||||
unless (sp1 == head start) $
|
unless (sp1 == head start) $
|
||||||
error $
|
error $
|
||||||
"Split point wrong between blocks 4031 and 4035: "
|
"Split point wrong between blocks 4031 and 4035: "
|
||||||
++ show (nodeHeight sp1)
|
++ show sp1.height
|
||||||
sp2 <- splitPoint (head tail4) (head tail3)
|
sp2 <- splitPoint (head tail4) (head tail3)
|
||||||
unless (sp2 == head tail2) $
|
unless (sp2 == head tail2) $
|
||||||
error $
|
error $
|
||||||
"Split point wrong between blocks 2185 and 4035: "
|
"Split point wrong between blocks 2185 and 4035: "
|
||||||
++ show (nodeHeight sp2)
|
++ show sp2.height
|
||||||
where
|
where
|
||||||
e n bn =
|
e n bn@BlockNode {} =
|
||||||
unless (nodeHeight bn == n) $
|
unless (bn.height == n) $
|
||||||
error $
|
error $
|
||||||
"Node height "
|
"Node height "
|
||||||
++ show (nodeHeight bn)
|
++ show bn.height
|
||||||
++ " of first chunk should be "
|
++ " of first chunk should be "
|
||||||
++ show n
|
++ show n
|
||||||
go seed start n = do
|
go seed start n = do
|
||||||
let bhs = appendBlocks net seed start n
|
let bhs = appendBlocks net seed start n
|
||||||
bnE <- connectBlocks net myTime bhs
|
bnE <- connectBlocks net myTime bhs
|
||||||
case bnE of
|
case bnE of
|
||||||
Right bn -> return bn
|
Right bn -> return bn
|
||||||
Left ex -> error ex
|
Left ex -> error ex
|
||||||
|
|
||||||
{- Merkle Trees -}
|
{- Merkle Trees -}
|
||||||
|
|
||||||
@ -172,214 +177,208 @@ testBaseWidth i = i /= 0 ==> calcTreeWidth (abs i) 0 == abs i
|
|||||||
|
|
||||||
buildExtractTree :: Network -> [(TxHash, Bool)] -> Bool
|
buildExtractTree :: Network -> [(TxHash, Bool)] -> Bool
|
||||||
buildExtractTree net txs =
|
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
|
where
|
||||||
(f, h) = buildPartialMerkle txs
|
(f, h) = buildPartialMerkle txs
|
||||||
(r, m) =
|
(r, m) =
|
||||||
fromRight (error "Could not extract matches from Merkle tree") $
|
fromRight (error "Could not extract matches from Merkle tree") $
|
||||||
extractMatches net f h (length txs)
|
extractMatches net f h (length txs)
|
||||||
|
|
||||||
testCompact :: Assertion
|
testCompact :: Assertion
|
||||||
testCompact = do
|
testCompact = do
|
||||||
assertEqual "vector 1" 0x05123456 (encodeCompact 0x1234560000)
|
assertEqual "vector 1" 0x05123456 (encodeCompact 0x1234560000)
|
||||||
assertEqual "vector 2" (0x1234560000, False) (decodeCompact 0x05123456)
|
assertEqual "vector 2" (0x1234560000, False) (decodeCompact 0x05123456)
|
||||||
assertEqual "vector 3" 0x0600c0de (encodeCompact 0xc0de000000)
|
assertEqual "vector 3" 0x0600c0de (encodeCompact 0xc0de000000)
|
||||||
assertEqual "vector 4" (0xc0de000000, False) (decodeCompact 0x0600c0de)
|
assertEqual "vector 4" (0xc0de000000, False) (decodeCompact 0x0600c0de)
|
||||||
assertEqual "vector 5" 0x05c0de00 (encodeCompact (-0x40de000000))
|
assertEqual "vector 5" 0x05c0de00 (encodeCompact (-0x40de000000))
|
||||||
assertEqual "vector 6" (-0x40de000000, False) (decodeCompact 0x05c0de00)
|
assertEqual "vector 6" (-0x40de000000, False) (decodeCompact 0x05c0de00)
|
||||||
|
|
||||||
testCompactBitcoinCore :: Assertion
|
testCompactBitcoinCore :: Assertion
|
||||||
testCompactBitcoinCore = do
|
testCompactBitcoinCore = do
|
||||||
assertEqual "zero" (0, False) (decodeCompact 0x00000000)
|
assertEqual "zero" (0, False) (decodeCompact 0x00000000)
|
||||||
assertEqual
|
assertEqual
|
||||||
"zero (encode · decode)"
|
"zero (encode · decode)"
|
||||||
0x00000000
|
0x00000000
|
||||||
(encodeCompact . fst $ decodeCompact 0x00000000)
|
(encodeCompact . fst $ decodeCompact 0x00000000)
|
||||||
assertEqual "rounds to zero" (0, False) (decodeCompact 0x00123456)
|
assertEqual "rounds to zero" (0, False) (decodeCompact 0x00123456)
|
||||||
assertEqual "rounds to zero" (0, False) (decodeCompact 0x01003456)
|
assertEqual "rounds to zero" (0, False) (decodeCompact 0x01003456)
|
||||||
assertEqual "rounds to zero" (0, False) (decodeCompact 0x02000056)
|
assertEqual "rounds to zero" (0, False) (decodeCompact 0x02000056)
|
||||||
assertEqual "rounds to zero" (0, False) (decodeCompact 0x03000000)
|
assertEqual "rounds to zero" (0, False) (decodeCompact 0x03000000)
|
||||||
assertEqual "rounds to zero" (0, False) (decodeCompact 0x04000000)
|
assertEqual "rounds to zero" (0, False) (decodeCompact 0x04000000)
|
||||||
assertEqual "rounds to zero" (0, False) (decodeCompact 0x00923456)
|
assertEqual "rounds to zero" (0, False) (decodeCompact 0x00923456)
|
||||||
assertEqual "rounds to zero" (0, False) (decodeCompact 0x01803456)
|
assertEqual "rounds to zero" (0, False) (decodeCompact 0x01803456)
|
||||||
assertEqual "rounds to zero" (0, False) (decodeCompact 0x02800056)
|
assertEqual "rounds to zero" (0, False) (decodeCompact 0x02800056)
|
||||||
assertEqual "rounds to zero" (0, False) (decodeCompact 0x03800000)
|
assertEqual "rounds to zero" (0, False) (decodeCompact 0x03800000)
|
||||||
assertEqual "rounds to zero" (0, False) (decodeCompact 0x04800000)
|
assertEqual "rounds to zero" (0, False) (decodeCompact 0x04800000)
|
||||||
assertEqual "vector 1 (decode)" (0x12, False) (decodeCompact 0x01123456)
|
assertEqual "vector 1 (decode)" (0x12, False) (decodeCompact 0x01123456)
|
||||||
assertEqual
|
assertEqual
|
||||||
"vector 1 (encode · decode)"
|
"vector 1 (encode · decode)"
|
||||||
0x01120000
|
0x01120000
|
||||||
(encodeCompact . fst $ decodeCompact 0x01123456)
|
(encodeCompact . fst $ decodeCompact 0x01123456)
|
||||||
assertEqual "0x80 bit set" 0x02008000 (encodeCompact 0x80)
|
assertEqual "0x80 bit set" 0x02008000 (encodeCompact 0x80)
|
||||||
assertEqual
|
assertEqual
|
||||||
"vector 2 (negative) (decode)"
|
"vector 2 (negative) (decode)"
|
||||||
(-0x7e, False)
|
(-0x7e, False)
|
||||||
(decodeCompact 0x01fedcba)
|
(decodeCompact 0x01fedcba)
|
||||||
assertEqual
|
assertEqual
|
||||||
"vector 2 (negative) (encode · decode)"
|
"vector 2 (negative) (encode · decode)"
|
||||||
0x01fe0000
|
0x01fe0000
|
||||||
(encodeCompact . fst $ decodeCompact 0x01fedcba)
|
(encodeCompact . fst $ decodeCompact 0x01fedcba)
|
||||||
assertEqual "vector 3 (decode)" (0x1234, False) (decodeCompact 0x02123456)
|
assertEqual "vector 3 (decode)" (0x1234, False) (decodeCompact 0x02123456)
|
||||||
assertEqual
|
assertEqual
|
||||||
"vector 3 (encode · decode)"
|
"vector 3 (encode · decode)"
|
||||||
0x02123400
|
0x02123400
|
||||||
(encodeCompact . fst $ decodeCompact 0x02123456)
|
(encodeCompact . fst $ decodeCompact 0x02123456)
|
||||||
assertEqual "vector 4 (decode)" (0x123456, False) (decodeCompact 0x03123456)
|
assertEqual "vector 4 (decode)" (0x123456, False) (decodeCompact 0x03123456)
|
||||||
assertEqual
|
assertEqual
|
||||||
"vector 4 (encode · decode)"
|
"vector 4 (encode · decode)"
|
||||||
0x03123456
|
0x03123456
|
||||||
(encodeCompact . fst $ decodeCompact 0x03123456)
|
(encodeCompact . fst $ decodeCompact 0x03123456)
|
||||||
assertEqual
|
assertEqual
|
||||||
"vector 5 (decode)"
|
"vector 5 (decode)"
|
||||||
(0x12345600, False)
|
(0x12345600, False)
|
||||||
(decodeCompact 0x04123456)
|
(decodeCompact 0x04123456)
|
||||||
assertEqual
|
assertEqual
|
||||||
"vector 5 (encode · decode)"
|
"vector 5 (encode · decode)"
|
||||||
0x04123456
|
0x04123456
|
||||||
(encodeCompact . fst $ decodeCompact 0x04123456)
|
(encodeCompact . fst $ decodeCompact 0x04123456)
|
||||||
assertEqual
|
assertEqual
|
||||||
"vector 6 (decode)"
|
"vector 6 (decode)"
|
||||||
(-0x12345600, False)
|
(-0x12345600, False)
|
||||||
(decodeCompact 0x04923456)
|
(decodeCompact 0x04923456)
|
||||||
assertEqual
|
assertEqual
|
||||||
"vector 6 (encode · decode)"
|
"vector 6 (encode · decode)"
|
||||||
0x04923456
|
0x04923456
|
||||||
(encodeCompact . fst $ decodeCompact 0x04923456)
|
(encodeCompact . fst $ decodeCompact 0x04923456)
|
||||||
assertEqual
|
assertEqual
|
||||||
"vector 7 (decode)"
|
"vector 7 (decode)"
|
||||||
(0x92340000, False)
|
(0x92340000, False)
|
||||||
(decodeCompact 0x05009234)
|
(decodeCompact 0x05009234)
|
||||||
assertEqual
|
assertEqual
|
||||||
"vector 7 (encode · decode)"
|
"vector 7 (encode · decode)"
|
||||||
0x05009234
|
0x05009234
|
||||||
(encodeCompact . fst $ decodeCompact 0x05009234)
|
(encodeCompact . fst $ decodeCompact 0x05009234)
|
||||||
assertEqual
|
assertEqual
|
||||||
"vector 8 (decode)"
|
"vector 8 (decode)"
|
||||||
( 0x1234560000000000000000000000000000000000000000000000000000000000
|
( 0x1234560000000000000000000000000000000000000000000000000000000000,
|
||||||
, False
|
False
|
||||||
)
|
)
|
||||||
(decodeCompact 0x20123456)
|
(decodeCompact 0x20123456)
|
||||||
assertEqual
|
assertEqual
|
||||||
"vector 8 (encode · decode)"
|
"vector 8 (encode · decode)"
|
||||||
0x20123456
|
0x20123456
|
||||||
(encodeCompact . fst $ decodeCompact 0x20123456)
|
(encodeCompact . fst $ decodeCompact 0x20123456)
|
||||||
assertBool "vector 9 (decode) (overflow)" (snd $ decodeCompact 0xff123456)
|
assertBool "vector 9 (decode) (overflow)" (snd $ decodeCompact 0xff123456)
|
||||||
assertBool
|
assertBool
|
||||||
"vector 9 (decode) (positive)"
|
"vector 9 (decode) (positive)"
|
||||||
((> 0) . fst $ decodeCompact 0xff123456)
|
((> 0) . fst $ decodeCompact 0xff123456)
|
||||||
|
|
||||||
runMerkleVector :: (Text, [Text]) -> Assertion
|
runMerkleVector :: (Text, [Text]) -> Assertion
|
||||||
runMerkleVector (r, hs) =
|
runMerkleVector (r, hs) =
|
||||||
assertBool "merkle vector" $
|
assertBool "merkle vector" $
|
||||||
buildMerkleRoot (map f hs) == getTxHash (f r)
|
buildMerkleRoot (map f hs) == (f r).get
|
||||||
where
|
where
|
||||||
f = fromJust . hexToTxHash
|
f = fromJust . hexToTxHash
|
||||||
|
|
||||||
merkleVectors :: [(Text, [Text])]
|
merkleVectors :: [(Text, [Text])]
|
||||||
merkleVectors =
|
merkleVectors =
|
||||||
-- Block 000000000000cd7e8cf6510303dde76121a1a791c15dba0be4be7022b07cf9e1
|
-- Block 000000000000cd7e8cf6510303dde76121a1a791c15dba0be4be7022b07cf9e1
|
||||||
[
|
[ ( "fb6698ac95b754256c5e71b4fbe07638cb6ca83ee67f44e181b91727f09f4b1f",
|
||||||
( "fb6698ac95b754256c5e71b4fbe07638cb6ca83ee67f44e181b91727f09f4b1f"
|
[ "dd96fdcfaec994bf583af650ff6022980ee0ba1686d84d0a3a2d24eabf34bc52",
|
||||||
,
|
"1bc216f786a564378710ae589916fc8e092ddfb9f24fe6c47b733550d476d5d9",
|
||||||
[ "dd96fdcfaec994bf583af650ff6022980ee0ba1686d84d0a3a2d24eabf34bc52"
|
"a1db0b0194426064b067899ff2d975fb277fd52dbb1a38370800c76dd6503d41",
|
||||||
, "1bc216f786a564378710ae589916fc8e092ddfb9f24fe6c47b733550d476d5d9"
|
"d69f7fb0e668fbd437d1bf5211cc34d7eb8746f50cfddf705fe10bc2f8f7035f",
|
||||||
, "a1db0b0194426064b067899ff2d975fb277fd52dbb1a38370800c76dd6503d41"
|
"5b4057cd80be7df5ed2ac42b776897ed3c26e3a01e4072075b8129c587094ef6",
|
||||||
, "d69f7fb0e668fbd437d1bf5211cc34d7eb8746f50cfddf705fe10bc2f8f7035f"
|
"ed6dabcfba0ef43c50d89a8a0e4b236b1bc6585d4c3bbf49728b55f44312d6bc",
|
||||||
, "5b4057cd80be7df5ed2ac42b776897ed3c26e3a01e4072075b8129c587094ef6"
|
"056aaa9a3c635909c794e9b0acc7dccb0456c59a84c6b08417335bee4515e3d3",
|
||||||
, "ed6dabcfba0ef43c50d89a8a0e4b236b1bc6585d4c3bbf49728b55f44312d6bc"
|
"05bae5f1d1c874171692e1fc06f664e63eb143d3f096601ef938e4a9012eee66",
|
||||||
, "056aaa9a3c635909c794e9b0acc7dccb0456c59a84c6b08417335bee4515e3d3"
|
"b5e48e94e3f2fba197b3f591e01f47e185d7834d669529d44078e41c671aab0f",
|
||||||
, "05bae5f1d1c874171692e1fc06f664e63eb143d3f096601ef938e4a9012eee66"
|
"3b56aeadfc0c5484fd507bc89f13f2e5f61c42e0a4ae9062eda9a9aeef7db6a4",
|
||||||
, "b5e48e94e3f2fba197b3f591e01f47e185d7834d669529d44078e41c671aab0f"
|
"2affa187e1ebb94a2a86578b9f64951e854ff3d346fef259acfb6d0f5212e0d3"
|
||||||
, "3b56aeadfc0c5484fd507bc89f13f2e5f61c42e0a4ae9062eda9a9aeef7db6a4"
|
]
|
||||||
, "2affa187e1ebb94a2a86578b9f64951e854ff3d346fef259acfb6d0f5212e0d3"
|
),
|
||||||
]
|
-- Block 00000000000007cc4b6f07bfed72bccc1ed8dd031a93969a4c22211f784457d4
|
||||||
)
|
|
||||||
, -- Block 00000000000007cc4b6f07bfed72bccc1ed8dd031a93969a4c22211f784457d4
|
|
||||||
|
|
||||||
( "886fea311d2dc64c315519f2d647e43998d780d2170f77e53dc0d85bf2ee680c"
|
( "886fea311d2dc64c315519f2d647e43998d780d2170f77e53dc0d85bf2ee680c",
|
||||||
,
|
[ "c9c9e5211512629fd111cc071d745b8c79bf486b4ea95489eb5de08b5d786b8e",
|
||||||
[ "c9c9e5211512629fd111cc071d745b8c79bf486b4ea95489eb5de08b5d786b8e"
|
"20beb0ee30dfd323ade790ce9a46ae7a174f9ea44ce22a17c4d4eb23b7016f51",
|
||||||
, "20beb0ee30dfd323ade790ce9a46ae7a174f9ea44ce22a17c4d4eb23b7016f51"
|
"d4cb7dd741e78a8f57e12f6c8ddb0361ff2a5bf9365bd7d7df761060847daf9a",
|
||||||
, "d4cb7dd741e78a8f57e12f6c8ddb0361ff2a5bf9365bd7d7df761060847daf9a"
|
"ddbfa6fdd29d4b47aeaadf82a4bf0a93d58cd7d8401fabf860a1ae8eeb51f42e",
|
||||||
, "ddbfa6fdd29d4b47aeaadf82a4bf0a93d58cd7d8401fabf860a1ae8eeb51f42e"
|
"9d82bafe44abee248b968c86f165051c8413482c232659795335c52922dab471",
|
||||||
, "9d82bafe44abee248b968c86f165051c8413482c232659795335c52922dab471"
|
"86035372d31b53efd848cea7231aa9738c209aff64d3c59b1619341afb5b6ba3",
|
||||||
, "86035372d31b53efd848cea7231aa9738c209aff64d3c59b1619341afb5b6ba3"
|
"11e7a7393d9658813dfaebc04fa6d4b73bac8d641bffa7067da879523d43d030",
|
||||||
, "11e7a7393d9658813dfaebc04fa6d4b73bac8d641bffa7067da879523d43d030"
|
"2f676b9aa5bc0ebf3395032c84c466e40cac29f80434cd1138e31c2d0fcc5c13",
|
||||||
, "2f676b9aa5bc0ebf3395032c84c466e40cac29f80434cd1138e31c2d0fcc5c13"
|
"37567d559fbfae07fda9a90de0ce30b202128bc8ebdfef5ad2b53e865a3478c2",
|
||||||
, "37567d559fbfae07fda9a90de0ce30b202128bc8ebdfef5ad2b53e865a3478c2"
|
"0b8e6c1200c454361e94e261738429e9c9b8dcffd85ec8511bbf5dc7e2e0ada8"
|
||||||
, "0b8e6c1200c454361e94e261738429e9c9b8dcffd85ec8511bbf5dc7e2e0ada8"
|
]
|
||||||
]
|
),
|
||||||
)
|
-- Block 00000000839a8e6886ab5951d76f411475428afc90947ee320161bbf18eb6048
|
||||||
, -- Block 00000000839a8e6886ab5951d76f411475428afc90947ee320161bbf18eb6048
|
|
||||||
|
|
||||||
( "0e3e2357e806b6cdb1f70b54c3a3a17b6714ee1f0e68bebb44a74b1efd512098"
|
( "0e3e2357e806b6cdb1f70b54c3a3a17b6714ee1f0e68bebb44a74b1efd512098",
|
||||||
, ["0e3e2357e806b6cdb1f70b54c3a3a17b6714ee1f0e68bebb44a74b1efd512098"]
|
["0e3e2357e806b6cdb1f70b54c3a3a17b6714ee1f0e68bebb44a74b1efd512098"]
|
||||||
)
|
),
|
||||||
, -- Block 000000000004d160ac1f7b775d7c1823345aeadd5fcb29ca2ad2403bb7babd4c
|
-- Block 000000000004d160ac1f7b775d7c1823345aeadd5fcb29ca2ad2403bb7babd4c
|
||||||
|
|
||||||
( "aae018650f513fc42d55b2210ec3ceeeb194fb1261d37989de07451fc0cbac5c"
|
( "aae018650f513fc42d55b2210ec3ceeeb194fb1261d37989de07451fc0cbac5c",
|
||||||
,
|
[ "a4454f22831acd7904a9902c5070a3ee4bf4c2b13bc6b2dc66735dd3c4414028",
|
||||||
[ "a4454f22831acd7904a9902c5070a3ee4bf4c2b13bc6b2dc66735dd3c4414028"
|
"45297f334278885108dd38a0b689ed95a4373dd3f7e4413e6aebdc2654fb771b"
|
||||||
, "45297f334278885108dd38a0b689ed95a4373dd3f7e4413e6aebdc2654fb771b"
|
]
|
||||||
]
|
),
|
||||||
)
|
-- Block 000000000001d1b13a7e86ddb20da178f20d6da5cd037a29c2a15b8b84cc774e
|
||||||
, -- Block 000000000001d1b13a7e86ddb20da178f20d6da5cd037a29c2a15b8b84cc774e
|
|
||||||
|
|
||||||
( "ca3580505feb87544760ac14a5859659e23be05f765bbed9f86a3c9aad1a5d0c"
|
( "ca3580505feb87544760ac14a5859659e23be05f765bbed9f86a3c9aad1a5d0c",
|
||||||
,
|
[ "60702384c6e9d34ff03c2b3e726bdc649befe603216815bd0a2974921d0d9549",
|
||||||
[ "60702384c6e9d34ff03c2b3e726bdc649befe603216815bd0a2974921d0d9549"
|
"11f40f58941d2a81a1616a3b84b7dd8b9d07e68750827de488c11a18f54220bb",
|
||||||
, "11f40f58941d2a81a1616a3b84b7dd8b9d07e68750827de488c11a18f54220bb"
|
"d78e82527aa8cf16e375010bc666362c0258d3c0da1885a1871121706da8b633"
|
||||||
, "d78e82527aa8cf16e375010bc666362c0258d3c0da1885a1871121706da8b633"
|
]
|
||||||
]
|
),
|
||||||
)
|
-- Block 0000000000000630a4e2266a31776e952a19b7c99a6387917d9de9032f608021
|
||||||
, -- Block 0000000000000630a4e2266a31776e952a19b7c99a6387917d9de9032f608021
|
|
||||||
|
|
||||||
( "dcce8be0a9a41e7bb726c5b49d957d90b5308e3dc5dce070ccbc8996e265a6c2"
|
( "dcce8be0a9a41e7bb726c5b49d957d90b5308e3dc5dce070ccbc8996e265a6c2",
|
||||||
,
|
[ "c0f58ff12cd1023b05f8f7035cc62bf50958ddb216a4e0eb5471deb7ef25fe81",
|
||||||
[ "c0f58ff12cd1023b05f8f7035cc62bf50958ddb216a4e0eb5471deb7ef25fe81"
|
"24e5bbf9008641b8fcf3d076fef66c28c695362ba9f6a6042f8275a98414ee92",
|
||||||
, "24e5bbf9008641b8fcf3d076fef66c28c695362ba9f6a6042f8275a98414ee92"
|
"e8e1f72abad5e34dabc0f6de46a484b17a9af857d1c41de19482fadf6f7f4b27",
|
||||||
, "e8e1f72abad5e34dabc0f6de46a484b17a9af857d1c41de19482fadf6f7f4b27"
|
"540e4d34d9fd9e5ec02853054be7ad9260379bc23388489049cca1b0f7cf518a",
|
||||||
, "540e4d34d9fd9e5ec02853054be7ad9260379bc23388489049cca1b0f7cf518a"
|
"324444835c5fe0545f98c4240011b75e6ea1bb76f41829e4cfbe7f75b6cee924",
|
||||||
, "324444835c5fe0545f98c4240011b75e6ea1bb76f41829e4cfbe7f75b6cee924"
|
"e7d31437ac21bceb0c222a82b2723e2b8a7654147e33397679f041537022a4b2",
|
||||||
, "e7d31437ac21bceb0c222a82b2723e2b8a7654147e33397679f041537022a4b2"
|
"a8b5768d8b33525ee89d546a6a6897f8e42ba9d56a2c5e871a5d2ab40258dc95",
|
||||||
, "a8b5768d8b33525ee89d546a6a6897f8e42ba9d56a2c5e871a5d2ab40258dc95"
|
"7ba712b31bae8d45810a5cda3838c7e7fb9abd6e88bb4b3ee79be9ea2f714bb4",
|
||||||
, "7ba712b31bae8d45810a5cda3838c7e7fb9abd6e88bb4b3ee79be9ea2f714bb4"
|
"2ae1c4d927b06edaa626b230976ad8062bbae24da9378d1de2409da5ab08a26d",
|
||||||
, "2ae1c4d927b06edaa626b230976ad8062bbae24da9378d1de2409da5ab08a26d"
|
"3c417dc8087d6878003624b74431e17fec9ca761389034b1b1e0f32cbfb11f4f",
|
||||||
, "3c417dc8087d6878003624b74431e17fec9ca761389034b1b1e0f32cbfb11f4f"
|
"de6de7beae8d8c98c7d46b4409d5460e58e3204d8b4caed256c7471998595909",
|
||||||
, "de6de7beae8d8c98c7d46b4409d5460e58e3204d8b4caed256c7471998595909"
|
"c7c3c211402b7c4379f7b01fadc67260ee58d11e8d0bcce3d68cb45f3467e99d",
|
||||||
, "c7c3c211402b7c4379f7b01fadc67260ee58d11e8d0bcce3d68cb45f3467e99d"
|
"77aa2717e727a096d81074bd46ae59462692d20a1acc1a01b2535518ae5aeb53",
|
||||||
, "77aa2717e727a096d81074bd46ae59462692d20a1acc1a01b2535518ae5aeb53"
|
"4859a710bb673aca46208bbd59d1000ae990dafff5f70b56f0853aeeaea3948b",
|
||||||
, "4859a710bb673aca46208bbd59d1000ae990dafff5f70b56f0853aeeaea3948b"
|
"38deca6991988e461b83aa0d49ffef0f304c4b760371682d152eeb8c56a48174",
|
||||||
, "38deca6991988e461b83aa0d49ffef0f304c4b760371682d152eeb8c56a48174"
|
"648f4f50dada3574e2dfe2dc68956b01dd97d543859a3540bbe1ef5418d0e494",
|
||||||
, "648f4f50dada3574e2dfe2dc68956b01dd97d543859a3540bbe1ef5418d0e494"
|
"9cd7be42c2f0cd8bf38738c162cd05108e213ec7958bf2571cb627872963f5c4",
|
||||||
, "9cd7be42c2f0cd8bf38738c162cd05108e213ec7958bf2571cb627872963f5c4"
|
"6740e0dd8b97e23864af41839fc197238d2f0dbefce9a82c657556be65c465fa",
|
||||||
, "6740e0dd8b97e23864af41839fc197238d2f0dbefce9a82c657556be65c465fa"
|
"f75c2e4b70db4b0aabc44b77af1ae75d305340fcf6e7b5f806ddcba4aa42b55d",
|
||||||
, "f75c2e4b70db4b0aabc44b77af1ae75d305340fcf6e7b5f806ddcba4aa42b55d"
|
"e125c488636749da68e6696b97525a77146c0777c7946927e37afd513d74a4e6",
|
||||||
, "e125c488636749da68e6696b97525a77146c0777c7946927e37afd513d74a4e6"
|
"c20526f119aea10880af631eba7f0b60385a22e0b0c402fe8508d41952e58be9",
|
||||||
, "c20526f119aea10880af631eba7f0b60385a22e0b0c402fe8508d41952e58be9"
|
"6456c023c7e245f5c57a168633a23f57f4fadb651115f807694a6bed14ae3b55",
|
||||||
, "6456c023c7e245f5c57a168633a23f57f4fadb651115f807694a6bed14ae3b55"
|
"98b26e364e2888c9f264e4b5e13103c89608609774eb07ce933d8a2a45d19776",
|
||||||
, "98b26e364e2888c9f264e4b5e13103c89608609774eb07ce933d8a2a45d19776"
|
"2efaa4f167bb65ba5684f8076cd9279fd67fd9c67388c8862809bab5542e637d",
|
||||||
, "2efaa4f167bb65ba5684f8076cd9279fd67fd9c67388c8862809bab5542e637d"
|
"ec44eeb84d8d976d77079a822710b4dfdb11a2d9a03d8cc00bab0ae424e84666",
|
||||||
, "ec44eeb84d8d976d77079a822710b4dfdb11a2d9a03d8cc00bab0ae424e84666"
|
"410730d9f807d81ac48b8eafac6f1d36642c1c370241b367a35f0bac6ac7c05f",
|
||||||
, "410730d9f807d81ac48b8eafac6f1d36642c1c370241b367a35f0bac6ac7c05f"
|
"e95a7d0d477fd3db22756a3fd390a50c7bc48dc9e946fea9d24bd0866b3bb0e9",
|
||||||
, "e95a7d0d477fd3db22756a3fd390a50c7bc48dc9e946fea9d24bd0866b3bb0e9"
|
"a72fec99d14939216628aaf7a0afc4c017113bcae964e777e6b508864eeaacc4",
|
||||||
, "a72fec99d14939216628aaf7a0afc4c017113bcae964e777e6b508864eeaacc4"
|
"8548433310fcf75dbbc042121e8318c678e0a017534786dd322a91cebe8d213f"
|
||||||
, "8548433310fcf75dbbc042121e8318c678e0a017534786dd322a91cebe8d213f"
|
]
|
||||||
]
|
)
|
||||||
)
|
]
|
||||||
]
|
|
||||||
|
|
||||||
testSubsidy :: Network -> Assertion
|
testSubsidy :: Network -> Assertion
|
||||||
testSubsidy net = go (2 * 50 * 100 * 1000 * 1000) 0
|
testSubsidy net = go (2 * 50 * 100 * 1000 * 1000) 0
|
||||||
where
|
where
|
||||||
go previous_subsidy halvings = do
|
go previous_subsidy halvings = do
|
||||||
let height = halvings * getHalvingInterval net
|
let height = halvings * net.halvingInterval
|
||||||
subsidy = computeSubsidy net height
|
subsidy = computeSubsidy net height
|
||||||
if halvings >= 64
|
if halvings >= 64
|
||||||
then subsidy `shouldBe` 0
|
then subsidy `shouldBe` 0
|
||||||
else do
|
else do
|
||||||
subsidy `shouldBe` (previous_subsidy `div` 2)
|
subsidy `shouldBe` (previous_subsidy `div` 2)
|
||||||
go subsidy (halvings + 1)
|
go subsidy (halvings + 1)
|
||||||
|
|
||||||
data AsertBlock = AsertBlock Int Integer Integer Word32
|
data AsertBlock = AsertBlock Int Integer Integer Word32
|
||||||
|
|
||||||
@ -387,34 +386,34 @@ data AsertVector = AsertVector String Integer Integer Word32 [AsertBlock]
|
|||||||
|
|
||||||
readAsertVector :: FilePath -> IO AsertVector
|
readAsertVector :: FilePath -> IO AsertVector
|
||||||
readAsertVector p = do
|
readAsertVector p = do
|
||||||
(d : ah : apt : ab : _ : _ : _ : _ : xs) <- lines <$> readFile ("data/" ++ p)
|
(d : ah : apt : ab : _ : _ : _ : _ : xs) <- lines <$> readFile ("data/" ++ p)
|
||||||
let desc = drop 16 d
|
let desc = drop 16 d
|
||||||
anchor_height = read (words ah !! 3)
|
anchor_height = read (words ah !! 3)
|
||||||
anchor_parent_time = read (words apt !! 4)
|
anchor_parent_time = read (words apt !! 4)
|
||||||
anchor_nbits = read (words ab !! 3)
|
anchor_nbits = read (words ab !! 3)
|
||||||
blocks = map (f . words) (init xs)
|
blocks = map (f . words) (init xs)
|
||||||
return $
|
return $
|
||||||
AsertVector
|
AsertVector
|
||||||
desc
|
desc
|
||||||
anchor_height
|
anchor_height
|
||||||
anchor_parent_time
|
anchor_parent_time
|
||||||
anchor_nbits
|
anchor_nbits
|
||||||
blocks
|
blocks
|
||||||
where
|
where
|
||||||
f [i, h, t, g] = AsertBlock (read i) (read h) (read t) (read g)
|
f [i, h, t, g] = AsertBlock (read i) (read h) (read t) (read g)
|
||||||
f _ = undefined
|
f _ = undefined
|
||||||
|
|
||||||
asertTests :: FilePath -> SpecWith ()
|
asertTests :: FilePath -> SpecWith ()
|
||||||
asertTests file = do
|
asertTests file = do
|
||||||
v@(AsertVector d _ _ _ _) <- runIO $ readAsertVector file
|
v@(AsertVector d _ _ _ _) <- runIO $ readAsertVector file
|
||||||
it d $ testAsertBits v
|
it d $ testAsertBits v
|
||||||
|
|
||||||
testAsertBits :: AsertVector -> Assertion
|
testAsertBits :: AsertVector -> Assertion
|
||||||
testAsertBits (AsertVector _ anchor_height anchor_parent_time anchor_bits blocks) =
|
testAsertBits (AsertVector _ anchor_height anchor_parent_time anchor_bits blocks) =
|
||||||
forM_ blocks $ \(AsertBlock _ h t g) ->
|
forM_ blocks $ \(AsertBlock _ h t g) ->
|
||||||
computeAsertBits
|
computeAsertBits
|
||||||
(2 * 24 * 60 * 60)
|
(2 * 24 * 60 * 60)
|
||||||
anchor_bits
|
anchor_bits
|
||||||
(t - anchor_parent_time)
|
(t - anchor_parent_time)
|
||||||
(h - anchor_height)
|
(h - anchor_height)
|
||||||
`shouldBe` g
|
`shouldBe` g
|
||||||
|
@ -1,13 +1,16 @@
|
|||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE NoFieldSelectors #-}
|
||||||
|
|
||||||
module Haskoin.Crypto.HashSpec (spec) where
|
module Haskoin.Crypto.HashSpec (spec) where
|
||||||
|
|
||||||
import Data.Bits
|
import Data.Bits
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
import Data.ByteString.Builder
|
import Data.ByteString.Builder
|
||||||
import qualified Data.ByteString.Char8 as C
|
import Data.ByteString.Char8 qualified as Char8
|
||||||
import qualified Data.ByteString.Lazy as BL
|
import Data.ByteString.Lazy qualified as Lazy
|
||||||
import qualified Data.ByteString.Short as BSS
|
import Data.ByteString.Short qualified as Short
|
||||||
import Data.Bytes.Get
|
import Data.Bytes.Get
|
||||||
import Data.Bytes.Put
|
import Data.Bytes.Put
|
||||||
import Data.Bytes.Serial
|
import Data.Bytes.Serial
|
||||||
@ -27,51 +30,52 @@ import Test.QuickCheck
|
|||||||
|
|
||||||
serialVals :: [SerialBox]
|
serialVals :: [SerialBox]
|
||||||
serialVals =
|
serialVals =
|
||||||
[ SerialBox arbitraryBS
|
[ SerialBox arbitraryBS,
|
||||||
, SerialBox arbitraryHash160
|
SerialBox arbitraryHash160,
|
||||||
, SerialBox arbitraryHash256
|
SerialBox arbitraryHash256,
|
||||||
, SerialBox arbitraryHash512
|
SerialBox arbitraryHash512
|
||||||
]
|
]
|
||||||
|
|
||||||
readVals :: [ReadBox]
|
readVals :: [ReadBox]
|
||||||
readVals =
|
readVals =
|
||||||
[ ReadBox arbitraryBS
|
[ ReadBox arbitraryBS,
|
||||||
, ReadBox arbitraryBSS
|
ReadBox arbitraryBSS,
|
||||||
, ReadBox arbitraryHash160
|
ReadBox arbitraryHash160,
|
||||||
, ReadBox arbitraryHash256
|
ReadBox arbitraryHash256,
|
||||||
, ReadBox arbitraryHash512
|
ReadBox arbitraryHash512
|
||||||
]
|
]
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec =
|
spec =
|
||||||
describe "Hash" $ do
|
describe "Hash" $ do
|
||||||
testIdentity serialVals readVals [] []
|
testIdentity serialVals readVals [] []
|
||||||
describe "Property Tests" $ do
|
describe "Property Tests" $ do
|
||||||
prop "join512( split512(h) ) == h" $
|
prop "join512( split512(h) ) == h" $
|
||||||
forAll arbitraryHash256 $ forAll arbitraryHash256 . joinSplit512
|
forAll arbitraryHash256 $
|
||||||
prop "decodeCompact . encodeCompact i == i" decEncCompact
|
forAll arbitraryHash256 . joinSplit512
|
||||||
prop "from string Hash512" $
|
prop "decodeCompact . encodeCompact i == i" decEncCompact
|
||||||
forAll arbitraryHash512 $ \h ->
|
prop "from string Hash512" $
|
||||||
fromString (cs $ encodeHex $ runPutS $ serialize h) == h
|
forAll arbitraryHash512 $ \h ->
|
||||||
prop "from string Hash256" $
|
fromString (cs $ encodeHex $ runPutS $ serialize h) == h
|
||||||
forAll arbitraryHash256 $ \h ->
|
prop "from string Hash256" $
|
||||||
fromString (cs $ encodeHex $ runPutS $ serialize h) == h
|
forAll arbitraryHash256 $ \h ->
|
||||||
prop "from string Hash160" $
|
fromString (cs $ encodeHex $ runPutS $ serialize h) == h
|
||||||
forAll arbitraryHash160 $ \h ->
|
prop "from string Hash160" $
|
||||||
fromString (cs $ encodeHex $ runPutS $ serialize h) == h
|
forAll arbitraryHash160 $ \h ->
|
||||||
describe "Test Vectors" $ do
|
fromString (cs $ encodeHex $ runPutS $ serialize h) == h
|
||||||
it "Passes RIPEMD160 test vectors" $
|
describe "Test Vectors" $ do
|
||||||
mapM_ (testVector ripemd160 getHash160) ripemd160Vectors
|
it "Passes RIPEMD160 test vectors" $
|
||||||
it "Passes SHA1 test vectors" $
|
mapM_ (testVector ripemd160 (.get)) ripemd160Vectors
|
||||||
mapM_ (testVector sha1 getHash160) sha1Vectors
|
it "Passes SHA1 test vectors" $
|
||||||
it "Passes SHA256 test vectors" $
|
mapM_ (testVector sha1 (.get)) sha1Vectors
|
||||||
mapM_ (testVector sha256 getHash256) sha256Vectors
|
it "Passes SHA256 test vectors" $
|
||||||
it "Passes SHA512 test vectors" $
|
mapM_ (testVector sha256 (.get)) sha256Vectors
|
||||||
mapM_ (testVector sha512 getHash512) sha512Vectors
|
it "Passes SHA512 test vectors" $
|
||||||
it "Passes HMAC_SHA256 test vectors" $
|
mapM_ (testVector sha512 (.get)) sha512Vectors
|
||||||
mapM_ (testHMACVector hmac256 getHash256) hmacSha256Vectors
|
it "Passes HMAC_SHA256 test vectors" $
|
||||||
it "Passes HMAC_SHA512 test vectors" $
|
mapM_ (testHMACVector hmac256 (.get)) hmacSha256Vectors
|
||||||
mapM_ (testHMACVector hmac512 getHash512) hmacSha512Vectors
|
it "Passes HMAC_SHA512 test vectors" $
|
||||||
|
mapM_ (testHMACVector hmac512 (.get)) hmacSha512Vectors
|
||||||
|
|
||||||
joinSplit512 :: Hash256 -> Hash256 -> Bool
|
joinSplit512 :: Hash256 -> Hash256 -> Bool
|
||||||
joinSplit512 a b = split512 (join512 (a, b)) == (a, b)
|
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.
|
-- to the old one.
|
||||||
decEncCompact :: Integer -> Bool
|
decEncCompact :: Integer -> Bool
|
||||||
decEncCompact i
|
decEncCompact i
|
||||||
-- Integer completely fits inside the mantisse
|
-- Integer completely fits inside the mantisse
|
||||||
| abs i <= 0x007fffff = decodeCompact (encodeCompact i) == (i, False)
|
| abs i <= 0x007fffff = decodeCompact (encodeCompact i) == (i, False)
|
||||||
-- Otherwise precision will be lost and the decoded result will
|
-- Otherwise precision will be lost and the decoded result will
|
||||||
-- be smaller than the original number
|
-- be smaller than the original number
|
||||||
| i >= 0 = fst (decodeCompact (encodeCompact i)) < i
|
| i >= 0 = fst (decodeCompact (encodeCompact i)) < i
|
||||||
| otherwise = fst (decodeCompact (encodeCompact i)) > i
|
| otherwise = fst (decodeCompact (encodeCompact i)) > i
|
||||||
|
|
||||||
-- Test vectors from:
|
-- Test vectors from:
|
||||||
-- https://github.com/bitcoin/bitcoin/blob/master/src/test/crypto_tests.cpp
|
-- https://github.com/bitcoin/bitcoin/blob/master/src/test/crypto_tests.cpp
|
||||||
|
|
||||||
testVector ::
|
testVector ::
|
||||||
(ByteString -> a) ->
|
(ByteString -> a) ->
|
||||||
(a -> BSS.ShortByteString) ->
|
(a -> Short.ShortByteString) ->
|
||||||
(ByteString, Text) ->
|
(ByteString, Text) ->
|
||||||
Assertion
|
Assertion
|
||||||
testVector f1 f2 (i, res) =
|
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 ::
|
testHMACVector ::
|
||||||
(ByteString -> ByteString -> a) ->
|
(ByteString -> ByteString -> a) ->
|
||||||
(a -> BSS.ShortByteString) ->
|
(a -> Short.ShortByteString) ->
|
||||||
(Text, Text, Text) ->
|
(Text, Text, Text) ->
|
||||||
Assertion
|
Assertion
|
||||||
testHMACVector f1 f2 (k, m, res) =
|
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
|
where
|
||||||
bsK = fromJust $ decodeHex k
|
bsK = fromJust $ decodeHex k
|
||||||
bsM = fromJust $ decodeHex m
|
bsM = fromJust $ decodeHex m
|
||||||
|
|
||||||
longTestString :: ByteString
|
longTestString :: ByteString
|
||||||
longTestString =
|
longTestString =
|
||||||
BL.toStrict $! toLazyByteString $! go [0 .. 199999]
|
Lazy.toStrict $! toLazyByteString $! go [0 .. 199999]
|
||||||
where
|
where
|
||||||
go :: [Word32] -> Builder
|
go :: [Word32] -> Builder
|
||||||
go [] = mempty
|
go [] = mempty
|
||||||
go (i : is) =
|
go (i : is) =
|
||||||
let i1 = fromIntegral $! i
|
let i1 = fromIntegral $! i
|
||||||
i2 = fromIntegral $! i `shiftR` 4
|
i2 = fromIntegral $! i `shiftR` 4
|
||||||
i3 = fromIntegral $! i `shiftR` 8
|
i3 = fromIntegral $! i `shiftR` 8
|
||||||
i4 = fromIntegral $! i `shiftR` 12
|
i4 = fromIntegral $! i `shiftR` 12
|
||||||
i5 = fromIntegral $! i `shiftR` 16
|
i5 = fromIntegral $! i `shiftR` 16
|
||||||
in word8 i1 <> word8 i2 <> word8 i3 <> word8 i4 <> word8 i5 <> go is
|
in word8 i1 <> word8 i2 <> word8 i3 <> word8 i4 <> word8 i5 <> go is
|
||||||
|
|
||||||
ripemd160Vectors :: [(ByteString, Text)]
|
ripemd160Vectors :: [(ByteString, Text)]
|
||||||
ripemd160Vectors =
|
ripemd160Vectors =
|
||||||
[ ("", "9c1185a5c5e9fc54612808977ee8f548b2258d31")
|
[ ("", "9c1185a5c5e9fc54612808977ee8f548b2258d31"),
|
||||||
, ("abc", "8eb208f7e05d987a9b044a8e98c6b087f15a0bfc")
|
("abc", "8eb208f7e05d987a9b044a8e98c6b087f15a0bfc"),
|
||||||
, ("message digest", "5d0689ef49d2fae572b881b123a85ffa21595f36")
|
("message digest", "5d0689ef49d2fae572b881b123a85ffa21595f36"),
|
||||||
, ("secure hash algorithm", "20397528223b6a5f4cbc2808aba0464e645544f9")
|
("secure hash algorithm", "20397528223b6a5f4cbc2808aba0464e645544f9"),
|
||||||
,
|
( "RIPEMD160 is considered to be safe",
|
||||||
( "RIPEMD160 is considered to be safe"
|
"a7d78608c7af8a8e728778e81576870734122b66"
|
||||||
, "a7d78608c7af8a8e728778e81576870734122b66"
|
),
|
||||||
)
|
( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq",
|
||||||
,
|
"12a053384a9c0c88e405a06c27dcf49ada62eb2b"
|
||||||
( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
|
),
|
||||||
, "12a053384a9c0c88e405a06c27dcf49ada62eb2b"
|
( "For this sample, this 63-byte string will be used as input data",
|
||||||
)
|
"de90dbfee14b63fb5abf27c2ad4a82aaa5f27a11"
|
||||||
,
|
),
|
||||||
( "For this sample, this 63-byte string will be used as input data"
|
( "This is exactly 64 bytes long, not counting the terminating byte",
|
||||||
, "de90dbfee14b63fb5abf27c2ad4a82aaa5f27a11"
|
"eda31d51d3a623b81e19eb02e24ff65d27d67b37"
|
||||||
)
|
),
|
||||||
,
|
(Char8.replicate 1000000 'a', "52783243c1697bdbe16d37f97f68f08325dc1528"),
|
||||||
( "This is exactly 64 bytes long, not counting the terminating byte"
|
(longTestString, "464243587bd146ea835cdf57bdae582f25ec45f1")
|
||||||
, "eda31d51d3a623b81e19eb02e24ff65d27d67b37"
|
]
|
||||||
)
|
|
||||||
, (C.replicate 1000000 'a', "52783243c1697bdbe16d37f97f68f08325dc1528")
|
|
||||||
, (longTestString, "464243587bd146ea835cdf57bdae582f25ec45f1")
|
|
||||||
]
|
|
||||||
|
|
||||||
sha1Vectors :: [(ByteString, Text)]
|
sha1Vectors :: [(ByteString, Text)]
|
||||||
sha1Vectors =
|
sha1Vectors =
|
||||||
[ ("", "da39a3ee5e6b4b0d3255bfef95601890afd80709")
|
[ ("", "da39a3ee5e6b4b0d3255bfef95601890afd80709"),
|
||||||
, ("abc", "a9993e364706816aba3e25717850c26c9cd0d89d")
|
("abc", "a9993e364706816aba3e25717850c26c9cd0d89d"),
|
||||||
, ("message digest", "c12252ceda8be8994d5fa0290a47231c1d16aae3")
|
("message digest", "c12252ceda8be8994d5fa0290a47231c1d16aae3"),
|
||||||
, ("secure hash algorithm", "d4d6d2f0ebe317513bbd8d967d89bac5819c2f60")
|
("secure hash algorithm", "d4d6d2f0ebe317513bbd8d967d89bac5819c2f60"),
|
||||||
,
|
( "SHA1 is considered to be safe",
|
||||||
( "SHA1 is considered to be safe"
|
"f2b6650569ad3a8720348dd6ea6c497dee3a842a"
|
||||||
, "f2b6650569ad3a8720348dd6ea6c497dee3a842a"
|
),
|
||||||
)
|
( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq",
|
||||||
,
|
"84983e441c3bd26ebaae4aa1f95129e5e54670f1"
|
||||||
( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
|
),
|
||||||
, "84983e441c3bd26ebaae4aa1f95129e5e54670f1"
|
( "For this sample, this 63-byte string will be used as input data",
|
||||||
)
|
"4f0ea5cd0585a23d028abdc1a6684e5a8094dc49"
|
||||||
,
|
),
|
||||||
( "For this sample, this 63-byte string will be used as input data"
|
( "This is exactly 64 bytes long, not counting the terminating byte",
|
||||||
, "4f0ea5cd0585a23d028abdc1a6684e5a8094dc49"
|
"fb679f23e7d1ce053313e66e127ab1b444397057"
|
||||||
)
|
),
|
||||||
,
|
(Char8.replicate 1000000 'a', "34aa973cd4c4daa4f61eeb2bdbad27316534016f"),
|
||||||
( "This is exactly 64 bytes long, not counting the terminating byte"
|
(longTestString, "b7755760681cbfd971451668f32af5774f4656b5")
|
||||||
, "fb679f23e7d1ce053313e66e127ab1b444397057"
|
]
|
||||||
)
|
|
||||||
, (C.replicate 1000000 'a', "34aa973cd4c4daa4f61eeb2bdbad27316534016f")
|
|
||||||
, (longTestString, "b7755760681cbfd971451668f32af5774f4656b5")
|
|
||||||
]
|
|
||||||
|
|
||||||
sha256Vectors :: [(ByteString, Text)]
|
sha256Vectors :: [(ByteString, Text)]
|
||||||
sha256Vectors =
|
sha256Vectors =
|
||||||
[ ("", "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855")
|
[ ("", "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"),
|
||||||
,
|
( "abc",
|
||||||
( "abc"
|
"ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad"
|
||||||
, "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad"
|
),
|
||||||
)
|
( "message digest",
|
||||||
,
|
"f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650"
|
||||||
( "message digest"
|
),
|
||||||
, "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650"
|
( "secure hash algorithm",
|
||||||
)
|
"f30ceb2bb2829e79e4ca9753d35a8ecc00262d164cc077080295381cbd643f0d"
|
||||||
,
|
),
|
||||||
( "secure hash algorithm"
|
( "SHA256 is considered to be safe",
|
||||||
, "f30ceb2bb2829e79e4ca9753d35a8ecc00262d164cc077080295381cbd643f0d"
|
"6819d915c73f4d1e77e4e1b52d1fa0f9cf9beaead3939f15874bd988e2a23630"
|
||||||
)
|
),
|
||||||
,
|
( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq",
|
||||||
( "SHA256 is considered to be safe"
|
"248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1"
|
||||||
, "6819d915c73f4d1e77e4e1b52d1fa0f9cf9beaead3939f15874bd988e2a23630"
|
),
|
||||||
)
|
( "For this sample, this 63-byte string will be used as input data",
|
||||||
,
|
"f08a78cbbaee082b052ae0708f32fa1e50c5c421aa772ba5dbb406a2ea6be342"
|
||||||
( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
|
),
|
||||||
, "248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1"
|
( "This is exactly 64 bytes long, not counting the terminating byte",
|
||||||
)
|
"ab64eff7e88e2e46165e29f2bce41826bd4c7b3552f6b382a9e7d3af47c245f8"
|
||||||
,
|
),
|
||||||
( "For this sample, this 63-byte string will be used as input data"
|
( "As Bitcoin relies on 80 byte header hashes, we want to have an example for that.",
|
||||||
, "f08a78cbbaee082b052ae0708f32fa1e50c5c421aa772ba5dbb406a2ea6be342"
|
"7406e8de7d6e4fffc573daef05aefb8806e7790f55eab5576f31349743cca743"
|
||||||
)
|
),
|
||||||
,
|
( Char8.replicate 1000000 'a',
|
||||||
( "This is exactly 64 bytes long, not counting the terminating byte"
|
"cdc76e5c9914fb9281a1c7e284d73e67f1809a48a497200e046d39ccc7112cd0"
|
||||||
, "ab64eff7e88e2e46165e29f2bce41826bd4c7b3552f6b382a9e7d3af47c245f8"
|
),
|
||||||
)
|
( longTestString,
|
||||||
,
|
"a316d55510b49662420f49d145d42fb83f31ef8dc016aa4e32df049991a91e26"
|
||||||
( "As Bitcoin relies on 80 byte header hashes, we want to have an example for that."
|
)
|
||||||
, "7406e8de7d6e4fffc573daef05aefb8806e7790f55eab5576f31349743cca743"
|
]
|
||||||
)
|
|
||||||
,
|
|
||||||
( C.replicate 1000000 'a'
|
|
||||||
, "cdc76e5c9914fb9281a1c7e284d73e67f1809a48a497200e046d39ccc7112cd0"
|
|
||||||
)
|
|
||||||
,
|
|
||||||
( longTestString
|
|
||||||
, "a316d55510b49662420f49d145d42fb83f31ef8dc016aa4e32df049991a91e26"
|
|
||||||
)
|
|
||||||
]
|
|
||||||
|
|
||||||
sha512Vectors :: [(ByteString, Text)]
|
sha512Vectors :: [(ByteString, Text)]
|
||||||
sha512Vectors =
|
sha512Vectors =
|
||||||
[
|
[ ( "",
|
||||||
( ""
|
"cf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d1\
|
||||||
, "cf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d1\
|
\3c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e"
|
||||||
\3c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e"
|
),
|
||||||
)
|
( "abc",
|
||||||
,
|
"ddaf35a193617abacc417349ae20413112e6fa4e89a97ea20a9eeee64b55d39a219299\
|
||||||
( "abc"
|
\2a274fc1a836ba3c23a3feebbd454d4423643ce80e2a9ac94fa54ca49f"
|
||||||
, "ddaf35a193617abacc417349ae20413112e6fa4e89a97ea20a9eeee64b55d39a219299\
|
),
|
||||||
\2a274fc1a836ba3c23a3feebbd454d4423643ce80e2a9ac94fa54ca49f"
|
( "message digest",
|
||||||
)
|
"107dbf389d9e9f71a3a95f6c055b9251bc5268c2be16d6c13492ea45b0199f3309e164\
|
||||||
,
|
\55ab1e96118e8a905d5597b72038ddb372a89826046de66687bb420e7c"
|
||||||
( "message digest"
|
),
|
||||||
, "107dbf389d9e9f71a3a95f6c055b9251bc5268c2be16d6c13492ea45b0199f3309e164\
|
( "secure hash algorithm",
|
||||||
\55ab1e96118e8a905d5597b72038ddb372a89826046de66687bb420e7c"
|
"7746d91f3de30c68cec0dd693120a7e8b04d8073cb699bdce1a3f64127bca7a3d5db50\
|
||||||
)
|
\2e814bb63c063a7a5043b2df87c61133395f4ad1edca7fcf4b30c3236e"
|
||||||
,
|
),
|
||||||
( "secure hash algorithm"
|
( "SHA512 is considered to be safe",
|
||||||
, "7746d91f3de30c68cec0dd693120a7e8b04d8073cb699bdce1a3f64127bca7a3d5db50\
|
"099e6468d889e1c79092a89ae925a9499b5408e01b66cb5b0a3bd0dfa51a99646b4a39\
|
||||||
\2e814bb63c063a7a5043b2df87c61133395f4ad1edca7fcf4b30c3236e"
|
\01caab1318189f74cd8cf2e941829012f2449df52067d3dd5b978456c2"
|
||||||
)
|
),
|
||||||
,
|
( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq",
|
||||||
( "SHA512 is considered to be safe"
|
"204a8fc6dda82f0a0ced7beb8e08a41657c16ef468b228a8279be331a703c33596fd15\
|
||||||
, "099e6468d889e1c79092a89ae925a9499b5408e01b66cb5b0a3bd0dfa51a99646b4a39\
|
\c13b1b07f9aa1d3bea57789ca031ad85c7a71dd70354ec631238ca3445"
|
||||||
\01caab1318189f74cd8cf2e941829012f2449df52067d3dd5b978456c2"
|
),
|
||||||
)
|
( "For this sample, this 63-byte string will be used as input data",
|
||||||
,
|
"b3de4afbc516d2478fe9b518d063bda6c8dd65fc38402dd81d1eb7364e72fb6e6663cf\
|
||||||
( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
|
\6d2771c8f5a6da09601712fb3d2a36c6ffea3e28b0818b05b0a8660766"
|
||||||
, "204a8fc6dda82f0a0ced7beb8e08a41657c16ef468b228a8279be331a703c33596fd15\
|
),
|
||||||
\c13b1b07f9aa1d3bea57789ca031ad85c7a71dd70354ec631238ca3445"
|
( "This is exactly 64 bytes long, not counting the terminating byte",
|
||||||
)
|
"70aefeaa0e7ac4f8fe17532d7185a289bee3b428d950c14fa8b713ca09814a387d2458\
|
||||||
,
|
\70e007a80ad97c369d193e41701aa07f3221d15f0e65a1ff970cedf030"
|
||||||
( "For this sample, this 63-byte string will be used as input data"
|
),
|
||||||
, "b3de4afbc516d2478fe9b518d063bda6c8dd65fc38402dd81d1eb7364e72fb6e6663cf\
|
( "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmn\
|
||||||
\6d2771c8f5a6da09601712fb3d2a36c6ffea3e28b0818b05b0a8660766"
|
\opjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu",
|
||||||
)
|
"8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d28\
|
||||||
,
|
\9e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909"
|
||||||
( "This is exactly 64 bytes long, not counting the terminating byte"
|
),
|
||||||
, "70aefeaa0e7ac4f8fe17532d7185a289bee3b428d950c14fa8b713ca09814a387d2458\
|
( Char8.replicate 1000000 'a',
|
||||||
\70e007a80ad97c369d193e41701aa07f3221d15f0e65a1ff970cedf030"
|
"e718483d0ce769644e2e42c7bc15b4638e1f98b13b2044285632a803afa973ebde0ff2\
|
||||||
)
|
\44877ea60a4cb0432ce577c31beb009c5c2c49aa2e4eadb217ad8cc09b"
|
||||||
,
|
),
|
||||||
( "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmn\
|
( longTestString,
|
||||||
\opjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu"
|
"40cac46c147e6131c5193dd5f34e9d8bb4951395f27b08c558c65ff4ba2de59437de8c\
|
||||||
, "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d28\
|
\3ef5459d76a52cedc02dc499a3c9ed9dedbfb3281afd9653b8a112fafc"
|
||||||
\9e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909"
|
)
|
||||||
)
|
]
|
||||||
,
|
|
||||||
( C.replicate 1000000 'a'
|
|
||||||
, "e718483d0ce769644e2e42c7bc15b4638e1f98b13b2044285632a803afa973ebde0ff2\
|
|
||||||
\44877ea60a4cb0432ce577c31beb009c5c2c49aa2e4eadb217ad8cc09b"
|
|
||||||
)
|
|
||||||
,
|
|
||||||
( longTestString
|
|
||||||
, "40cac46c147e6131c5193dd5f34e9d8bb4951395f27b08c558c65ff4ba2de59437de8c\
|
|
||||||
\3ef5459d76a52cedc02dc499a3c9ed9dedbfb3281afd9653b8a112fafc"
|
|
||||||
)
|
|
||||||
]
|
|
||||||
|
|
||||||
-- test cases 1, 2, 3, 4, 6 and 7 of RFC 4231
|
-- test cases 1, 2, 3, 4, 6 and 7 of RFC 4231
|
||||||
hmacSha256Vectors :: [(Text, Text, Text)]
|
hmacSha256Vectors :: [(Text, Text, Text)]
|
||||||
hmacSha256Vectors =
|
hmacSha256Vectors =
|
||||||
[
|
[ ( "0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b",
|
||||||
( "0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b"
|
"4869205468657265",
|
||||||
, "4869205468657265"
|
"b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7"
|
||||||
, "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7"
|
),
|
||||||
)
|
( "4a656665",
|
||||||
,
|
"7768617420646f2079612077616e7420666f72206e6f7468696e673f",
|
||||||
( "4a656665"
|
"5bdcc146bf60754e6a042426089575c75a003f089d2739839dec58b964ec3843"
|
||||||
, "7768617420646f2079612077616e7420666f72206e6f7468696e673f"
|
),
|
||||||
, "5bdcc146bf60754e6a042426089575c75a003f089d2739839dec58b964ec3843"
|
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa",
|
||||||
)
|
"dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd\
|
||||||
,
|
\dddddddddddddddddddddddddddddd",
|
||||||
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
|
"773ea91e36800e46854db8ebd09181a72959098b3ef8c122d9635514ced565fe"
|
||||||
, "dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd\
|
),
|
||||||
\dddddddddddddddddddddddddddddd"
|
( "0102030405060708090a0b0c0d0e0f10111213141516171819",
|
||||||
, "773ea91e36800e46854db8ebd09181a72959098b3ef8c122d9635514ced565fe"
|
"cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd\
|
||||||
)
|
\cdcdcdcdcdcdcdcdcdcdcdcdcdcdcd",
|
||||||
,
|
"82558a389a443c0ea4cc819899f2083a85f0faa3e578f8077a2e3ff46729665b"
|
||||||
( "0102030405060708090a0b0c0d0e0f10111213141516171819"
|
),
|
||||||
, "cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd\
|
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
||||||
\cdcdcdcdcdcdcdcdcdcdcdcdcdcdcd"
|
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
||||||
, "82558a389a443c0ea4cc819899f2083a85f0faa3e578f8077a2e3ff46729665b"
|
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
||||||
)
|
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa",
|
||||||
,
|
"54657374205573696e67204c6172676572205468616e20426c6f636b2d53697a65204b\
|
||||||
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
\6579202d2048617368204b6579204669727374",
|
||||||
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
"60e431591ee0b67f0d8a26aacbf5b77f8e0bc6213728c5140546040f0ee37f54"
|
||||||
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
),
|
||||||
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
|
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
||||||
, "54657374205573696e67204c6172676572205468616e20426c6f636b2d53697a65204b\
|
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
||||||
\6579202d2048617368204b6579204669727374"
|
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
||||||
, "60e431591ee0b67f0d8a26aacbf5b77f8e0bc6213728c5140546040f0ee37f54"
|
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa",
|
||||||
)
|
"5468697320697320612074657374207573696e672061206c6172676572207468616e20\
|
||||||
,
|
\626c6f636b2d73697a65206b657920616e642061206c6172676572207468616e20626c\
|
||||||
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
\6f636b2d73697a6520646174612e20546865206b6579206e6565647320746f20626520\
|
||||||
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
\686173686564206265666f7265206265696e6720757365642062792074686520484d41\
|
||||||
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
\4320616c676f726974686d2e",
|
||||||
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
|
"9b09ffa71b942fcb27635fbcd5b0e944bfdc63644f0713938a7f51535c3a35e2"
|
||||||
, "5468697320697320612074657374207573696e672061206c6172676572207468616e20\
|
),
|
||||||
\626c6f636b2d73697a65206b657920616e642061206c6172676572207468616e20626c\
|
-- Test case with key length 63 bytes.
|
||||||
\6f636b2d73697a6520646174612e20546865206b6579206e6565647320746f20626520\
|
|
||||||
\686173686564206265666f7265206265696e6720757365642062792074686520484d41\
|
|
||||||
\4320616c676f726974686d2e"
|
|
||||||
, "9b09ffa71b942fcb27635fbcd5b0e944bfdc63644f0713938a7f51535c3a35e2"
|
|
||||||
)
|
|
||||||
, -- Test case with key length 63 bytes.
|
|
||||||
|
|
||||||
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566\
|
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566\
|
||||||
\654a6566654a6566654a6566654a6566654a6566654a6566654a6566"
|
\654a6566654a6566654a6566654a6566654a6566654a6566654a6566",
|
||||||
, "7768617420646f2079612077616e7420666f72206e6f7468696e673f"
|
"7768617420646f2079612077616e7420666f72206e6f7468696e673f",
|
||||||
, "9de4b546756c83516720a4ad7fe7bdbeac4298c6fdd82b15f895a6d10b0769a6"
|
"9de4b546756c83516720a4ad7fe7bdbeac4298c6fdd82b15f895a6d10b0769a6"
|
||||||
)
|
),
|
||||||
, -- Test case with key length 64 bytes.
|
-- Test case with key length 64 bytes.
|
||||||
|
|
||||||
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566\
|
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566\
|
||||||
\654a6566654a6566654a6566654a6566654a6566654a6566654a656665"
|
\654a6566654a6566654a6566654a6566654a6566654a6566654a656665",
|
||||||
, "7768617420646f2079612077616e7420666f72206e6f7468696e673f"
|
"7768617420646f2079612077616e7420666f72206e6f7468696e673f",
|
||||||
, "528c609a4c9254c274585334946b7c2661bad8f1fc406b20f6892478d19163dd"
|
"528c609a4c9254c274585334946b7c2661bad8f1fc406b20f6892478d19163dd"
|
||||||
)
|
),
|
||||||
, -- Test case with key length 65 bytes.
|
-- Test case with key length 65 bytes.
|
||||||
|
|
||||||
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566\
|
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566\
|
||||||
\654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a"
|
\654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a",
|
||||||
, "7768617420646f2079612077616e7420666f72206e6f7468696e673f"
|
"7768617420646f2079612077616e7420666f72206e6f7468696e673f",
|
||||||
, "d06af337f359a2330deffb8e3cbe4b5b7aa8ca1f208528cdbd245d5dc63c4483"
|
"d06af337f359a2330deffb8e3cbe4b5b7aa8ca1f208528cdbd245d5dc63c4483"
|
||||||
)
|
)
|
||||||
]
|
]
|
||||||
|
|
||||||
-- test cases 1, 2, 3, 4, 6 and 7 of RFC 4231
|
-- test cases 1, 2, 3, 4, 6 and 7 of RFC 4231
|
||||||
hmacSha512Vectors :: [(Text, Text, Text)]
|
hmacSha512Vectors :: [(Text, Text, Text)]
|
||||||
hmacSha512Vectors =
|
hmacSha512Vectors =
|
||||||
[
|
[ ( "0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b",
|
||||||
( "0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b"
|
"4869205468657265",
|
||||||
, "4869205468657265"
|
"87aa7cdea5ef619d4ff0b4241a1d6cb02379f4e2ce4ec2787ad0b30545e17cde\
|
||||||
, "87aa7cdea5ef619d4ff0b4241a1d6cb02379f4e2ce4ec2787ad0b30545e17cde\
|
\daa833b7d6b8a702038b274eaea3f4e4be9d914eeb61f1702e696c203a126854"
|
||||||
\daa833b7d6b8a702038b274eaea3f4e4be9d914eeb61f1702e696c203a126854"
|
),
|
||||||
)
|
( "4a656665",
|
||||||
,
|
"7768617420646f2079612077616e7420666f72206e6f7468696e673f",
|
||||||
( "4a656665"
|
"164b7a7bfcf819e2e395fbe73b56e0a387bd64222e831fd610270cd7ea250554\
|
||||||
, "7768617420646f2079612077616e7420666f72206e6f7468696e673f"
|
\9758bf75c05a994a6d034f65f8f0e6fdcaeab1a34d4a6b4b636e070a38bce737"
|
||||||
, "164b7a7bfcf819e2e395fbe73b56e0a387bd64222e831fd610270cd7ea250554\
|
),
|
||||||
\9758bf75c05a994a6d034f65f8f0e6fdcaeab1a34d4a6b4b636e070a38bce737"
|
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa",
|
||||||
)
|
"dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd\
|
||||||
,
|
\dddddddddddddddddddddddddddddddddddd",
|
||||||
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
|
"fa73b0089d56a284efb0f0756c890be9b1b5dbdd8ee81a3655f83e33b2279d39\
|
||||||
, "dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd\
|
\bf3e848279a722c806b485a47e67c807b946a337bee8942674278859e13292fb"
|
||||||
\dddddddddddddddddddddddddddddddddddd"
|
),
|
||||||
, "fa73b0089d56a284efb0f0756c890be9b1b5dbdd8ee81a3655f83e33b2279d39\
|
( "0102030405060708090a0b0c0d0e0f10111213141516171819",
|
||||||
\bf3e848279a722c806b485a47e67c807b946a337bee8942674278859e13292fb"
|
"cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd\
|
||||||
)
|
\cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd",
|
||||||
,
|
"b0ba465637458c6990e5a8c5f61d4af7e576d97ff94b872de76f8050361ee3db\
|
||||||
( "0102030405060708090a0b0c0d0e0f10111213141516171819"
|
\a91ca5c11aa25eb4d679275cc5788063a5f19741120c4f2de2adebeb10a298dd"
|
||||||
, "cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd\
|
),
|
||||||
\cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd"
|
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
||||||
, "b0ba465637458c6990e5a8c5f61d4af7e576d97ff94b872de76f8050361ee3db\
|
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
||||||
\a91ca5c11aa25eb4d679275cc5788063a5f19741120c4f2de2adebeb10a298dd"
|
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
||||||
)
|
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
||||||
,
|
\aaaaaa",
|
||||||
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
"54657374205573696e67204c6172676572205468616e20426c6f636b2d53697a\
|
||||||
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
\65204b6579202d2048617368204b6579204669727374",
|
||||||
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
"80b24263c7c1a3ebb71493c1dd7be8b49b46d1f41b4aeec1121b013783f8f352\
|
||||||
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
\6b56d037e05f2598bd0fd2215d6a1e5295e64f73f63f0aec8b915a985d786598"
|
||||||
\aaaaaa"
|
),
|
||||||
, "54657374205573696e67204c6172676572205468616e20426c6f636b2d53697a\
|
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
||||||
\65204b6579202d2048617368204b6579204669727374"
|
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
||||||
, "80b24263c7c1a3ebb71493c1dd7be8b49b46d1f41b4aeec1121b013783f8f352\
|
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
||||||
\6b56d037e05f2598bd0fd2215d6a1e5295e64f73f63f0aec8b915a985d786598"
|
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
||||||
)
|
\aaaaaa",
|
||||||
,
|
"5468697320697320612074657374207573696e672061206c6172676572207468\
|
||||||
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
\616e20626c6f636b2d73697a65206b657920616e642061206c61726765722074\
|
||||||
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
\68616e20626c6f636b2d73697a6520646174612e20546865206b6579206e6565\
|
||||||
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
\647320746f20626520686173686564206265666f7265206265696e6720757365\
|
||||||
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
|
\642062792074686520484d414320616c676f726974686d2e",
|
||||||
\aaaaaa"
|
"e37b6a775dc87dbaa4dfa9f96e5e3ffddebd71f8867289865df5a32d20cdc944\
|
||||||
, "5468697320697320612074657374207573696e672061206c6172676572207468\
|
\b6022cac3c4982b10d5eeb55c3e4de15134676fb6de0446065c97440fa8c6a58"
|
||||||
\616e20626c6f636b2d73697a65206b657920616e642061206c61726765722074\
|
),
|
||||||
\68616e20626c6f636b2d73697a6520646174612e20546865206b6579206e6565\
|
-- Test case with key length 127 bytes.
|
||||||
\647320746f20626520686173686564206265666f7265206265696e6720757365\
|
|
||||||
\642062792074686520484d414320616c676f726974686d2e"
|
|
||||||
, "e37b6a775dc87dbaa4dfa9f96e5e3ffddebd71f8867289865df5a32d20cdc944\
|
|
||||||
\b6022cac3c4982b10d5eeb55c3e4de15134676fb6de0446065c97440fa8c6a58"
|
|
||||||
)
|
|
||||||
, -- Test case with key length 127 bytes.
|
|
||||||
|
|
||||||
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
|
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
|
||||||
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
|
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
|
||||||
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
|
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
|
||||||
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566"
|
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566",
|
||||||
, "7768617420646f2079612077616e7420666f72206e6f7468696e673f"
|
"7768617420646f2079612077616e7420666f72206e6f7468696e673f",
|
||||||
, "267424dfb8eeb999f3e5ec39a4fe9fd14c923e6187e0897063e5c9e02b2e624a\
|
"267424dfb8eeb999f3e5ec39a4fe9fd14c923e6187e0897063e5c9e02b2e624a\
|
||||||
\c04413e762977df71a9fb5d562b37f89dfdfb930fce2ed1fa783bbc2a203d80e"
|
\c04413e762977df71a9fb5d562b37f89dfdfb930fce2ed1fa783bbc2a203d80e"
|
||||||
)
|
),
|
||||||
, -- Test case with key length 128 bytes.
|
-- Test case with key length 128 bytes.
|
||||||
|
|
||||||
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
|
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
|
||||||
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
|
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
|
||||||
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
|
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
|
||||||
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665"
|
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665",
|
||||||
, "7768617420646f2079612077616e7420666f72206e6f7468696e673f"
|
"7768617420646f2079612077616e7420666f72206e6f7468696e673f",
|
||||||
, "43aaac07bb1dd97c82c04df921f83b16a68d76815cd1a30d3455ad43a3d80484\
|
"43aaac07bb1dd97c82c04df921f83b16a68d76815cd1a30d3455ad43a3d80484\
|
||||||
\2bb35462be42cc2e4b5902de4d204c1c66d93b47d1383e3e13a3788687d61258"
|
\2bb35462be42cc2e4b5902de4d204c1c66d93b47d1383e3e13a3788687d61258"
|
||||||
)
|
),
|
||||||
, -- Test case with key length 129 bytes.
|
-- Test case with key length 129 bytes.
|
||||||
|
|
||||||
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
|
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
|
||||||
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
|
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
|
||||||
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
|
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
|
||||||
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
|
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
|
||||||
\4a"
|
\4a",
|
||||||
, "7768617420646f2079612077616e7420666f72206e6f7468696e673f"
|
"7768617420646f2079612077616e7420666f72206e6f7468696e673f",
|
||||||
, "0b273325191cfc1b4b71d5075c8fcad67696309d292b1dad2cd23983a35feb8e\
|
"0b273325191cfc1b4b71d5075c8fcad67696309d292b1dad2cd23983a35feb8e\
|
||||||
\fb29795e79f2ef27f68cb1e16d76178c307a67beaad9456fac5fdffeadb16e2c"
|
\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 #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Haskoin.Crypto.SignatureSpec (spec) where
|
module Haskoin.Crypto.SignatureSpec (spec) where
|
||||||
@ -5,114 +7,120 @@ module Haskoin.Crypto.SignatureSpec (spec) where
|
|||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Data.Bits (testBit)
|
import Data.Bits (testBit)
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
import qualified Data.ByteString as BS
|
import Data.ByteString qualified as BS
|
||||||
import Data.Map.Strict (Map)
|
import Data.Map.Strict (Map)
|
||||||
import qualified Data.Map.Strict as Map
|
import Data.Map.Strict qualified as Map
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.Serialize as S
|
import Data.Serialize as S
|
||||||
import Data.String.Conversions (cs)
|
import Data.String.Conversions (cs)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Haskoin.Address
|
import Haskoin.Address
|
||||||
import Haskoin.Constants
|
|
||||||
import Haskoin.Crypto
|
import Haskoin.Crypto
|
||||||
import Haskoin.Keys
|
import Haskoin.Network.Constants
|
||||||
import Haskoin.Script
|
import Haskoin.Script
|
||||||
import Haskoin.Transaction
|
import Haskoin.Transaction
|
||||||
import Haskoin.Util
|
import Haskoin.Util
|
||||||
import Haskoin.Util.Arbitrary
|
import Haskoin.Util.Arbitrary
|
||||||
import Haskoin.UtilSpec (readTestFile)
|
|
||||||
import Test.HUnit
|
import Test.HUnit
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
import Test.Hspec.QuickCheck
|
import Test.Hspec.QuickCheck
|
||||||
import Test.QuickCheck
|
import Test.QuickCheck
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = do
|
spec = prepareContext $ \ctx -> do
|
||||||
describe "Signature properties" $ do
|
describe "Signature property checks" $ do
|
||||||
prop "verify signature" $
|
prop "verifies signature" $
|
||||||
forAll arbitrarySignature $ \(m, key', sig) ->
|
forAll (arbitrarySignature ctx) $ \(m, key', sig) ->
|
||||||
verifyHashSig m sig (derivePubKey key')
|
verifyHashSig ctx m sig (derivePubKey ctx key')
|
||||||
prop "s component less than half order" $
|
prop "s component less than half order" $
|
||||||
forAll arbitrarySignature $ isCanonicalHalfOrder . lst3
|
forAll (arbitrarySignature ctx) $
|
||||||
prop "encoded signature is canonical" $
|
isCanonicalHalfOrder ctx . lst3
|
||||||
forAll arbitrarySignature $ testIsCanonical . lst3
|
prop "encoded signature is canonical" $
|
||||||
prop "decodeStrictSig . exportSig identity" $
|
forAll (arbitrarySignature ctx) $
|
||||||
forAll arbitrarySignature $
|
testIsCanonical ctx . lst3
|
||||||
(\s -> decodeStrictSig (exportSig s) == Just s) . lst3
|
prop "decodeStrictSig . exportSig identity" $
|
||||||
prop "importSig . exportSig identity" $
|
forAll (arbitrarySignature ctx) $
|
||||||
forAll arbitrarySignature $
|
(\s -> decodeStrictSig ctx (exportSig ctx s) == Just s) . lst3
|
||||||
(\s -> importSig (exportSig s) == Just s) . lst3
|
prop "importSig . exportSig identity" $
|
||||||
prop "getSig . putSig identity" $
|
forAll (arbitrarySignature ctx) $
|
||||||
forAll arbitrarySignature $
|
(\s -> importSig ctx (exportSig ctx s) == Just s) . lst3
|
||||||
(\s -> runGet getSig (runPut $ putSig s) == Right s) . lst3
|
prop "signature JSON identity" $
|
||||||
describe "Signature vectors" $
|
forAll (arbitrarySignature ctx) $
|
||||||
checkDistSig $ \file1 file2 -> do
|
(\s -> (unmarshalJSON ctx . marshalJSON ctx) s == Just s) . lst3
|
||||||
vectors <- runIO (readTestFile file1 :: IO [(Text, Text, Text)])
|
prop "getSig . putSig identity" $
|
||||||
vectorsDER <- runIO (readTestFile file2 :: IO [(Text, Text, Text)])
|
forAll (arbitrarySignature ctx) $
|
||||||
it "Passes the trezor rfc6979 test vectors" $
|
(\s -> unmarshal ctx (marshal ctx s) == Right s) . lst3
|
||||||
mapM_ (testRFC6979Vector . toVector) vectors
|
describe "Signature vectors" $ do
|
||||||
it "Passes the rfc6979 DER test vectors" $
|
it "passes RFC6979 test vectors" $
|
||||||
mapM_ (testRFC6979DERVector . toVector) vectorsDER
|
checkDistSig ctx $ \file1 file2 -> do
|
||||||
describe "BIP143 signature vectors" $ do
|
vectors <- readTestFile file1 :: IO [(Text, Text, Text)]
|
||||||
it "agrees with BIP143 p2wpkh example" testBip143p2wpkh
|
vectorsDER <- readTestFile file2 :: IO [(Text, Text, Text)]
|
||||||
it "agrees with BIP143 p2sh-p2wpkh example" testBip143p2shp2wpkh
|
mapM_ (testRFC6979Vector ctx . toVector) vectors
|
||||||
it "builds a p2wsh multisig transaction" testP2WSHMulsig
|
mapM_ (testRFC6979DERVector ctx . toVector) vectorsDER
|
||||||
it "agrees with BIP143 p2sh-p2wsh multisig example" testBip143p2shp2wpkhMulsig
|
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
|
-- github.com/bitcoin/bitcoin/blob/master/src/script.cpp
|
||||||
-- from function IsCanonicalSignature
|
-- from function IsCanonicalSignature
|
||||||
testIsCanonical :: Sig -> Bool
|
testIsCanonical :: Ctx -> Sig -> Bool
|
||||||
testIsCanonical sig =
|
testIsCanonical ctx sig =
|
||||||
not $
|
not $
|
||||||
-- Non-canonical signature: too short
|
-- Non-canonical signature: too short
|
||||||
(len < 8)
|
(len < 8)
|
||||||
||
|
||
|
||||||
-- Non-canonical signature: too long
|
-- Non-canonical signature: too long
|
||||||
(len > 72)
|
(len > 72)
|
||||||
||
|
||
|
||||||
-- Non-canonical signature: wrong type
|
-- Non-canonical signature: wrong type
|
||||||
(BS.index s 0 /= 0x30)
|
(BS.index s 0 /= 0x30)
|
||||||
||
|
||
|
||||||
-- Non-canonical signature: wrong length marker
|
-- Non-canonical signature: wrong length marker
|
||||||
(BS.index s 1 /= len - 2)
|
(BS.index s 1 /= len - 2)
|
||||||
||
|
||
|
||||||
-- Non-canonical signature: S length misplaced
|
-- Non-canonical signature: S length misplaced
|
||||||
(5 + rlen >= len)
|
(5 + rlen >= len)
|
||||||
||
|
||
|
||||||
-- Non-canonical signature: R+S length mismatch
|
-- Non-canonical signature: R+S length mismatch
|
||||||
(rlen + slen + 6 /= len)
|
(rlen + slen + 6 /= len)
|
||||||
||
|
||
|
||||||
-- Non-canonical signature: R value type mismatch
|
-- Non-canonical signature: R value type mismatch
|
||||||
(BS.index s 2 /= 0x02)
|
(BS.index s 2 /= 0x02)
|
||||||
||
|
||
|
||||||
-- Non-canonical signature: R length is zero
|
-- Non-canonical signature: R length is zero
|
||||||
(rlen == 0)
|
(rlen == 0)
|
||||||
||
|
||
|
||||||
-- Non-canonical signature: R value negative
|
-- Non-canonical signature: R value negative
|
||||||
testBit (BS.index s 4) 7
|
testBit (BS.index s 4) 7
|
||||||
||
|
||
|
||||||
-- Non-canonical signature: R value excessively padded
|
-- Non-canonical signature: R value excessively padded
|
||||||
( rlen > 1
|
( rlen > 1
|
||||||
&& BS.index s 4 == 0
|
&& BS.index s 4 == 0
|
||||||
&& not (testBit (BS.index s 5) 7)
|
&& not (testBit (BS.index s 5) 7)
|
||||||
)
|
)
|
||||||
||
|
||
|
||||||
-- Non-canonical signature: S value type mismatch
|
-- Non-canonical signature: S value type mismatch
|
||||||
(BS.index s (fromIntegral rlen + 4) /= 0x02)
|
(BS.index s (fromIntegral rlen + 4) /= 0x02)
|
||||||
||
|
||
|
||||||
-- Non-canonical signature: S length is zero
|
-- Non-canonical signature: S length is zero
|
||||||
(slen == 0)
|
(slen == 0)
|
||||||
||
|
||
|
||||||
-- Non-canonical signature: S value negative
|
-- Non-canonical signature: S value negative
|
||||||
testBit (BS.index s (fromIntegral rlen + 6)) 7
|
testBit (BS.index s (fromIntegral rlen + 6)) 7
|
||||||
||
|
||
|
||||||
-- Non-canonical signature: S value excessively padded
|
-- Non-canonical signature: S value excessively padded
|
||||||
( slen > 1
|
( slen > 1
|
||||||
&& BS.index s (fromIntegral rlen + 6) == 0
|
&& BS.index s (fromIntegral rlen + 6) == 0
|
||||||
&& not (testBit (BS.index s (fromIntegral rlen + 7)) 7)
|
&& not (testBit (BS.index s (fromIntegral rlen + 7)) 7)
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
s = exportSig sig
|
s = exportSig ctx sig
|
||||||
len = fromIntegral $ BS.length s
|
len = fromIntegral $ BS.length s
|
||||||
rlen = BS.index s 3
|
rlen = BS.index s 3
|
||||||
slen = BS.index s (fromIntegral rlen + 5)
|
slen = BS.index s (fromIntegral rlen + 5)
|
||||||
@ -123,49 +131,46 @@ testIsCanonical sig =
|
|||||||
-- between implementations. We check the output of signMsg 1 0
|
-- between implementations. We check the output of signMsg 1 0
|
||||||
|
|
||||||
data ValidImpl
|
data ValidImpl
|
||||||
= ImplCore
|
= ImplCore
|
||||||
| ImplABC
|
| ImplCash
|
||||||
|
|
||||||
implSig :: Text
|
implSig :: Ctx -> Text
|
||||||
implSig =
|
implSig ctx =
|
||||||
encodeHex $
|
encodeHex $
|
||||||
exportSig $
|
exportSig ctx $
|
||||||
signMsg
|
signMsg
|
||||||
"0000000000000000000000000000000000000000000000000000000000000001"
|
ctx
|
||||||
"0000000000000000000000000000000000000000000000000000000000000000"
|
"0000000000000000000000000000000000000000000000000000000000000001"
|
||||||
|
"0000000000000000000000000000000000000000000000000000000000000000"
|
||||||
|
|
||||||
-- We have test vectors for these cases
|
-- We have test vectors for these cases
|
||||||
validImplMap :: Map Text ValidImpl
|
validImplMap :: Map Text ValidImpl
|
||||||
validImplMap =
|
validImplMap =
|
||||||
Map.fromList
|
Map.fromList
|
||||||
[
|
[ ( "3045022100a0b37f8fba683cc68f6574cd43b39f0343a50008bf6ccea9d13231\
|
||||||
( "3045022100a0b37f8fba683cc68f6574cd43b39f0343a50008bf6ccea9d13231\
|
\d9e7e2e1e4022011edc8d307254296264aebfc3dc76cd8b668373a072fd64665\
|
||||||
\d9e7e2e1e4022011edc8d307254296264aebfc3dc76cd8b668373a072fd64665\
|
\b50000e9fcce52",
|
||||||
\b50000e9fcce52"
|
ImplCore
|
||||||
, ImplCore
|
),
|
||||||
)
|
( "304402200581361d23e645be9e3efe63a9a2ac2e8dd0c70ba3ac8554c9befe06\
|
||||||
,
|
\0ad0b36202207d8172f1e259395834793d81b17e986f1e6131e4734969d2f4ae\
|
||||||
( "304402200581361d23e645be9e3efe63a9a2ac2e8dd0c70ba3ac8554c9befe06\
|
\3a9c8bc42965",
|
||||||
\0ad0b36202207d8172f1e259395834793d81b17e986f1e6131e4734969d2f4ae\
|
ImplCash
|
||||||
\3a9c8bc42965"
|
)
|
||||||
, ImplABC
|
]
|
||||||
)
|
|
||||||
]
|
|
||||||
|
|
||||||
getImpl :: Maybe ValidImpl
|
getImpl :: Ctx -> Maybe ValidImpl
|
||||||
getImpl = implSig `Map.lookup` validImplMap
|
getImpl ctx = implSig ctx `Map.lookup` validImplMap
|
||||||
|
|
||||||
rfc6979files :: ValidImpl -> (FilePath, FilePath)
|
rfc6979files :: ValidImpl -> (FilePath, FilePath)
|
||||||
rfc6979files ImplCore = ("rfc6979core.json", "rfc6979DERcore.json")
|
rfc6979files ImplCore = ("rfc6979core.json", "rfc6979DERcore.json")
|
||||||
rfc6979files ImplABC = ("rfc6979abc.json", "rfc6979DERabc.json")
|
rfc6979files ImplCash = ("rfc6979cash.json", "rfc6979DERcash.json")
|
||||||
|
|
||||||
checkDistSig :: (FilePath -> FilePath -> Spec) -> Spec
|
checkDistSig :: Ctx -> (FilePath -> FilePath -> Assertion) -> Assertion
|
||||||
checkDistSig go =
|
checkDistSig ctx go =
|
||||||
case rfc6979files <$> getImpl of
|
case rfc6979files <$> getImpl ctx of
|
||||||
Just (file1, file2) -> go file1 file2
|
Just (file1, file2) -> go file1 file2
|
||||||
_ ->
|
_ -> assertFailure "invalid RFC6979 signature"
|
||||||
it "Passes rfc6979 test vectors" $
|
|
||||||
void $ assertFailure "Invalid rfc6979 signature"
|
|
||||||
|
|
||||||
{- Trezor RFC 6979 Test Vectors -}
|
{- Trezor RFC 6979 Test Vectors -}
|
||||||
-- github.com/trezor/python-ecdsa/blob/master/ecdsa/test_pyecdsa.py
|
-- 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 :: (Text, Text, Text) -> (SecKey, ByteString, Text)
|
||||||
toVector (prv, m, res) = (fromJust $ (secKey <=< decodeHex) prv, cs m, res)
|
toVector (prv, m, res) = (fromJust $ (secKey <=< decodeHex) prv, cs m, res)
|
||||||
|
|
||||||
testRFC6979Vector :: (SecKey, ByteString, Text) -> Assertion
|
testRFC6979Vector :: Ctx -> (SecKey, ByteString, Text) -> Assertion
|
||||||
testRFC6979Vector (prv, m, res) = do
|
testRFC6979Vector ctx (prv, m, res) = do
|
||||||
assertEqual "RFC 6979 Vector" res (encodeHex $ encode $ exportCompactSig s)
|
assertEqual "RFC 6979 Vector" res (encodeHex (exportCompactSig ctx s).get)
|
||||||
assertBool "Signature is valid" $ verifyHashSig h s (derivePubKey prv)
|
assertBool "Signature is valid" $ verifyHashSig ctx h s (derivePubKey ctx prv)
|
||||||
assertBool "Signature is canonical" $ testIsCanonical s
|
assertBool "Signature is canonical" $ testIsCanonical ctx s
|
||||||
assertBool "Signature is normalized" $ isCanonicalHalfOrder s
|
assertBool "Signature is normalized" $ isCanonicalHalfOrder ctx s
|
||||||
where
|
where
|
||||||
h = sha256 m
|
h = sha256 m
|
||||||
s = signHash prv h
|
s = signHash ctx prv h
|
||||||
|
|
||||||
-- Test vectors from:
|
-- Test vectors from:
|
||||||
-- https://crypto.stackexchange.com/questions/20838/request-for-data-to-test-deterministic-ecdsa-signature-algorithm-for-secp256k1
|
-- https://crypto.stackexchange.com/questions/20838/request-for-data-to-test-deterministic-ecdsa-signature-algorithm-for-secp256k1
|
||||||
|
|
||||||
testRFC6979DERVector :: (SecKey, ByteString, Text) -> Assertion
|
testRFC6979DERVector :: Ctx -> (SecKey, ByteString, Text) -> Assertion
|
||||||
testRFC6979DERVector (prv, m, res) = do
|
testRFC6979DERVector ctx (prv, m, res) = do
|
||||||
assertEqual "RFC 6979 DER Vector" res (encodeHex $ exportSig s)
|
assertEqual "RFC 6979 DER Vector" res (encodeHex $ exportSig ctx s)
|
||||||
assertBool "DER Signature is valid" $ verifyHashSig h s (derivePubKey prv)
|
assertBool "DER Signature is valid" $ verifyHashSig ctx h s (derivePubKey ctx prv)
|
||||||
assertBool "DER Signature is canonical" $ testIsCanonical s
|
assertBool "DER Signature is canonical" $ testIsCanonical ctx s
|
||||||
assertBool "DER Signature is normalized" $ isCanonicalHalfOrder s
|
assertBool "DER Signature is normalized" $ isCanonicalHalfOrder ctx s
|
||||||
where
|
where
|
||||||
h = sha256 m
|
h = sha256 m
|
||||||
s = signHash prv h
|
s = signHash ctx prv h
|
||||||
|
|
||||||
-- Reproduce the P2WPKH example from BIP 143
|
-- Reproduce the P2WPKH example from BIP 143
|
||||||
testBip143p2wpkh :: Assertion
|
testBip143p2wpkh :: Ctx -> Assertion
|
||||||
testBip143p2wpkh =
|
testBip143p2wpkh ctx =
|
||||||
case getImpl of
|
case getImpl ctx of
|
||||||
Just ImplCore ->
|
Just ImplCore ->
|
||||||
assertEqual "BIP143 Core p2wpkh" (Right signedTxCore) generatedSignedTx
|
assertEqual "BIP143 Core p2wpkh" (Right signedTxCore) generatedSignedTx
|
||||||
Just ImplABC ->
|
Just ImplCash ->
|
||||||
assertEqual "BIP143 ABC p2wpkh" (Right signedTxABC) generatedSignedTx
|
assertEqual "BIP143 ABC p2wpkh" (Right signedTxCash) generatedSignedTx
|
||||||
Nothing -> assertFailure "Invalid secp256k1 library"
|
Nothing -> assertFailure "Invalid secp256k1 library"
|
||||||
where
|
where
|
||||||
signedTxCore =
|
signedTxCore =
|
||||||
"01000000000102fff7f7881a8099afa6940d42d1e7f6362bec38171ea3edf433\
|
"01000000000102fff7f7881a8099afa6940d42d1e7f6362bec38171ea3edf433\
|
||||||
\541db4e4ad969f00000000494830450221008b9d1dc26ba6a9cb62127b02742f\
|
\541db4e4ad969f00000000494830450221008b9d1dc26ba6a9cb62127b02742f\
|
||||||
\a9d754cd3bebf337f7a55d114c8e5cdd30be022040529b194ba3f9281a99f2b1\
|
\a9d754cd3bebf337f7a55d114c8e5cdd30be022040529b194ba3f9281a99f2b1\
|
||||||
\c0a19c0489bc22ede944ccf4ecbab4cc618ef3ed01eeffffffef51e1b804cc89\
|
\c0a19c0489bc22ede944ccf4ecbab4cc618ef3ed01eeffffffef51e1b804cc89\
|
||||||
\d182d279655c3aa89e815b1b309fe287d9b2b55d57b90ec68a0100000000ffff\
|
\d182d279655c3aa89e815b1b309fe287d9b2b55d57b90ec68a0100000000ffff\
|
||||||
\ffff02202cb206000000001976a9148280b37df378db99f66f85c95a783a76ac\
|
\ffff02202cb206000000001976a9148280b37df378db99f66f85c95a783a76ac\
|
||||||
\7a6d5988ac9093510d000000001976a9143bde42dbee7e4dbe6a21b2d50ce2f0\
|
\7a6d5988ac9093510d000000001976a9143bde42dbee7e4dbe6a21b2d50ce2f0\
|
||||||
\167faa815988ac000247304402203609e17b84f6a7d30c80bfa610b5b4542f32\
|
\167faa815988ac000247304402203609e17b84f6a7d30c80bfa610b5b4542f32\
|
||||||
\a8a0d5447a12fb1366d7f01cc44a0220573a954c4518331561406f90300e8f33\
|
\a8a0d5447a12fb1366d7f01cc44a0220573a954c4518331561406f90300e8f33\
|
||||||
\58f51928d43c212a8caed02de67eebee0121025476c2e83188368da1ff3e292e\
|
\58f51928d43c212a8caed02de67eebee0121025476c2e83188368da1ff3e292e\
|
||||||
\7acafcdb3566bb0ad253f62fc70f07aeee635711000000"
|
\7acafcdb3566bb0ad253f62fc70f07aeee635711000000"
|
||||||
signedTxABC =
|
signedTxCash =
|
||||||
"01000000000102fff7f7881a8099afa6940d42d1e7f6362bec38171ea3edf433\
|
"01000000000102fff7f7881a8099afa6940d42d1e7f6362bec38171ea3edf433\
|
||||||
\541db4e4ad969f000000004847304402200fbc9dad97500334e47c2dca50096a\
|
\541db4e4ad969f000000004847304402200fbc9dad97500334e47c2dca50096a\
|
||||||
\2117c01952c2870102e320823d21c36229022007cb36c2b141d11c08ef81d948\
|
\2117c01952c2870102e320823d21c36229022007cb36c2b141d11c08ef81d948\
|
||||||
\f148332fc09fe8f6d226aaaf8ba6ae0d8a66ba01eeffffffef51e1b804cc89d1\
|
\f148332fc09fe8f6d226aaaf8ba6ae0d8a66ba01eeffffffef51e1b804cc89d1\
|
||||||
\82d279655c3aa89e815b1b309fe287d9b2b55d57b90ec68a0100000000ffffff\
|
\82d279655c3aa89e815b1b309fe287d9b2b55d57b90ec68a0100000000ffffff\
|
||||||
\ff02202cb206000000001976a9148280b37df378db99f66f85c95a783a76ac7a\
|
\ff02202cb206000000001976a9148280b37df378db99f66f85c95a783a76ac7a\
|
||||||
\6d5988ac9093510d000000001976a9143bde42dbee7e4dbe6a21b2d50ce2f016\
|
\6d5988ac9093510d000000001976a9143bde42dbee7e4dbe6a21b2d50ce2f016\
|
||||||
\7faa815988ac0002473044022011cb891cee521eb1fc7aef681655a881288553\
|
\7faa815988ac0002473044022011cb891cee521eb1fc7aef681655a881288553\
|
||||||
\fc024cff9cee5007bae5e6b8c602200b89d60ee2f98aa9a645dad59cd680b4b6\
|
\fc024cff9cee5007bae5e6b8c602200b89d60ee2f98aa9a645dad59cd680b4b6\
|
||||||
\25f343efcd3e7fb70852100ef601890121025476c2e83188368da1ff3e292e7a\
|
\25f343efcd3e7fb70852100ef601890121025476c2e83188368da1ff3e292e7a\
|
||||||
\cafcdb3566bb0ad253f62fc70f07aeee635711000000"
|
\cafcdb3566bb0ad253f62fc70f07aeee635711000000"
|
||||||
unsignedTx =
|
unsignedTx =
|
||||||
"0100000002fff7f7881a8099afa6940d42d1e7f6362bec38171ea3edf433541d\
|
"0100000002fff7f7881a8099afa6940d42d1e7f6362bec38171ea3edf433541d\
|
||||||
\b4e4ad969f0000000000eeffffffef51e1b804cc89d182d279655c3aa89e815b\
|
\b4e4ad969f0000000000eeffffffef51e1b804cc89d182d279655c3aa89e815b\
|
||||||
\1b309fe287d9b2b55d57b90ec68a0100000000ffffffff02202cb20600000000\
|
\1b309fe287d9b2b55d57b90ec68a0100000000ffffffff02202cb20600000000\
|
||||||
\1976a9148280b37df378db99f66f85c95a783a76ac7a6d5988ac9093510d0000\
|
\1976a9148280b37df378db99f66f85c95a783a76ac7a6d5988ac9093510d0000\
|
||||||
\00001976a9143bde42dbee7e4dbe6a21b2d50ce2f0167faa815988ac11000000"
|
\00001976a9143bde42dbee7e4dbe6a21b2d50ce2f0167faa815988ac11000000"
|
||||||
Just key0 =
|
Just key0 =
|
||||||
secHexKey
|
secHexKey
|
||||||
"bbc27228ddcb9209d7fd6f36b02f7dfa6252af40bb2f1cbc7a557da8027ff866"
|
"bbc27228ddcb9209d7fd6f36b02f7dfa6252af40bb2f1cbc7a557da8027ff866"
|
||||||
pubKey0 = toPubKey key0
|
pubKey0 = toPubKey ctx key0
|
||||||
Just key1 =
|
Just key1 =
|
||||||
secHexKey
|
secHexKey
|
||||||
"619c335025c7f4012e556c2a58b2506e30b8511b53ade95ea316fd8c3286feb9"
|
"619c335025c7f4012e556c2a58b2506e30b8511b53ade95ea316fd8c3286feb9"
|
||||||
[op0, op1] = prevOutput <$> txIn unsignedTx
|
[op0, op1] = (.outpoint) <$> unsignedTx.inputs
|
||||||
sigIn0 = SigInput (PayPK pubKey0) 625000000 op0 sigHashAll Nothing
|
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
|
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
|
-- Reproduce the P2SH-P2WPKH example from BIP 143
|
||||||
testBip143p2shp2wpkh :: Assertion
|
testBip143p2shp2wpkh :: Ctx -> Assertion
|
||||||
testBip143p2shp2wpkh =
|
testBip143p2shp2wpkh ctx =
|
||||||
case getImpl of
|
case getImpl ctx of
|
||||||
Just ImplCore ->
|
Just ImplCore ->
|
||||||
assertEqual "BIP143 Core p2sh-p2wpkh" (Right signedTxCore) generatedSignedTx
|
assertEqual "BIP143 Core p2sh-p2wpkh" (Right signedTxCore) generatedSignedTx
|
||||||
Just ImplABC ->
|
Just ImplCash ->
|
||||||
assertEqual "BIP143 ABC p2sh-p2wpkh" (Right signedTxABC) generatedSignedTx
|
assertEqual "BIP143 Cash p2sh-p2wpkh" (Right signedTxCash) generatedSignedTx
|
||||||
Nothing -> assertFailure "Invalid secp256k1 library"
|
Nothing -> assertFailure "Invalid secp256k1 library"
|
||||||
where
|
where
|
||||||
signedTxCore =
|
signedTxCore =
|
||||||
"01000000000101db6b1b20aa0fd7b23880be2ecbd4a98130974cf4748fb66092\
|
"01000000000101db6b1b20aa0fd7b23880be2ecbd4a98130974cf4748fb66092\
|
||||||
\ac4d3ceb1a5477010000001716001479091972186c449eb1ded22b78e40d009b\
|
\ac4d3ceb1a5477010000001716001479091972186c449eb1ded22b78e40d009b\
|
||||||
\df0089feffffff02b8b4eb0b000000001976a914a457b684d7f0d539a46a45bb\
|
\df0089feffffff02b8b4eb0b000000001976a914a457b684d7f0d539a46a45bb\
|
||||||
\c043f35b59d0d96388ac0008af2f000000001976a914fd270b1ee6abcaea97fe\
|
\c043f35b59d0d96388ac0008af2f000000001976a914fd270b1ee6abcaea97fe\
|
||||||
\a7ad0402e8bd8ad6d77c88ac02473044022047ac8e878352d3ebbde1c94ce3a1\
|
\a7ad0402e8bd8ad6d77c88ac02473044022047ac8e878352d3ebbde1c94ce3a1\
|
||||||
\0d057c24175747116f8288e5d794d12d482f0220217f36a485cae903c713331d\
|
\0d057c24175747116f8288e5d794d12d482f0220217f36a485cae903c713331d\
|
||||||
\877c1f64677e3622ad4010726870540656fe9dcb012103ad1d8e89212f0b92c7\
|
\877c1f64677e3622ad4010726870540656fe9dcb012103ad1d8e89212f0b92c7\
|
||||||
\4d23bb710c00662ad1470198ac48c43f7d6f93a2a2687392040000"
|
\4d23bb710c00662ad1470198ac48c43f7d6f93a2a2687392040000"
|
||||||
signedTxABC =
|
signedTxCash =
|
||||||
"01000000000101db6b1b20aa0fd7b23880be2ecbd4a98130974cf4748fb66092\
|
"01000000000101db6b1b20aa0fd7b23880be2ecbd4a98130974cf4748fb66092\
|
||||||
\ac4d3ceb1a5477010000001716001479091972186c449eb1ded22b78e40d009b\
|
\ac4d3ceb1a5477010000001716001479091972186c449eb1ded22b78e40d009b\
|
||||||
\df0089feffffff02b8b4eb0b000000001976a914a457b684d7f0d539a46a45bb\
|
\df0089feffffff02b8b4eb0b000000001976a914a457b684d7f0d539a46a45bb\
|
||||||
\c043f35b59d0d96388ac0008af2f000000001976a914fd270b1ee6abcaea97fe\
|
\c043f35b59d0d96388ac0008af2f000000001976a914fd270b1ee6abcaea97fe\
|
||||||
\a7ad0402e8bd8ad6d77c88ac024730440220091c78fd1e21535f6ddc45515e4c\
|
\a7ad0402e8bd8ad6d77c88ac024730440220091c78fd1e21535f6ddc45515e4c\
|
||||||
\afca15cdf344765d72c1529fb82d3ada2d1802204a980d5e37d0b04f5e1185a0\
|
\afca15cdf344765d72c1529fb82d3ada2d1802204a980d5e37d0b04f5e1185a0\
|
||||||
\f97295c383764e9a4b08d8bd1161b33c6719139a012103ad1d8e89212f0b92c7\
|
\f97295c383764e9a4b08d8bd1161b33c6719139a012103ad1d8e89212f0b92c7\
|
||||||
\4d23bb710c00662ad1470198ac48c43f7d6f93a2a2687392040000"
|
\4d23bb710c00662ad1470198ac48c43f7d6f93a2a2687392040000"
|
||||||
unsignedTx =
|
unsignedTx =
|
||||||
"0100000001db6b1b20aa0fd7b23880be2ecbd4a98130974cf4748fb66092ac4d\
|
"0100000001db6b1b20aa0fd7b23880be2ecbd4a98130974cf4748fb66092ac4d\
|
||||||
\3ceb1a54770100000000feffffff02b8b4eb0b000000001976a914a457b684d7\
|
\3ceb1a54770100000000feffffff02b8b4eb0b000000001976a914a457b684d7\
|
||||||
\f0d539a46a45bbc043f35b59d0d96388ac0008af2f000000001976a914fd270b\
|
\f0d539a46a45bbc043f35b59d0d96388ac0008af2f000000001976a914fd270b\
|
||||||
\1ee6abcaea97fea7ad0402e8bd8ad6d77c88ac92040000"
|
\1ee6abcaea97fea7ad0402e8bd8ad6d77c88ac92040000"
|
||||||
Just key0 =
|
Just key0 =
|
||||||
secHexKey
|
secHexKey
|
||||||
"eb696a065ef48a2192da5b28b694f87544b30fae8327c4510137a922f32c6dcf"
|
"eb696a065ef48a2192da5b28b694f87544b30fae8327c4510137a922f32c6dcf"
|
||||||
op0 = prevOutput . head $ txIn unsignedTx
|
op0 = (head unsignedTx.inputs).outpoint
|
||||||
WitnessPubKeyAddress h = pubKeyWitnessAddr $ toPubKey key0
|
WitnessPubKeyAddress h = pubKeyWitnessAddr ctx $ toPubKey ctx key0
|
||||||
sigIn0 = SigInput (PayWitnessPKHash h) 1000000000 op0 sigHashAll Nothing
|
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)
|
-- P2WSH multisig example (tested against bitcoin-core 0.19.0.1)
|
||||||
testP2WSHMulsig :: Assertion
|
testP2WSHMulsig :: Ctx -> Assertion
|
||||||
testP2WSHMulsig =
|
testP2WSHMulsig ctx =
|
||||||
case getImpl of
|
case getImpl ctx of
|
||||||
Just ImplCore ->
|
Just ImplCore ->
|
||||||
assertEqual "Core p2wsh multisig" (Right signedTxCore) generatedSignedTx
|
assertEqual "Core p2wsh multisig" (Right signedTxCore) generatedSignedTx
|
||||||
Just ImplABC ->
|
Just ImplCash ->
|
||||||
assertEqual "ABC p2wsh multisig" (Right signedTxABC) generatedSignedTx
|
assertEqual "Cash p2wsh multisig" (Right signedTxCash) generatedSignedTx
|
||||||
Nothing -> assertFailure "Invalid secp256k1 library"
|
Nothing -> assertFailure "Invalid secp256k1 library"
|
||||||
where
|
where
|
||||||
signedTxCore =
|
signedTxCore =
|
||||||
"01000000000101d2e34df5d7ee565208eddd231548916b9b0e99f4f5071f8961\
|
"01000000000101d2e34df5d7ee565208eddd231548916b9b0e99f4f5071f8961\
|
||||||
\34a448c5fb07bf0100000000ffffffff01f0b9f505000000001976a9143d5a35\
|
\34a448c5fb07bf0100000000ffffffff01f0b9f505000000001976a9143d5a35\
|
||||||
\2cab583b12fbcb26d1269b4a2c951a33ad88ac0400483045022100fad4fedd2b\
|
\2cab583b12fbcb26d1269b4a2c951a33ad88ac0400483045022100fad4fedd2b\
|
||||||
\b4c439c64637eb8e9150d9020a7212808b8dc0578d5ff5b4ad65fe0220714640\
|
\b4c439c64637eb8e9150d9020a7212808b8dc0578d5ff5b4ad65fe0220714640\
|
||||||
\f261b37eb3106310bf853f4b706e51436fb6b64c2ab00768814eb55b98014730\
|
\f261b37eb3106310bf853f4b706e51436fb6b64c2ab00768814eb55b98014730\
|
||||||
\44022100baff4e4ceea4022b9725a2e6f6d77997a554f858165b91ac8c16c983\
|
\44022100baff4e4ceea4022b9725a2e6f6d77997a554f858165b91ac8c16c983\
|
||||||
\3008bee9021f5f70ebc3f8580dc0a5e96451e3697bdf1f1f5883944f0f33ab0c\
|
\3008bee9021f5f70ebc3f8580dc0a5e96451e3697bdf1f1f5883944f0f33ab0c\
|
||||||
\fb272354040169522102ba46d3bb8db74c77c6cf082db57fc0548058fcdea811\
|
\fb272354040169522102ba46d3bb8db74c77c6cf082db57fc0548058fcdea811\
|
||||||
\549e186526e3d10caf6721038ac8aef2dd9cea5e7d66e2f6e23f177a6c21f69e\
|
\549e186526e3d10caf6721038ac8aef2dd9cea5e7d66e2f6e23f177a6c21f69e\
|
||||||
\a311fa0c85d81badb6b37ceb2103d96d2bfbbc040faaf93491d69e2bfe9695e2\
|
\a311fa0c85d81badb6b37ceb2103d96d2bfbbc040faaf93491d69e2bfe9695e2\
|
||||||
\d8e007a7f26db96c2ee42db15dc953ae00000000"
|
\d8e007a7f26db96c2ee42db15dc953ae00000000"
|
||||||
signedTxABC =
|
signedTxCash =
|
||||||
"01000000000101d2e34df5d7ee565208eddd231548916b9b0e99f4f5071f8961\
|
"01000000000101d2e34df5d7ee565208eddd231548916b9b0e99f4f5071f8961\
|
||||||
\34a448c5fb07bf0100000000ffffffff01f0b9f505000000001976a9143d5a35\
|
\34a448c5fb07bf0100000000ffffffff01f0b9f505000000001976a9143d5a35\
|
||||||
\2cab583b12fbcb26d1269b4a2c951a33ad88ac0400483045022100b79bf3714a\
|
\2cab583b12fbcb26d1269b4a2c951a33ad88ac0400483045022100b79bf3714a\
|
||||||
\50f8f0e2f946034361ba4f6567b796d55910d89e98720d2e99f98c0220134879\
|
\50f8f0e2f946034361ba4f6567b796d55910d89e98720d2e99f98c0220134879\
|
||||||
\518002df23e80a058475fa8b10bc4182bedfecd5f85e446a00f211ea53014830\
|
\518002df23e80a058475fa8b10bc4182bedfecd5f85e446a00f211ea53014830\
|
||||||
\45022100ce3c77480d664430a7544c1a962d1ae31151109a528a37e5bccc92ba\
|
\45022100ce3c77480d664430a7544c1a962d1ae31151109a528a37e5bccc92ba\
|
||||||
\2e460ad10220317bc9a71d0c3471058d16d4c3b1ea99616208db6b9b9040fb81\
|
\2e460ad10220317bc9a71d0c3471058d16d4c3b1ea99616208db6b9b9040fb81\
|
||||||
\0a7fa27f72b40169522102ba46d3bb8db74c77c6cf082db57fc0548058fcdea8\
|
\0a7fa27f72b40169522102ba46d3bb8db74c77c6cf082db57fc0548058fcdea8\
|
||||||
\11549e186526e3d10caf6721038ac8aef2dd9cea5e7d66e2f6e23f177a6c21f6\
|
\11549e186526e3d10caf6721038ac8aef2dd9cea5e7d66e2f6e23f177a6c21f6\
|
||||||
\9ea311fa0c85d81badb6b37ceb2103d96d2bfbbc040faaf93491d69e2bfe9695\
|
\9ea311fa0c85d81badb6b37ceb2103d96d2bfbbc040faaf93491d69e2bfe9695\
|
||||||
\e2d8e007a7f26db96c2ee42db15dc953ae00000000"
|
\e2d8e007a7f26db96c2ee42db15dc953ae00000000"
|
||||||
unsignedTx =
|
unsignedTx =
|
||||||
"0100000001d2e34df5d7ee565208eddd231548916b9b0e99f4f5071f896134a4\
|
"0100000001d2e34df5d7ee565208eddd231548916b9b0e99f4f5071f896134a4\
|
||||||
\48c5fb07bf0100000000ffffffff01f0b9f505000000001976a9143d5a352cab\
|
\48c5fb07bf0100000000ffffffff01f0b9f505000000001976a9143d5a352cab\
|
||||||
\583b12fbcb26d1269b4a2c951a33ad88ac00000000"
|
\583b12fbcb26d1269b4a2c951a33ad88ac00000000"
|
||||||
op0 = head $ prevOutput <$> txIn unsignedTx
|
op0 = (head unsignedTx.inputs).outpoint
|
||||||
Just keys =
|
Just keys =
|
||||||
traverse
|
traverse
|
||||||
secHexKey
|
secHexKey
|
||||||
[ "3030303030303030303030303030303030303030303030303030303030303031"
|
[ "3030303030303030303030303030303030303030303030303030303030303031",
|
||||||
, "3030303030303030303030303030303030303030303030303030303030303032"
|
"3030303030303030303030303030303030303030303030303030303030303032",
|
||||||
, "3030303030303030303030303030303030303030303030303030303030303033"
|
"3030303030303030303030303030303030303030303030303030303030303033"
|
||||||
]
|
]
|
||||||
rdm = PayMulSig (toPubKey <$> keys) 2
|
rdm = PayMulSig (toPubKey ctx <$> keys) 2
|
||||||
sigIn =
|
sigIn =
|
||||||
SigInput
|
SigInput
|
||||||
(toP2WSH $ encodeOutput rdm)
|
(toP2WSH $ encodeOutput ctx rdm)
|
||||||
100000000
|
100000000
|
||||||
op0
|
op0
|
||||||
sigHashAll
|
sigHashAll
|
||||||
(Just rdm)
|
(Just rdm)
|
||||||
generatedSignedTx = signTx btc unsignedTx [sigIn] (take 2 keys)
|
generatedSignedTx = signTx btc ctx unsignedTx [sigIn] (take 2 keys)
|
||||||
|
|
||||||
-- Reproduce the P2SH-P2WSH multisig example from BIP 143
|
-- Reproduce the P2SH-P2WSH multisig example from BIP 143
|
||||||
testBip143p2shp2wpkhMulsig :: Assertion
|
testBip143p2shp2wpkhMulsig :: Ctx -> Assertion
|
||||||
testBip143p2shp2wpkhMulsig =
|
testBip143p2shp2wpkhMulsig ctx =
|
||||||
case getImpl of
|
case getImpl ctx of
|
||||||
Just ImplCore ->
|
Just ImplCore ->
|
||||||
assertEqual
|
assertEqual
|
||||||
"BIP143 Core p2sh-p2wsh multisig"
|
"BIP143 Core p2sh-p2wsh multisig"
|
||||||
(Right signedTxCore)
|
(Right signedTxCore)
|
||||||
generatedSignedTx
|
generatedSignedTx
|
||||||
Just ImplABC ->
|
Just ImplCash ->
|
||||||
assertEqual
|
assertEqual
|
||||||
"BIP143 Core p2sh-p2wsh multisig"
|
"BIP143 Core p2sh-p2wsh multisig"
|
||||||
(Right signedTxABC)
|
(Right signedTxCash)
|
||||||
generatedSignedTx
|
generatedSignedTx
|
||||||
Nothing -> assertFailure "Invalid secp256k1 library"
|
Nothing -> assertFailure "Invalid secp256k1 library"
|
||||||
where
|
where
|
||||||
signedTxCore =
|
signedTxCore =
|
||||||
"0100000000010136641869ca081e70f394c6948e8af409e18b619df2ed74aa10\
|
"0100000000010136641869ca081e70f394c6948e8af409e18b619df2ed74aa10\
|
||||||
\6c1ca29787b96e0100000023220020a16b5755f7f6f96dbd65f5f0d6ab9418b8\
|
\6c1ca29787b96e0100000023220020a16b5755f7f6f96dbd65f5f0d6ab9418b8\
|
||||||
\9af4b1f14a1bb8a09062c35f0dcb54ffffffff0200e9a435000000001976a914\
|
\9af4b1f14a1bb8a09062c35f0dcb54ffffffff0200e9a435000000001976a914\
|
||||||
\389ffce9cd9ae88dcc0631e88a821ffdbe9bfe2688acc0832f05000000001976\
|
\389ffce9cd9ae88dcc0631e88a821ffdbe9bfe2688acc0832f05000000001976\
|
||||||
\a9147480a33f950689af511e6e84c138dbbd3c3ee41588ac080047304402206a\
|
\a9147480a33f950689af511e6e84c138dbbd3c3ee41588ac080047304402206a\
|
||||||
\c44d672dac41f9b00e28f4df20c52eeb087207e8d758d76d92c6fab3b73e2b02\
|
\c44d672dac41f9b00e28f4df20c52eeb087207e8d758d76d92c6fab3b73e2b02\
|
||||||
\20367750dbbe19290069cba53d096f44530e4f98acaa594810388cf7409a1870\
|
\20367750dbbe19290069cba53d096f44530e4f98acaa594810388cf7409a1870\
|
||||||
\ce01473044022068c7946a43232757cbdf9176f009a928e1cd9a1a8c212f15c1\
|
\ce01473044022068c7946a43232757cbdf9176f009a928e1cd9a1a8c212f15c1\
|
||||||
\e11ac9f2925d9002205b75f937ff2f9f3c1246e547e54f62e027f64eefa26955\
|
\e11ac9f2925d9002205b75f937ff2f9f3c1246e547e54f62e027f64eefa26955\
|
||||||
\78cc6432cdabce271502473044022059ebf56d98010a932cf8ecfec54c48e613\
|
\78cc6432cdabce271502473044022059ebf56d98010a932cf8ecfec54c48e613\
|
||||||
\9ed6adb0728c09cbe1e4fa0915302e022007cd986c8fa870ff5d2b3a89139c9f\
|
\9ed6adb0728c09cbe1e4fa0915302e022007cd986c8fa870ff5d2b3a89139c9f\
|
||||||
\e7e499259875357e20fcbb15571c76795403483045022100fbefd94bd0a488d5\
|
\e7e499259875357e20fcbb15571c76795403483045022100fbefd94bd0a488d5\
|
||||||
\0b79102b5dad4ab6ced30c4069f1eaa69a4b5a763414067e02203156c6a5c9cf\
|
\0b79102b5dad4ab6ced30c4069f1eaa69a4b5a763414067e02203156c6a5c9cf\
|
||||||
\88f91265f5a942e96213afae16d83321c8b31bb342142a14d163814830450221\
|
\88f91265f5a942e96213afae16d83321c8b31bb342142a14d163814830450221\
|
||||||
\00a5263ea0553ba89221984bd7f0b13613db16e7a70c549a86de0cc0444141a4\
|
\00a5263ea0553ba89221984bd7f0b13613db16e7a70c549a86de0cc0444141a4\
|
||||||
\07022005c360ef0ae5a5d4f9f2f87a56c1546cc8268cab08c73501d6b3be2e1e\
|
\07022005c360ef0ae5a5d4f9f2f87a56c1546cc8268cab08c73501d6b3be2e1e\
|
||||||
\1a8a08824730440220525406a1482936d5a21888260dc165497a90a15669636d\
|
\1a8a08824730440220525406a1482936d5a21888260dc165497a90a15669636d\
|
||||||
\8edca6b9fe490d309c022032af0c646a34a44d1f4576bf6a4a74b67940f8faa8\
|
\8edca6b9fe490d309c022032af0c646a34a44d1f4576bf6a4a74b67940f8faa8\
|
||||||
\4c7df9abe12a01a11e2b4783cf56210307b8ae49ac90a048e9b53357a2354b33\
|
\4c7df9abe12a01a11e2b4783cf56210307b8ae49ac90a048e9b53357a2354b33\
|
||||||
\34e9c8bee813ecb98e99a7e07e8c3ba32103b28f0c28bfab54554ae8c658ac5c\
|
\34e9c8bee813ecb98e99a7e07e8c3ba32103b28f0c28bfab54554ae8c658ac5c\
|
||||||
\3e0ce6e79ad336331f78c428dd43eea8449b21034b8113d703413d57761b8b97\
|
\3e0ce6e79ad336331f78c428dd43eea8449b21034b8113d703413d57761b8b97\
|
||||||
\81957b8c0ac1dfe69f492580ca4195f50376ba4a21033400f6afecb833092a9a\
|
\81957b8c0ac1dfe69f492580ca4195f50376ba4a21033400f6afecb833092a9a\
|
||||||
\21cfdf1ed1376e58c5d1f47de74683123987e967a8f42103a6d48b1131e94ba0\
|
\21cfdf1ed1376e58c5d1f47de74683123987e967a8f42103a6d48b1131e94ba0\
|
||||||
\4d9737d61acdaa1322008af9602b3b14862c07a1789aac162102d8b661b0b330\
|
\4d9737d61acdaa1322008af9602b3b14862c07a1789aac162102d8b661b0b330\
|
||||||
\2ee2f162b09e07a55ad5dfbe673a9f01d9f0c19617681024306b56ae00000000"
|
\2ee2f162b09e07a55ad5dfbe673a9f01d9f0c19617681024306b56ae00000000"
|
||||||
signedTxABC =
|
signedTxCash =
|
||||||
"0100000000010136641869ca081e70f394c6948e8af409e18b619df2ed74aa10\
|
"0100000000010136641869ca081e70f394c6948e8af409e18b619df2ed74aa10\
|
||||||
\6c1ca29787b96e0100000023220020a16b5755f7f6f96dbd65f5f0d6ab9418b8\
|
\6c1ca29787b96e0100000023220020a16b5755f7f6f96dbd65f5f0d6ab9418b8\
|
||||||
\9af4b1f14a1bb8a09062c35f0dcb54ffffffff0200e9a435000000001976a914\
|
\9af4b1f14a1bb8a09062c35f0dcb54ffffffff0200e9a435000000001976a914\
|
||||||
\389ffce9cd9ae88dcc0631e88a821ffdbe9bfe2688acc0832f05000000001976\
|
\389ffce9cd9ae88dcc0631e88a821ffdbe9bfe2688acc0832f05000000001976\
|
||||||
\a9147480a33f950689af511e6e84c138dbbd3c3ee41588ac0800483045022100\
|
\a9147480a33f950689af511e6e84c138dbbd3c3ee41588ac0800483045022100\
|
||||||
\b70b684ef0d17b51adf71c0dae932beca5d447dd5eec03394328436bdba836e7\
|
\b70b684ef0d17b51adf71c0dae932beca5d447dd5eec03394328436bdba836e7\
|
||||||
\0220208ebfd7408d21e41da11d8287655528385429d3fe300bee241f10944339\
|
\0220208ebfd7408d21e41da11d8287655528385429d3fe300bee241f10944339\
|
||||||
\5b580147304402204b5f9bc06c8f0a252b9842ea44785853beb1638002cec5f2\
|
\5b580147304402204b5f9bc06c8f0a252b9842ea44785853beb1638002cec5f2\
|
||||||
\489d73e5f6f5109302204f3b132b32638835d4b1a651e7d18dc93c10192db553\
|
\489d73e5f6f5109302204f3b132b32638835d4b1a651e7d18dc93c10192db553\
|
||||||
\999932af6a8e3d8a153202483045022100e0ed8d3a245a138c751d74e1359aee\
|
\999932af6a8e3d8a153202483045022100e0ed8d3a245a138c751d74e1359aee\
|
||||||
\6a52476ddf33a3a9a5f0c2ad30147319650220581318187061ad0f48fc4f5c85\
|
\6a52476ddf33a3a9a5f0c2ad30147319650220581318187061ad0f48fc4f5c85\
|
||||||
\1822e554d59977005b8de4b78bf2ce2fe8399703483045022100a0a40abc581e\
|
\1822e554d59977005b8de4b78bf2ce2fe8399703483045022100a0a40abc581e\
|
||||||
\4b725775a3aa93bf0f0fd9a02ad3aa0f93483214784a47ba5387022069151c30\
|
\4b725775a3aa93bf0f0fd9a02ad3aa0f93483214784a47ba5387022069151c30\
|
||||||
\f85a7e20c8671107c5af884ee4c5a82bd06398327fa68a993f7cc64b81473044\
|
\f85a7e20c8671107c5af884ee4c5a82bd06398327fa68a993f7cc64b81473044\
|
||||||
\022016d828460f6fab3cf89ae4b87c8f02c11c798cf739967f3b7406e7367c29\
|
\022016d828460f6fab3cf89ae4b87c8f02c11c798cf739967f3b7406e7367c29\
|
||||||
\ae8b022079e82b822eb6c37a66efabc3f0b40a2b98c52f848d36463f6623cbdc\
|
\ae8b022079e82b822eb6c37a66efabc3f0b40a2b98c52f848d36463f6623cbdc\
|
||||||
\fe675812824730440220225a14ba7434858dbb5e6e0a0969ddf3b5455edaabf9\
|
\fe675812824730440220225a14ba7434858dbb5e6e0a0969ddf3b5455edaabf9\
|
||||||
\9f5773d1f59e7816b918022047ed1ab87840a74f7e9489f3af051e5fd26b790f\
|
\9f5773d1f59e7816b918022047ed1ab87840a74f7e9489f3af051e5fd26b790f\
|
||||||
\b308c79f4b0ed73c0422795d83cf56210307b8ae49ac90a048e9b53357a2354b\
|
\b308c79f4b0ed73c0422795d83cf56210307b8ae49ac90a048e9b53357a2354b\
|
||||||
\3334e9c8bee813ecb98e99a7e07e8c3ba32103b28f0c28bfab54554ae8c658ac\
|
\3334e9c8bee813ecb98e99a7e07e8c3ba32103b28f0c28bfab54554ae8c658ac\
|
||||||
\5c3e0ce6e79ad336331f78c428dd43eea8449b21034b8113d703413d57761b8b\
|
\5c3e0ce6e79ad336331f78c428dd43eea8449b21034b8113d703413d57761b8b\
|
||||||
\9781957b8c0ac1dfe69f492580ca4195f50376ba4a21033400f6afecb833092a\
|
\9781957b8c0ac1dfe69f492580ca4195f50376ba4a21033400f6afecb833092a\
|
||||||
\9a21cfdf1ed1376e58c5d1f47de74683123987e967a8f42103a6d48b1131e94b\
|
\9a21cfdf1ed1376e58c5d1f47de74683123987e967a8f42103a6d48b1131e94b\
|
||||||
\a04d9737d61acdaa1322008af9602b3b14862c07a1789aac162102d8b661b0b3\
|
\a04d9737d61acdaa1322008af9602b3b14862c07a1789aac162102d8b661b0b3\
|
||||||
\302ee2f162b09e07a55ad5dfbe673a9f01d9f0c19617681024306b56ae00000000"
|
\302ee2f162b09e07a55ad5dfbe673a9f01d9f0c19617681024306b56ae00000000"
|
||||||
unsignedTx =
|
unsignedTx =
|
||||||
"010000000136641869ca081e70f394c6948e8af409e18b619df2ed74aa106c1c\
|
"010000000136641869ca081e70f394c6948e8af409e18b619df2ed74aa106c1c\
|
||||||
\a29787b96e0100000000ffffffff0200e9a435000000001976a914389ffce9cd\
|
\a29787b96e0100000000ffffffff0200e9a435000000001976a914389ffce9cd\
|
||||||
\9ae88dcc0631e88a821ffdbe9bfe2688acc0832f05000000001976a9147480a3\
|
\9ae88dcc0631e88a821ffdbe9bfe2688acc0832f05000000001976a9147480a3\
|
||||||
\3f950689af511e6e84c138dbbd3c3ee41588ac00000000"
|
\3f950689af511e6e84c138dbbd3c3ee41588ac00000000"
|
||||||
op0 = head $ prevOutput <$> txIn unsignedTx
|
op0 = (head unsignedTx.inputs).outpoint
|
||||||
rawKeys =
|
rawKeys =
|
||||||
[ "730fff80e1413068a05b57d6a58261f07551163369787f349438ea38ca80fac6"
|
[ "730fff80e1413068a05b57d6a58261f07551163369787f349438ea38ca80fac6",
|
||||||
, "11fa3d25a17cbc22b29c44a484ba552b5a53149d106d3d853e22fdd05a2d8bb3"
|
"11fa3d25a17cbc22b29c44a484ba552b5a53149d106d3d853e22fdd05a2d8bb3",
|
||||||
, "77bf4141a87d55bdd7f3cd0bdccf6e9e642935fec45f2f30047be7b799120661"
|
"77bf4141a87d55bdd7f3cd0bdccf6e9e642935fec45f2f30047be7b799120661",
|
||||||
, "14af36970f5025ea3e8b5542c0f8ebe7763e674838d08808896b63c3351ffe49"
|
"14af36970f5025ea3e8b5542c0f8ebe7763e674838d08808896b63c3351ffe49",
|
||||||
, "fe9a95c19eef81dde2b95c1284ef39be497d128e2aa46916fb02d552485e0323"
|
"fe9a95c19eef81dde2b95c1284ef39be497d128e2aa46916fb02d552485e0323",
|
||||||
, "428a7aee9f0c2af0cd19af3cf1c78149951ea528726989b2e83e4778d2c3f890"
|
"428a7aee9f0c2af0cd19af3cf1c78149951ea528726989b2e83e4778d2c3f890"
|
||||||
]
|
]
|
||||||
Just keys = traverse secHexKey rawKeys
|
Just keys = traverse secHexKey rawKeys
|
||||||
rdm = PayMulSig (toPubKey <$> keys) 6
|
rdm = PayMulSig (toPubKey ctx <$> keys) 6
|
||||||
sigIn sh = SigInput (toP2WSH $ encodeOutput rdm) 987654321 op0 sh (Just rdm)
|
sigIn sh = SigInput (toP2WSH $ encodeOutput ctx rdm) 987654321 op0 sh (Just rdm)
|
||||||
sigHashesA = [sigHashAll, sigHashNone, sigHashSingle]
|
sigHashesA = [sigHashAll, sigHashNone, sigHashSingle]
|
||||||
sigHashesB = setAnyoneCanPayFlag <$> sigHashesA
|
sigHashesB = setAnyoneCanPay <$> sigHashesA
|
||||||
sigIns = sigIn <$> (sigHashesA <> sigHashesB)
|
sigIns = sigIn <$> (sigHashesA <> sigHashesB)
|
||||||
generatedSignedTx = foldM addSig unsignedTx $ zip sigIns keys
|
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 :: Text -> Maybe SecKey
|
||||||
secHexKey = decodeHex >=> secKey
|
secHexKey = decodeHex >=> secKey
|
||||||
|
|
||||||
toPubKey :: SecKey -> PubKeyI
|
toPubKey :: Ctx -> SecKey -> PublicKey
|
||||||
toPubKey = derivePubKeyI . wrapSecKey True
|
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 #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Haskoin.NetworkSpec (spec) where
|
module Haskoin.NetworkSpec (spec) where
|
||||||
@ -9,13 +11,12 @@ import Data.Maybe (fromJust)
|
|||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Word (Word32)
|
import Data.Word (Word32)
|
||||||
import Haskoin.Address
|
import Haskoin.Address
|
||||||
import Haskoin.Constants
|
import Haskoin.Crypto
|
||||||
import Haskoin.Keys
|
|
||||||
import Haskoin.Network
|
import Haskoin.Network
|
||||||
|
import Haskoin.Network.Constants
|
||||||
import Haskoin.Transaction
|
import Haskoin.Transaction
|
||||||
import Haskoin.Util
|
import Haskoin.Util
|
||||||
import Haskoin.Util.Arbitrary
|
import Haskoin.Util.Arbitrary
|
||||||
import Haskoin.UtilSpec (customCerealID)
|
|
||||||
import Test.HUnit (Assertion, assertBool, assertEqual)
|
import Test.HUnit (Assertion, assertBool, assertEqual)
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
import Test.Hspec.QuickCheck
|
import Test.Hspec.QuickCheck
|
||||||
@ -23,54 +24,55 @@ import Test.QuickCheck
|
|||||||
|
|
||||||
serialVals :: [SerialBox]
|
serialVals :: [SerialBox]
|
||||||
serialVals =
|
serialVals =
|
||||||
[ SerialBox arbitraryVarInt
|
[ SerialBox arbitraryVarInt,
|
||||||
, SerialBox arbitraryVarString
|
SerialBox arbitraryVarString,
|
||||||
, SerialBox arbitraryNetworkAddress
|
SerialBox arbitraryNetworkAddress,
|
||||||
, SerialBox arbitraryInvType
|
SerialBox arbitraryInvType,
|
||||||
, SerialBox arbitraryInvVector
|
SerialBox arbitraryInvVector,
|
||||||
, SerialBox arbitraryInv1
|
SerialBox arbitraryInv1,
|
||||||
, SerialBox arbitraryVersion
|
SerialBox arbitraryVersion,
|
||||||
, SerialBox arbitraryAddr1
|
SerialBox arbitraryAddr1,
|
||||||
, SerialBox arbitraryAlert
|
SerialBox arbitraryAlert,
|
||||||
, SerialBox arbitraryReject
|
SerialBox arbitraryReject,
|
||||||
, SerialBox arbitraryRejectCode
|
SerialBox arbitraryRejectCode,
|
||||||
, SerialBox arbitraryGetData
|
SerialBox arbitraryGetData,
|
||||||
, SerialBox arbitraryNotFound
|
SerialBox arbitraryNotFound,
|
||||||
, SerialBox arbitraryPing
|
SerialBox arbitraryPing,
|
||||||
, SerialBox arbitraryPong
|
SerialBox arbitraryPong,
|
||||||
, SerialBox arbitraryMessageCommand
|
SerialBox arbitraryMessageCommand,
|
||||||
, SerialBox arbitraryMessageHeader
|
SerialBox arbitraryMessageHeader,
|
||||||
, SerialBox arbitraryBloomFlags
|
SerialBox arbitraryBloomFlags,
|
||||||
, SerialBox arbitraryBloomFilter
|
SerialBox arbitraryBloomFilter,
|
||||||
, SerialBox arbitraryFilterLoad
|
SerialBox arbitraryFilterLoad,
|
||||||
, SerialBox arbitraryFilterAdd
|
SerialBox arbitraryFilterAdd
|
||||||
]
|
]
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = do
|
spec = prepareContext $ \ctx -> do
|
||||||
testIdentity serialVals [] [] []
|
testIdentity serialVals [] [] []
|
||||||
describe "Custom identity tests" $ do
|
describe "Custom identity tests" $ do
|
||||||
prop "Data.Serialize Encoding for type Message" $
|
prop "Data.Serialize Encoding for type Message" $
|
||||||
forAll arbitraryNetwork $ \net ->
|
forAll arbitraryNetwork $ \net ->
|
||||||
forAll (arbitraryMessage net) $
|
forAll (arbitraryMessage net ctx) $
|
||||||
customCerealID (getMessage net) (putMessage net)
|
customCerealID (getMessage net) (putMessage net)
|
||||||
describe "bloom filters" $ do
|
describe "bloom filters" $ do
|
||||||
it "bloom filter vector 1" bloomFilter1
|
it "bloom filter vector 1" bloomFilter1
|
||||||
it "bloom filter vector 2" bloomFilter2
|
it "bloom filter vector 2" bloomFilter2
|
||||||
it "bloom filter vector 3" bloomFilter3
|
it "bloom filter vector 3" $ bloomFilter3 ctx
|
||||||
describe "relevant bloom filter update" $ do
|
describe "relevant bloom filter update" $ do
|
||||||
it "Relevant Update" relevantOutputUpdated
|
it "Relevant Update" $ relevantOutputUpdated ctx
|
||||||
it "Irrelevant Update" irrelevantOutputNotUpdated
|
it "Irrelevant Update" $ irrelevantOutputNotUpdated ctx
|
||||||
|
|
||||||
bloomFilter :: Word32 -> Text -> Assertion
|
bloomFilter :: Word32 -> Text -> Assertion
|
||||||
bloomFilter n x = do
|
bloomFilter n x = do
|
||||||
assertBool "Bloom filter doesn't contain vector 1" $ bloomContains f1 v1
|
assertBool "Bloom filter doesn't contain vector 1" $ bloomContains f1 v1
|
||||||
assertBool "Bloom filter contains something it should not" $
|
assertBool "Bloom filter contains something it should not" $
|
||||||
not $ bloomContains f1 v2
|
not $
|
||||||
assertBool "Bloom filter doesn't contain vector 3" $ bloomContains f3 v3
|
bloomContains f1 v2
|
||||||
assertBool "Bloom filter doesn't contain vector 4" $ bloomContains f4 v4
|
assertBool "Bloom filter doesn't contain vector 3" $ bloomContains f3 v3
|
||||||
assertBool "Bloom filter serialization is incorrect" $
|
assertBool "Bloom filter doesn't contain vector 4" $ bloomContains f4 v4
|
||||||
runPutS (serialize f4) == bs
|
assertBool "Bloom filter serialization is incorrect" $
|
||||||
|
runPutS (serialize f4) == bs
|
||||||
where
|
where
|
||||||
f0 = bloomCreate 3 0.01 n BloomUpdateAll
|
f0 = bloomCreate 3 0.01 n BloomUpdateAll
|
||||||
f1 = bloomInsert f0 v1
|
f1 = bloomInsert f0 v1
|
||||||
@ -88,97 +90,97 @@ bloomFilter1 = bloomFilter 0 "03614e9b050000000000000001"
|
|||||||
bloomFilter2 :: Assertion
|
bloomFilter2 :: Assertion
|
||||||
bloomFilter2 = bloomFilter 2147483649 "03ce4299050000000100008001"
|
bloomFilter2 = bloomFilter 2147483649 "03ce4299050000000100008001"
|
||||||
|
|
||||||
bloomFilter3 :: Assertion
|
bloomFilter3 :: Ctx -> Assertion
|
||||||
bloomFilter3 =
|
bloomFilter3 ctx =
|
||||||
assertBool "Bloom filter serialization is incorrect" $
|
assertBool "Bloom filter serialization is incorrect" $
|
||||||
runPutS (serialize f2) == bs
|
runPutS (serialize f2) == bs
|
||||||
where
|
where
|
||||||
f0 = bloomCreate 2 0.001 0 BloomUpdateAll
|
f0 = bloomCreate 2 0.001 0 BloomUpdateAll
|
||||||
f1 = bloomInsert f0 $ runPutS $ serialize p
|
f1 = bloomInsert f0 $ marshal ctx p
|
||||||
f2 = bloomInsert f1 $ runPutS $ serialize $ getAddrHash160 $ pubKeyAddr p
|
f2 = bloomInsert f1 $ runPutS $ serialize (pubKeyAddr ctx p).hash160
|
||||||
k = fromJust $ fromWif btc "5Kg1gnAjaLfKiwhhPpGS3QfRg2m6awQvaj98JCZBZQ5SuS2F15C"
|
k = fromJust $ fromWif btc "5Kg1gnAjaLfKiwhhPpGS3QfRg2m6awQvaj98JCZBZQ5SuS2F15C"
|
||||||
p = derivePubKeyI k
|
p = derivePublicKey ctx k
|
||||||
bs = fromJust $ decodeHex "038fc16b080000000000000001"
|
bs = fromJust $ decodeHex "038fc16b080000000000000001"
|
||||||
|
|
||||||
relevantOutputUpdated :: Assertion
|
relevantOutputUpdated :: Ctx -> Assertion
|
||||||
relevantOutputUpdated =
|
relevantOutputUpdated ctx =
|
||||||
assertBool "Bloom filter output updated" $
|
assertBool "Bloom filter output updated" $
|
||||||
any (bloomContains bf2) spendTxInput
|
any (bloomContains bf2) spendTxInput
|
||||||
where
|
where
|
||||||
bf0 = bloomCreate 10 0.000001 0 BloomUpdateAll
|
bf0 = bloomCreate 10 0.000001 0 BloomUpdateAll
|
||||||
relevantOutputHash = fromJust $ decodeHex "03f47604ea2736334151081e13265b4fe38e6fa8"
|
relevantOutputHash = fromJust $ decodeHex "03f47604ea2736334151081e13265b4fe38e6fa8"
|
||||||
bf1 = bloomInsert bf0 relevantOutputHash
|
bf1 = bloomInsert bf0 relevantOutputHash
|
||||||
bf2 = fromJust $ bloomRelevantUpdate bf1 relevantTx
|
bf2 = fromJust $ bloomRelevantUpdate ctx bf1 relevantTx
|
||||||
spendTxInput = runPutS . serialize . prevOutput <$> txIn spendRelevantTx
|
spendTxInput = runPutS . serialize . (.outpoint) <$> spendRelevantTx.inputs
|
||||||
|
|
||||||
irrelevantOutputNotUpdated :: Assertion
|
irrelevantOutputNotUpdated :: Ctx -> Assertion
|
||||||
irrelevantOutputNotUpdated = assertEqual "Bloom filter not updated" Nothing bf2
|
irrelevantOutputNotUpdated ctx = assertEqual "Bloom filter not updated" Nothing bf2
|
||||||
where
|
where
|
||||||
bf0 = bloomCreate 10 0.000001 0 BloomUpdateAll
|
bf0 = bloomCreate 10 0.000001 0 BloomUpdateAll
|
||||||
relevantOutputHash = fromJust $ decodeHex "03f47604ea2736334151081e13265b4fe38e6fa8"
|
relevantOutputHash = fromJust $ decodeHex "03f47604ea2736334151081e13265b4fe38e6fa8"
|
||||||
bf1 = bloomInsert bf0 relevantOutputHash
|
bf1 = bloomInsert bf0 relevantOutputHash
|
||||||
bf2 = bloomRelevantUpdate bf1 unrelatedTx
|
bf2 = bloomRelevantUpdate ctx bf1 unrelatedTx
|
||||||
|
|
||||||
-- Random transaction (57dc904f32ad4daab7b321dd469e8791ad09df784cdd273a73985150a4f225e9)
|
-- Random transaction (57dc904f32ad4daab7b321dd469e8791ad09df784cdd273a73985150a4f225e9)
|
||||||
relevantTx :: Tx
|
relevantTx :: Tx
|
||||||
relevantTx =
|
relevantTx =
|
||||||
Tx
|
Tx
|
||||||
{ txVersion = 1
|
{ version = 1,
|
||||||
, txIn =
|
inputs =
|
||||||
[ TxIn
|
[ TxIn
|
||||||
{ prevOutput = OutPoint "35fe9017b7e3af592920b56fa06ac02faf0c52cdb19dcb416129ac71c95d060e" 1
|
{ outpoint = OutPoint "35fe9017b7e3af592920b56fa06ac02faf0c52cdb19dcb416129ac71c95d060e" 1,
|
||||||
, scriptInput = fromJust $ decodeHex "473044022032fc8eef299b7e94b9a986a6aa2dcb9733ab804bef80df995e443b9c1f8c604202203335df7a2e2b4789451cdb4b2b05a786a81c51519eb6a567fd6fe8cd7b2d33fe014104272502dc63a512dad1473cb82a71be9baf4f4303abd1ff6028fc8a78e1f3aec1218907119dec14f07354850758ff0948e88a904fa411c4df7d5444414ec64ad6"
|
script = fromJust $ decodeHex "473044022032fc8eef299b7e94b9a986a6aa2dcb9733ab804bef80df995e443b9c1f8c604202203335df7a2e2b4789451cdb4b2b05a786a81c51519eb6a567fd6fe8cd7b2d33fe014104272502dc63a512dad1473cb82a71be9baf4f4303abd1ff6028fc8a78e1f3aec1218907119dec14f07354850758ff0948e88a904fa411c4df7d5444414ec64ad6",
|
||||||
, txInSequence = 4294967295
|
sequence = 4294967295
|
||||||
}
|
}
|
||||||
]
|
],
|
||||||
, txOut =
|
outputs =
|
||||||
[ TxOut{outValue = 100000000, scriptOutput = fromJust $ decodeHex "76a91403f47604ea2736334151081e13265b4fe38e6fa888ac"}
|
[ TxOut {value = 100000000, script = fromJust $ decodeHex "76a91403f47604ea2736334151081e13265b4fe38e6fa888ac"},
|
||||||
, TxOut{outValue = 107980000, scriptOutput = fromJust $ decodeHex "76a91481cc186a2f4a69f633ed4bf10ef4a78be13effdd88ac"}
|
TxOut {value = 107980000, script = fromJust $ decodeHex "76a91481cc186a2f4a69f633ed4bf10ef4a78be13effdd88ac"}
|
||||||
]
|
],
|
||||||
, txWitness = []
|
witness = [],
|
||||||
, txLockTime = 0
|
locktime = 0
|
||||||
}
|
}
|
||||||
|
|
||||||
-- Transaction that spends above (fd6e3b693b844aa431fad46765c1aa019a6b13aebfa9dae916b3ffa43283a300)
|
-- Transaction that spends above (fd6e3b693b844aa431fad46765c1aa019a6b13aebfa9dae916b3ffa43283a300)
|
||||||
spendRelevantTx :: Tx
|
spendRelevantTx :: Tx
|
||||||
spendRelevantTx =
|
spendRelevantTx =
|
||||||
Tx
|
Tx
|
||||||
{ txVersion = 1
|
{ version = 1,
|
||||||
, txIn =
|
inputs =
|
||||||
[ TxIn
|
[ TxIn
|
||||||
{ prevOutput = OutPoint "57dc904f32ad4daab7b321dd469e8791ad09df784cdd273a73985150a4f225e9" 0
|
{ outpoint = OutPoint "57dc904f32ad4daab7b321dd469e8791ad09df784cdd273a73985150a4f225e9" 0,
|
||||||
, scriptInput = fromJust $ decodeHex "483045022100ecc334821e4e94cc2fdc841d5ad147d5bb942b993ba81460cc446e0410afa811022015fcbc542b734dbb61a05ec06012095096de5839c50808fe56f2b315e877c20d012103fb64e5792fa586172339b776b7017d3d529358cb73be6406a1fc994228d14f88"
|
script = fromJust $ decodeHex "483045022100ecc334821e4e94cc2fdc841d5ad147d5bb942b993ba81460cc446e0410afa811022015fcbc542b734dbb61a05ec06012095096de5839c50808fe56f2b315e877c20d012103fb64e5792fa586172339b776b7017d3d529358cb73be6406a1fc994228d14f88",
|
||||||
, txInSequence = 4294967295
|
sequence = 4294967295
|
||||||
}
|
},
|
||||||
, TxIn
|
TxIn
|
||||||
{ prevOutput = OutPoint "cfee6a8d6e68e8fd16df6fff010afffcd19d7e075aa7b707dd1bae6adc420042" 0
|
{ outpoint = OutPoint "cfee6a8d6e68e8fd16df6fff010afffcd19d7e075aa7b707dd1bae6adc420042" 0,
|
||||||
, scriptInput = fromJust $ decodeHex "47304402200e6bb95fa606f254d17089d83c4ceeb19c5d1699b4faddcd4f1f1568286e6b650220087fb8439f31e1b30e47710d095422405f601d6151f2f93e125e1a08a6e29ad4012103b49252e8fc6d5b49c8d14ee71fab45591df4a126a6c453c724f3d356e38f0cee"
|
script = fromJust $ decodeHex "47304402200e6bb95fa606f254d17089d83c4ceeb19c5d1699b4faddcd4f1f1568286e6b650220087fb8439f31e1b30e47710d095422405f601d6151f2f93e125e1a08a6e29ad4012103b49252e8fc6d5b49c8d14ee71fab45591df4a126a6c453c724f3d356e38f0cee",
|
||||||
, txInSequence = 4294967295
|
sequence = 4294967295
|
||||||
}
|
}
|
||||||
]
|
],
|
||||||
, txOut =
|
outputs =
|
||||||
[ TxOut{outValue = 3851100, scriptOutput = fromJust $ decodeHex "76a914a297cae82a9a3b932bf023ae274fe2585295c9ca88ac"}
|
[ TxOut {value = 3851100, script = fromJust $ decodeHex "76a914a297cae82a9a3b932bf023ae274fe2585295c9ca88ac"},
|
||||||
, TxOut{outValue = 111000000, scriptOutput = fromJust $ decodeHex "76a9148f952c38600a61385974acc30a64f74407f9801488ac"}
|
TxOut {value = 111000000, script = fromJust $ decodeHex "76a9148f952c38600a61385974acc30a64f74407f9801488ac"}
|
||||||
]
|
],
|
||||||
, txWitness = []
|
witness = [],
|
||||||
, txLockTime = 0
|
locktime = 0
|
||||||
}
|
}
|
||||||
|
|
||||||
-- This random transaction is unrelated to the others
|
-- This random transaction is unrelated to the others
|
||||||
unrelatedTx :: Tx
|
unrelatedTx :: Tx
|
||||||
unrelatedTx =
|
unrelatedTx =
|
||||||
Tx
|
Tx
|
||||||
{ txVersion = 1
|
{ version = 1,
|
||||||
, txIn =
|
inputs =
|
||||||
[ TxIn
|
[ TxIn
|
||||||
{ prevOutput = OutPoint "3ec3a71431c68e5d978a5fb4a0a1081d8bee8384d8aa4c06b1fbaf9413e2214f" 20
|
{ outpoint = OutPoint "3ec3a71431c68e5d978a5fb4a0a1081d8bee8384d8aa4c06b1fbaf9413e2214f" 20,
|
||||||
, scriptInput = fromJust $ decodeHex "483045022100ec9c202c9d3140b973aca9d7f21a82138aa4cfa43fddc5419098ac5e26a6f152022010848fd688f290ae010fb5cb493410caa03145fc12445900ec1ad2bde33aecd9012102c7445e72d723f99a0064526c28269d07f47c8fd81531a94a8d3bf5ebd5e23ef1"
|
script = fromJust $ decodeHex "483045022100ec9c202c9d3140b973aca9d7f21a82138aa4cfa43fddc5419098ac5e26a6f152022010848fd688f290ae010fb5cb493410caa03145fc12445900ec1ad2bde33aecd9012102c7445e72d723f99a0064526c28269d07f47c8fd81531a94a8d3bf5ebd5e23ef1",
|
||||||
, txInSequence = 4294967295
|
sequence = 4294967295
|
||||||
}
|
}
|
||||||
]
|
],
|
||||||
, txOut =
|
outputs =
|
||||||
[ TxOut{outValue = 12600000, scriptOutput = fromJust $ decodeHex "76a9148fef3b7051de8cc44e966159e7ea37f4520187e888ac"}
|
[ TxOut {value = 12600000, script = fromJust $ decodeHex "76a9148fef3b7051de8cc44e966159e7ea37f4520187e888ac"}
|
||||||
]
|
],
|
||||||
, txWitness = []
|
witness = [],
|
||||||
, txLockTime = 0
|
locktime = 0
|
||||||
}
|
}
|
||||||
|
@ -1,11 +1,15 @@
|
|||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
|
||||||
module Haskoin.ScriptSpec (spec) where
|
module Haskoin.ScriptSpec (spec) where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Data.Aeson as A
|
import Data.Aeson as A
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
import qualified Data.ByteString as B
|
import Data.ByteString qualified as B
|
||||||
import Data.Bytes.Get
|
import Data.Bytes.Get
|
||||||
import Data.Bytes.Put
|
import Data.Bytes.Put
|
||||||
import Data.Bytes.Serial
|
import Data.Bytes.Serial
|
||||||
@ -17,14 +21,13 @@ import Data.String.Conversions (cs)
|
|||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Word
|
import Data.Word
|
||||||
import Haskoin.Address
|
import Haskoin.Address
|
||||||
import Haskoin.Constants
|
import Haskoin.Crypto
|
||||||
import Haskoin.Data
|
import Haskoin.Network.Constants
|
||||||
import Haskoin.Keys
|
import Haskoin.Network.Data
|
||||||
import Haskoin.Script
|
import Haskoin.Script
|
||||||
import Haskoin.Transaction
|
import Haskoin.Transaction
|
||||||
import Haskoin.Util
|
import Haskoin.Util
|
||||||
import Haskoin.Util.Arbitrary
|
import Haskoin.Util.Arbitrary
|
||||||
import Haskoin.UtilSpec (readTestFile)
|
|
||||||
import Test.HUnit as HUnit
|
import Test.HUnit as HUnit
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
import Test.Hspec.QuickCheck
|
import Test.Hspec.QuickCheck
|
||||||
@ -33,196 +36,187 @@ import Text.Read
|
|||||||
|
|
||||||
serialVals :: [SerialBox]
|
serialVals :: [SerialBox]
|
||||||
serialVals =
|
serialVals =
|
||||||
[ SerialBox arbitraryScriptOp
|
[ SerialBox arbitraryScriptOp,
|
||||||
, SerialBox arbitraryScript
|
SerialBox arbitraryScript
|
||||||
]
|
]
|
||||||
|
|
||||||
readVals :: [ReadBox]
|
readVals :: Ctx -> [ReadBox]
|
||||||
readVals =
|
readVals ctx =
|
||||||
[ ReadBox arbitrarySigHash
|
[ ReadBox arbitrarySigHash,
|
||||||
, ReadBox arbitrarySigHashFlag
|
ReadBox arbitrarySigHashFlag,
|
||||||
, ReadBox arbitraryScript
|
ReadBox arbitraryScript,
|
||||||
, ReadBox arbitraryPushDataType
|
ReadBox arbitraryPushDataType,
|
||||||
, ReadBox arbitraryScriptOp
|
ReadBox arbitraryScriptOp,
|
||||||
, ReadBox (arbitraryScriptOutput =<< arbitraryNetwork)
|
ReadBox ((`arbitraryScriptOutput` ctx) =<< arbitraryNetwork)
|
||||||
]
|
]
|
||||||
|
|
||||||
jsonVals :: [JsonBox]
|
jsonVals :: Ctx -> [JsonBox]
|
||||||
jsonVals =
|
jsonVals ctx =
|
||||||
[ JsonBox $ arbitraryScriptOutput =<< arbitraryNetwork
|
[ JsonBox $
|
||||||
, JsonBox arbitraryOutPoint
|
fmap (marshalValue ctx) $
|
||||||
, JsonBox arbitrarySigHash
|
arbitraryNetwork >>= flip arbitraryScriptOutput ctx,
|
||||||
, JsonBox $ fst <$> (arbitrarySigInput =<< arbitraryNetwork)
|
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 :: Spec
|
||||||
spec = do
|
spec = prepareContext $ \ctx -> do
|
||||||
testIdentity serialVals readVals jsonVals []
|
testIdentity serialVals (readVals ctx) (jsonVals ctx) (netVals ctx)
|
||||||
describe "btc scripts" $ props btc
|
describe "btc scripts" $ props btc ctx
|
||||||
describe "bch scripts" $ props bch
|
describe "bch scripts" $ props bch ctx
|
||||||
describe "multi signatures" $
|
describe "multi signatures" $
|
||||||
zipWithM_ (curry mapMulSigVector) mulSigVectors [0 ..]
|
zipWithM_ (curry (mapMulSigVector ctx)) mulSigVectors [0 ..]
|
||||||
describe "signature decoding" $
|
describe "signature decoding" $
|
||||||
zipWithM_ (curry (sigDecodeMap btc)) scriptSigSignatures [0 ..]
|
zipWithM_ (curry (sigDecodeMap btc ctx)) scriptSigSignatures [0 ..]
|
||||||
describe "SigHashFlag fromEnum/toEnum" $
|
describe "SigHashFlag fromEnum/toEnum" $
|
||||||
prop "fromEnum/toEnum" $
|
prop "fromEnum/toEnum" $
|
||||||
forAll arbitrarySigHashFlag $ \f -> toEnum (fromEnum f) `shouldBe` f
|
forAll arbitrarySigHashFlag $
|
||||||
describe "Script vectors" $
|
\f -> toEnum (fromEnum f) `shouldBe` f
|
||||||
it "Can encode script vectors" encodeScriptVector
|
describe "Script vectors" $
|
||||||
|
it "Can encode script vectors" encodeScriptVector
|
||||||
|
|
||||||
props :: Network -> Spec
|
props :: Network -> Ctx -> Spec
|
||||||
props net = do
|
props net ctx = do
|
||||||
standardSpec net
|
standardSpec net ctx
|
||||||
strictSigSpec net
|
strictSigSpec net ctx
|
||||||
scriptSpec net
|
scriptSpec net ctx
|
||||||
txSigHashForkIdSpec net
|
txSigHashForkIdSpec net
|
||||||
forkIdScriptSpec net
|
forkIdScriptSpec net ctx
|
||||||
sigHashSpec net
|
sigHashSpec net ctx
|
||||||
txSigHashSpec net
|
txSigHashSpec net
|
||||||
|
|
||||||
standardSpec :: Network -> Spec
|
standardSpec :: Network -> Ctx -> Spec
|
||||||
standardSpec net = do
|
standardSpec net ctx = do
|
||||||
prop "has intToScriptOp . scriptOpToInt identity" $
|
prop "has intToScriptOp . scriptOpToInt identity" $
|
||||||
forAll arbitraryIntScriptOp $ \i ->
|
forAll arbitraryIntScriptOp $ \i ->
|
||||||
intToScriptOp <$> scriptOpToInt i `shouldBe` Right i
|
intToScriptOp <$> scriptOpToInt i `shouldBe` Right i
|
||||||
prop "has decodeOutput . encodeOutput identity" $
|
prop "has decodeOutput . encodeOutput identity" $
|
||||||
forAll (arbitraryScriptOutput net) $ \so ->
|
forAll (arbitraryScriptOutput net ctx) $ \so ->
|
||||||
decodeOutput (encodeOutput so) `shouldBe` Right so
|
decodeOutput ctx (encodeOutput ctx so) `shouldBe` Right so
|
||||||
prop "has decodeInput . encodeOutput identity" $
|
prop "has decodeInput . encodeOutput identity" $
|
||||||
forAll (arbitraryScriptInput net) $ \si ->
|
forAll (arbitraryScriptInput net ctx) $ \si ->
|
||||||
decodeInput net (encodeInput si) `shouldBe` Right si
|
(decodeInput net ctx . encodeInput net ctx) si `shouldBe` Right si
|
||||||
prop "can sort multisig scripts" $
|
prop "can sort multisig scripts" $
|
||||||
forAll arbitraryMSOutput $ \out ->
|
forAll (arbitraryMSOutput ctx) $ \out ->
|
||||||
map
|
let keyList = map (marshal ctx) (sortMulSig ctx out).keys
|
||||||
(runPutS . serialize)
|
isSorted xs = xs == sort xs
|
||||||
(getOutputMulSigKeys (sortMulSig out))
|
in keyList `shouldSatisfy` isSorted
|
||||||
`shouldSatisfy` \xs -> xs == sort xs
|
it "can decode inputs with empty signatures" $ do
|
||||||
it "can decode inputs with empty signatures" $ do
|
decodeInput net ctx (Script [OP_0])
|
||||||
decodeInput net (Script [OP_0])
|
`shouldBe` Right (RegularInput (SpendPK TxSignatureEmpty))
|
||||||
`shouldBe` Right (RegularInput (SpendPK TxSignatureEmpty))
|
decodeInput net ctx (Script [opPushData ""])
|
||||||
decodeInput net (Script [opPushData ""])
|
`shouldBe` Right (RegularInput (SpendPK TxSignatureEmpty))
|
||||||
`shouldBe` Right (RegularInput (SpendPK TxSignatureEmpty))
|
let Just sk = secKey (B.replicate 32 1)
|
||||||
let pk =
|
pk = derivePublicKey ctx (wrapSecKey True sk)
|
||||||
derivePubKeyI $
|
decodeInput net ctx (Script [OP_0, opPushData $ marshal ctx pk])
|
||||||
wrapSecKey True $ fromJust $ secKey $ B.replicate 32 1
|
`shouldBe` Right (RegularInput (SpendPKHash TxSignatureEmpty pk))
|
||||||
decodeInput net (Script [OP_0, opPushData $ runPutS $ serialize pk])
|
decodeInput net ctx (Script [OP_0, OP_0])
|
||||||
`shouldBe` Right (RegularInput (SpendPKHash TxSignatureEmpty pk))
|
`shouldBe` Right (RegularInput (SpendMulSig [TxSignatureEmpty]))
|
||||||
decodeInput net (Script [OP_0, OP_0])
|
decodeInput net ctx (Script [OP_0, OP_0, OP_0, OP_0])
|
||||||
`shouldBe` Right (RegularInput (SpendMulSig [TxSignatureEmpty]))
|
`shouldBe` Right (RegularInput (SpendMulSig $ replicate 3 TxSignatureEmpty))
|
||||||
decodeInput net (Script [OP_0, OP_0, OP_0, OP_0])
|
|
||||||
`shouldBe` Right (RegularInput (SpendMulSig $ replicate 3 TxSignatureEmpty))
|
|
||||||
|
|
||||||
scriptSpec :: Network -> Spec
|
scriptSpec :: Network -> Ctx -> Spec
|
||||||
scriptSpec net =
|
scriptSpec net ctx =
|
||||||
when (getNetworkName net == "btc") $
|
when (net.name == "btc") $
|
||||||
it "can verify standard scripts from script_tests.json file" $ do
|
it "can verify standard scripts from script_tests.json file" $ do
|
||||||
xs <- readTestFile "script_tests.json" :: IO [A.Value]
|
xs <- readTestFile "script_tests.json" :: IO [A.Value]
|
||||||
let vectorsA =
|
let vectorsA =
|
||||||
mapMaybe (A.decode . A.encode) xs ::
|
mapMaybe (A.decode . A.encode) xs ::
|
||||||
[ ( String
|
[(String, String, String, String, String)]
|
||||||
, String
|
vectorsB =
|
||||||
, String
|
mapMaybe (A.decode . A.encode) xs ::
|
||||||
, String
|
[([Word64], String, String, String, String, String)]
|
||||||
, String
|
vectors =
|
||||||
)
|
map (\(a, b, c, d, e) -> ([0], a, b, c, d, e)) vectorsA
|
||||||
]
|
<> vectorsB
|
||||||
vectorsB =
|
length vectors `shouldBe` 86
|
||||||
mapMaybe (A.decode . A.encode) xs ::
|
forM_ vectors $ \([val], siStr, soStr, flags, res, desc) ->
|
||||||
[ ( [Word64]
|
-- We can disable specific tests by adding a DISABLED flag in the data
|
||||||
, String
|
unless ("DISABLED" `isInfixOf` flags) $ do
|
||||||
, String
|
let _strict =
|
||||||
, String
|
any
|
||||||
, String
|
(`isInfixOf` flags)
|
||||||
, String
|
["DERSIG", "STRICTENC", "NULLDUMMY"]
|
||||||
)
|
scriptSig = parseScript siStr
|
||||||
]
|
scriptPubKey = parseScript soStr
|
||||||
vectors =
|
out = unmarshal ctx scriptPubKey
|
||||||
map (\(a, b, c, d, e) -> ([0], a, b, c, d, e)) vectorsA
|
tx = spendTx scriptPubKey 0 scriptSig
|
||||||
<> vectorsB
|
sat = val * 100000000
|
||||||
length vectors `shouldBe` 86
|
ver o = verifyStdInput net ctx tx 0 o sat
|
||||||
forM_ vectors $ \([val], siStr, soStr, flags, res, desc) ->
|
valid = either (const False) ver out
|
||||||
-- We can disable specific tests by adding a DISABLED flag in the data
|
assertBool desc $ if res == "OK" then valid else not valid
|
||||||
|
|
||||||
unless ("DISABLED" `isInfixOf` flags) $ do
|
forkIdScriptSpec :: Network -> Ctx -> Spec
|
||||||
let _strict =
|
forkIdScriptSpec net ctx =
|
||||||
"DERSIG" `isInfixOf` flags
|
when (isJust net.sigHashForkId) $
|
||||||
|| "STRICTENC" `isInfixOf` flags
|
it "can verify scripts from forkid_script_tests.json file" $ do
|
||||||
|| "NULLDUMMY" `isInfixOf` flags
|
xs <- readTestFile "forkid_script_tests.json" :: IO [A.Value]
|
||||||
scriptSig = parseScript siStr
|
let vectors =
|
||||||
scriptPubKey = parseScript soStr
|
mapMaybe (A.decode . A.encode) xs ::
|
||||||
decodedOutput = decodeOutputBS scriptPubKey
|
[ ( [Word64],
|
||||||
ver = either (const False) $ \so ->
|
String,
|
||||||
verifyStdInput
|
String,
|
||||||
net
|
String,
|
||||||
(spendTx scriptPubKey 0 scriptSig)
|
String,
|
||||||
0
|
String
|
||||||
so
|
)
|
||||||
(val * 100000000)
|
]
|
||||||
case res of
|
length vectors `shouldBe` 3
|
||||||
"OK" -> assertBool desc $ ver decodedOutput
|
forM_ vectors $ \([valBTC], siStr, soStr, _, res, _) -> do
|
||||||
_ -> assertBool desc (not $ ver decodedOutput)
|
let val = valBTC * 100000000
|
||||||
|
scriptSig = parseScript siStr
|
||||||
forkIdScriptSpec :: Network -> Spec
|
scriptPubKey = parseScript soStr
|
||||||
forkIdScriptSpec net =
|
out = unmarshal ctx scriptPubKey
|
||||||
when (isJust (getSigHashForkId net)) $
|
tx = spendTx scriptPubKey val scriptSig
|
||||||
it "can verify scripts from forkid_script_tests.json file" $ do
|
ver o = verifyStdInput net ctx tx 0 o val
|
||||||
xs <- readTestFile "forkid_script_tests.json" :: IO [A.Value]
|
valid = either (const False) ver out
|
||||||
let vectors =
|
case res of
|
||||||
mapMaybe (A.decode . A.encode) xs ::
|
"OK" -> valid `shouldBe` True
|
||||||
[ ( [Word64]
|
_ -> valid `shouldBe` False
|
||||||
, 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
|
|
||||||
|
|
||||||
creditTx :: ByteString -> Word64 -> Tx
|
creditTx :: ByteString -> Word64 -> Tx
|
||||||
creditTx scriptPubKey val =
|
creditTx scriptPubKey val =
|
||||||
Tx 1 [txI] [txO] [] 0
|
Tx 1 [txI] [txO] [] 0
|
||||||
where
|
where
|
||||||
txO = TxOut{outValue = val, scriptOutput = scriptPubKey}
|
txO = TxOut {value = val, script = scriptPubKey}
|
||||||
txI =
|
txI =
|
||||||
TxIn
|
TxIn
|
||||||
{ prevOutput = nullOutPoint
|
{ outpoint = nullOutPoint,
|
||||||
, scriptInput = runPutS $ serialize $ Script [OP_0, OP_0]
|
script = runPutS $ serialize $ Script [OP_0, OP_0],
|
||||||
, txInSequence = maxBound
|
sequence = maxBound
|
||||||
}
|
}
|
||||||
|
|
||||||
spendTx :: ByteString -> Word64 -> ByteString -> Tx
|
spendTx :: ByteString -> Word64 -> ByteString -> Tx
|
||||||
spendTx scriptPubKey val scriptSig =
|
spendTx scriptPubKey val scriptSig =
|
||||||
Tx 1 [txI] [txO] [] 0
|
Tx 1 [txI] [txO] [] 0
|
||||||
where
|
where
|
||||||
txO = TxOut{outValue = val, scriptOutput = B.empty}
|
txO = TxOut {value = val, script = B.empty}
|
||||||
txI =
|
txI =
|
||||||
TxIn
|
TxIn
|
||||||
{ prevOutput = OutPoint (txHash $ creditTx scriptPubKey val) 0
|
{ outpoint = OutPoint (txHash $ creditTx scriptPubKey val) 0,
|
||||||
, scriptInput = scriptSig
|
script = scriptSig,
|
||||||
, txInSequence = maxBound
|
sequence = maxBound
|
||||||
}
|
}
|
||||||
|
|
||||||
parseScript :: String -> ByteString
|
parseScript :: String -> ByteString
|
||||||
parseScript str =
|
parseScript str =
|
||||||
B.concat $ fromMaybe err $ mapM f $ words str
|
B.concat $ fromMaybe err $ mapM f $ words str
|
||||||
where
|
where
|
||||||
f = decodeHex . cs . dropHex . replaceToken
|
f = decodeHex . cs . dropHex . replaceToken
|
||||||
dropHex ('0' : 'x' : xs) = xs
|
dropHex ('0' : 'x' : xs) = xs
|
||||||
@ -231,233 +225,238 @@ parseScript str =
|
|||||||
|
|
||||||
replaceToken :: String -> String
|
replaceToken :: String -> String
|
||||||
replaceToken str = case readMaybe $ "OP_" <> str of
|
replaceToken str = case readMaybe $ "OP_" <> str of
|
||||||
Just opcode -> "0x" <> cs (encodeHex $ runPutS $ serialize (opcode :: ScriptOp))
|
Just opcode -> "0x" <> cs (encodeHex $ runPutS $ serialize (opcode :: ScriptOp))
|
||||||
_ -> str
|
_ -> str
|
||||||
|
|
||||||
strictSigSpec :: Network -> Spec
|
strictSigSpec :: Network -> Ctx -> Spec
|
||||||
strictSigSpec net =
|
strictSigSpec net ctx =
|
||||||
when (getNetworkName net == "btc") $ do
|
when (net.name == "btc") $ do
|
||||||
it "can decode strict signatures" $ do
|
it "can decode strict signatures" $ do
|
||||||
xs <- readTestFile "sig_strict.json"
|
xs <- readTestFile "sig_strict.json"
|
||||||
let vectors = mapMaybe decodeHex xs
|
let vectors = mapMaybe decodeHex xs
|
||||||
length vectors `shouldBe` 3
|
length vectors `shouldBe` 3
|
||||||
forM_ vectors $ \sig ->
|
forM_ vectors $ \sig ->
|
||||||
decodeTxSig net sig `shouldSatisfy` isRight
|
let eitherSig :: Either String TxSignature
|
||||||
it "can detect non-strict signatures" $ do
|
eitherSig = decodeTxSig net ctx sig
|
||||||
xs <- readTestFile "sig_nonstrict.json"
|
in eitherSig `shouldSatisfy` isRight
|
||||||
let vectors = mapMaybe decodeHex xs
|
it "can detect non-strict signatures" $ do
|
||||||
length vectors `shouldBe` 17
|
xs <- readTestFile "sig_nonstrict.json"
|
||||||
forM_ vectors $ \sig ->
|
let vectors = mapMaybe decodeHex xs
|
||||||
decodeTxSig net sig `shouldSatisfy` isLeft
|
length vectors `shouldBe` 17
|
||||||
|
forM_ vectors $ \sig ->
|
||||||
|
let eitherSig = decodeTxSig net ctx sig
|
||||||
|
in eitherSig `shouldSatisfy` isLeft
|
||||||
|
|
||||||
txSigHashSpec :: Network -> Spec
|
txSigHashSpec :: Network -> Spec
|
||||||
txSigHashSpec net =
|
txSigHashSpec net =
|
||||||
when (getNetworkName net == "btc") $
|
when (net.name == "btc") $
|
||||||
it "can produce valid sighashes from sighash.json test vectors" $ do
|
it "can produce valid sighashes from sighash.json test vectors" $ do
|
||||||
xs <- readTestFile "sighash.json" :: IO [A.Value]
|
xs <- readTestFile "sighash.json" :: IO [A.Value]
|
||||||
let vectors =
|
let vectors =
|
||||||
mapMaybe (A.decode . A.encode) xs ::
|
mapMaybe (A.decode . A.encode) xs ::
|
||||||
[ ( String
|
[ ( String,
|
||||||
, String
|
String,
|
||||||
, Int
|
Int,
|
||||||
, Integer
|
Integer,
|
||||||
, String
|
String
|
||||||
)
|
)
|
||||||
]
|
]
|
||||||
length vectors `shouldBe` 500
|
length vectors `shouldBe` 500
|
||||||
forM_ vectors $ \(txStr, scpStr, i, shI, resStr) -> do
|
forM_ vectors $ \(txStr, scpStr, i, shI, resStr) -> do
|
||||||
let tx = fromString txStr
|
let tx = fromString txStr
|
||||||
s =
|
s =
|
||||||
fromMaybe (error $ "Could not decode script: " <> cs scpStr) $
|
fromMaybe (error $ "Could not decode script: " <> cs scpStr) $
|
||||||
eitherToMaybe . runGetS deserialize =<< decodeHex (cs scpStr)
|
eitherToMaybe . runGetS deserialize =<< decodeHex (cs scpStr)
|
||||||
sh = fromIntegral shI
|
sh = fromIntegral shI
|
||||||
res =
|
res =
|
||||||
eitherToMaybe . runGetS deserialize . B.reverse
|
eitherToMaybe . runGetS deserialize . B.reverse
|
||||||
=<< decodeHex (cs resStr)
|
=<< decodeHex (cs resStr)
|
||||||
Just (txSigHash net tx s 0 i sh) `shouldBe` res
|
Just (txSigHash net tx s 0 i sh) `shouldBe` res
|
||||||
|
|
||||||
txSigHashForkIdSpec :: Network -> Spec
|
txSigHashForkIdSpec :: Network -> Spec
|
||||||
txSigHashForkIdSpec net =
|
txSigHashForkIdSpec net =
|
||||||
when (getNetworkName net == "btc") $
|
when (net.name == "btc") $
|
||||||
it "can produce valid sighashes from forkid_sighash.json test vectors" $ do
|
it "can produce valid sighashes from forkid_sighash.json test vectors" $ do
|
||||||
xs <- readTestFile "forkid_sighash.json" :: IO [A.Value]
|
xs <- readTestFile "forkid_sighash.json" :: IO [A.Value]
|
||||||
let vectors =
|
let vectors =
|
||||||
mapMaybe (A.decode . A.encode) xs ::
|
mapMaybe (A.decode . A.encode) xs ::
|
||||||
[ ( String
|
[ ( String,
|
||||||
, String
|
String,
|
||||||
, Int
|
Int,
|
||||||
, Word64
|
Word64,
|
||||||
, Integer
|
Integer,
|
||||||
, String
|
String
|
||||||
)
|
)
|
||||||
]
|
]
|
||||||
length vectors `shouldBe` 13
|
length vectors `shouldBe` 13
|
||||||
forM_ vectors $ \(txStr, scpStr, i, val, shI, resStr) -> do
|
forM_ vectors $ \(txStr, scpStr, i, val, shI, resStr) -> do
|
||||||
let tx = fromString txStr
|
let tx = fromString txStr
|
||||||
s =
|
s =
|
||||||
fromMaybe (error $ "Could not decode script: " <> cs scpStr) $
|
fromMaybe (error $ "Could not decode script: " <> cs scpStr) $
|
||||||
eitherToMaybe . runGetS deserialize =<< decodeHex (cs scpStr)
|
eitherToMaybe . runGetS deserialize =<< decodeHex (cs scpStr)
|
||||||
sh = fromIntegral shI
|
sh = fromIntegral shI
|
||||||
res = eitherToMaybe . runGetS deserialize =<< decodeHex (cs resStr)
|
res = eitherToMaybe . runGetS deserialize =<< decodeHex (cs resStr)
|
||||||
Just (txSigHashForkId net tx s val i sh) `shouldBe` res
|
Just (txSigHashForkId net tx s val i sh) `shouldBe` res
|
||||||
|
|
||||||
sigHashSpec :: Network -> Spec
|
sigHashSpec :: Network -> Ctx -> Spec
|
||||||
sigHashSpec net = do
|
sigHashSpec net ctx = do
|
||||||
it "can correctly show" $ do
|
it "can correctly show" $ do
|
||||||
show (0x00 :: SigHash) `shouldBe` "SigHash " <> show (0x00 :: Word32)
|
show (0x00 :: SigHash) `shouldBe` "SigHash " <> show (0x00 :: Word32)
|
||||||
show (0x01 :: SigHash) `shouldBe` "SigHash " <> show (0x01 :: Word32)
|
show (0x01 :: SigHash) `shouldBe` "SigHash " <> show (0x01 :: Word32)
|
||||||
show (0xff :: SigHash) `shouldBe` "SigHash " <> show (0xff :: Word32)
|
show (0xff :: SigHash) `shouldBe` "SigHash " <> show (0xff :: Word32)
|
||||||
show (0xabac3344 :: SigHash) `shouldBe` "SigHash "
|
show (0xabac3344 :: SigHash)
|
||||||
<> show (0xabac3344 :: Word32)
|
`shouldBe` "SigHash "
|
||||||
it "can add a forkid" $ do
|
<> show (0xabac3344 :: Word32)
|
||||||
0x00 `sigHashAddForkId` 0x00 `shouldBe` 0x00
|
it "can add a forkid" $ do
|
||||||
0xff `sigHashAddForkId` 0x00ffffff `shouldBe` 0xffffffff
|
0x00 `sigHashAddForkId` 0x00 `shouldBe` 0x00
|
||||||
0xffff `sigHashAddForkId` 0x00aaaaaa `shouldBe` 0xaaaaaaff
|
0xff `sigHashAddForkId` 0x00ffffff `shouldBe` 0xffffffff
|
||||||
0xffff `sigHashAddForkId` 0xaaaaaaaa `shouldBe` 0xaaaaaaff
|
0xffff `sigHashAddForkId` 0x00aaaaaa `shouldBe` 0xaaaaaaff
|
||||||
0xffff `sigHashAddForkId` 0x00004444 `shouldBe` 0x004444ff
|
0xffff `sigHashAddForkId` 0xaaaaaaaa `shouldBe` 0xaaaaaaff
|
||||||
0xff01 `sigHashAddForkId` 0x44440000 `shouldBe` 0x44000001
|
0xffff `sigHashAddForkId` 0x00004444 `shouldBe` 0x004444ff
|
||||||
0xff03 `sigHashAddForkId` 0x00550000 `shouldBe` 0x55000003
|
0xff01 `sigHashAddForkId` 0x44440000 `shouldBe` 0x44000001
|
||||||
it "can extract a forkid" $ do
|
0xff03 `sigHashAddForkId` 0x00550000 `shouldBe` 0x55000003
|
||||||
sigHashGetForkId 0x00000000 `shouldBe` 0x00000000
|
it "can extract a forkid" $ do
|
||||||
sigHashGetForkId 0x80000000 `shouldBe` 0x00800000
|
sigHashGetForkId 0x00000000 `shouldBe` 0x00000000
|
||||||
sigHashGetForkId 0xffffffff `shouldBe` 0x00ffffff
|
sigHashGetForkId 0x80000000 `shouldBe` 0x00800000
|
||||||
sigHashGetForkId 0xabac3403 `shouldBe` 0x00abac34
|
sigHashGetForkId 0xffffffff `shouldBe` 0x00ffffff
|
||||||
it "can build some vectors" $ do
|
sigHashGetForkId 0xabac3403 `shouldBe` 0x00abac34
|
||||||
sigHashAll `shouldBe` 0x01
|
it "can build some vectors" $ do
|
||||||
sigHashNone `shouldBe` 0x02
|
sigHashAll `shouldBe` 0x01
|
||||||
sigHashSingle `shouldBe` 0x03
|
sigHashNone `shouldBe` 0x02
|
||||||
setForkIdFlag sigHashAll `shouldBe` 0x41
|
sigHashSingle `shouldBe` 0x03
|
||||||
setAnyoneCanPayFlag sigHashAll `shouldBe` 0x81
|
setForkIdFlag sigHashAll `shouldBe` 0x41
|
||||||
setAnyoneCanPayFlag (setForkIdFlag sigHashAll) `shouldBe` 0xc1
|
setAnyoneCanPay sigHashAll `shouldBe` 0x81
|
||||||
it "can test flags" $ do
|
setAnyoneCanPay (setForkIdFlag sigHashAll) `shouldBe` 0xc1
|
||||||
hasForkIdFlag sigHashAll `shouldBe` False
|
it "can test flags" $ do
|
||||||
hasForkIdFlag (setForkIdFlag sigHashAll) `shouldBe` True
|
hasForkIdFlag sigHashAll `shouldBe` False
|
||||||
hasAnyoneCanPayFlag sigHashAll `shouldBe` False
|
hasForkIdFlag (setForkIdFlag sigHashAll) `shouldBe` True
|
||||||
hasAnyoneCanPayFlag (setAnyoneCanPayFlag sigHashAll) `shouldBe` True
|
anyoneCanPay sigHashAll `shouldBe` False
|
||||||
isSigHashAll sigHashNone `shouldBe` False
|
anyoneCanPay (setAnyoneCanPay sigHashAll) `shouldBe` True
|
||||||
isSigHashAll sigHashAll `shouldBe` True
|
isSigHashAll sigHashNone `shouldBe` False
|
||||||
isSigHashNone sigHashSingle `shouldBe` False
|
isSigHashAll sigHashAll `shouldBe` True
|
||||||
isSigHashNone sigHashNone `shouldBe` True
|
isSigHashNone sigHashSingle `shouldBe` False
|
||||||
isSigHashSingle sigHashAll `shouldBe` False
|
isSigHashNone sigHashNone `shouldBe` True
|
||||||
isSigHashSingle sigHashSingle `shouldBe` True
|
isSigHashSingle sigHashAll `shouldBe` False
|
||||||
isSigHashUnknown sigHashAll `shouldBe` False
|
isSigHashSingle sigHashSingle `shouldBe` True
|
||||||
isSigHashUnknown sigHashNone `shouldBe` False
|
isSigHashUnknown sigHashAll `shouldBe` False
|
||||||
isSigHashUnknown sigHashSingle `shouldBe` False
|
isSigHashUnknown sigHashNone `shouldBe` False
|
||||||
isSigHashUnknown 0x00 `shouldBe` True
|
isSigHashUnknown sigHashSingle `shouldBe` False
|
||||||
isSigHashUnknown 0x04 `shouldBe` True
|
isSigHashUnknown 0x00 `shouldBe` True
|
||||||
it "can decodeTxSig . encode a TxSignature" $
|
isSigHashUnknown 0x04 `shouldBe` True
|
||||||
property $
|
it "can decodeTxSig . encode a TxSignature" $
|
||||||
forAll (arbitraryTxSignature net) $ \(_, _, ts) ->
|
property $
|
||||||
decodeTxSig net (encodeTxSig ts) `shouldBe` Right ts
|
forAll (arbitraryTxSignature net ctx) $ \(_, _, ts) ->
|
||||||
it "can produce the sighash one" $
|
let f = decodeTxSig net ctx . encodeTxSig net ctx
|
||||||
property $
|
in f ts `shouldBe` Right ts
|
||||||
forAll (arbitraryTx net) $ forAll arbitraryScript . testSigHashOne net
|
it "can produce the sighash one" $
|
||||||
|
property $
|
||||||
|
forAll (arbitraryTx net ctx) $
|
||||||
|
forAll arbitraryScript . testSigHashOne net
|
||||||
|
|
||||||
testSigHashOne :: Network -> Tx -> Script -> Word64 -> Bool -> Property
|
testSigHashOne :: Network -> Tx -> Script -> Word64 -> Bool -> Property
|
||||||
testSigHashOne net tx s val acp =
|
testSigHashOne net tx s val acp =
|
||||||
not (null $ txIn tx)
|
not (null tx.inputs) ==>
|
||||||
==> if length (txIn tx) > length (txOut tx)
|
if length tx.inputs > length tx.outputs
|
||||||
then res `shouldBe` one
|
then res `shouldBe` one
|
||||||
else res `shouldNotBe` one
|
else res `shouldNotBe` one
|
||||||
where
|
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"
|
one = "0100000000000000000000000000000000000000000000000000000000000000"
|
||||||
f =
|
f =
|
||||||
if acp
|
if acp
|
||||||
then setAnyoneCanPayFlag
|
then setAnyoneCanPay
|
||||||
else id
|
else id
|
||||||
|
|
||||||
{- Parse tests from bitcoin-qt repository -}
|
{- Parse tests from bitcoin-qt repository -}
|
||||||
|
|
||||||
mapMulSigVector :: ((Text, Text), Int) -> Spec
|
mapMulSigVector :: Ctx -> ((Text, Text), Int) -> Spec
|
||||||
mapMulSigVector (v, i) =
|
mapMulSigVector ctx (v, i) =
|
||||||
it name $ runMulSigVector v
|
it name $ runMulSigVector ctx v
|
||||||
where
|
where
|
||||||
name = "check multisig vector " <> show i
|
name = "check multisig vector " <> show i
|
||||||
|
|
||||||
runMulSigVector :: (Text, Text) -> Assertion
|
runMulSigVector :: Ctx -> (Text, Text) -> Assertion
|
||||||
runMulSigVector (a, ops) = assertBool "multisig vector" $ Just a == b
|
runMulSigVector ctx (a, ops) = assertBool "multisig vector" $ Just a == b
|
||||||
where
|
where
|
||||||
s = do
|
s = do
|
||||||
s' <- decodeHex ops
|
s' <- decodeHex ops
|
||||||
eitherToMaybe $ runGetS deserialize s'
|
eitherToMaybe $ runGetS deserialize s'
|
||||||
b = do
|
b = do
|
||||||
o <- s
|
o <- s
|
||||||
d <- eitherToMaybe $ decodeOutput o
|
d <- eitherToMaybe $ decodeOutput ctx o
|
||||||
addrToText btc $ payToScriptAddress d
|
addrToText btc $ payToScriptAddress ctx d
|
||||||
|
|
||||||
sigDecodeMap :: Network -> (Text, Int) -> Spec
|
sigDecodeMap :: Network -> Ctx -> (Text, Int) -> Spec
|
||||||
sigDecodeMap net (_, i) =
|
sigDecodeMap net ctx (_, i) =
|
||||||
it ("check signature " ++ show i) func
|
it ("check signature " ++ show i) func
|
||||||
where
|
where
|
||||||
func = testSigDecode net $ scriptSigSignatures !! i
|
func = testSigDecode net ctx $ scriptSigSignatures !! i
|
||||||
|
|
||||||
testSigDecode :: Network -> Text -> Assertion
|
testSigDecode :: Network -> Ctx -> Text -> Assertion
|
||||||
testSigDecode net str =
|
testSigDecode net ctx str =
|
||||||
let bs = fromJust $ decodeHex str
|
let bs = fromJust $ decodeHex str
|
||||||
eitherSig = decodeTxSig net bs
|
eitherSig = decodeTxSig net ctx bs
|
||||||
in assertBool
|
in assertBool
|
||||||
( unwords
|
( unwords
|
||||||
[ "Decode failed:"
|
[ "Decode failed:",
|
||||||
, fromLeft (error "Decode did not fail") eitherSig
|
fromLeft (error "Decode did not fail") eitherSig
|
||||||
]
|
]
|
||||||
)
|
)
|
||||||
$ isRight eitherSig
|
$ isRight eitherSig
|
||||||
|
|
||||||
mulSigVectors :: [(Text, Text)]
|
mulSigVectors :: [(Text, Text)]
|
||||||
mulSigVectors =
|
mulSigVectors =
|
||||||
[
|
[ ( "3QJmV3qfvL9SuYo34YihAf3sRCW3qSinyC",
|
||||||
( "3QJmV3qfvL9SuYo34YihAf3sRCW3qSinyC"
|
"52410491bba2510912a5bd37da1fb5b1673010e43d2c6d812c514e91bfa9f2eb\
|
||||||
, "52410491bba2510912a5bd37da1fb5b1673010e43d2c6d812c514e91bfa9f2eb\
|
\129e1c183329db55bd868e209aac2fbc02cb33d98fe74bf23f0c235d6126b1d8\
|
||||||
\129e1c183329db55bd868e209aac2fbc02cb33d98fe74bf23f0c235d6126b1d8\
|
\334f864104865c40293a680cb9c020e7b1e106d8c1916d3cef99aa431a56d253\
|
||||||
\334f864104865c40293a680cb9c020e7b1e106d8c1916d3cef99aa431a56d253\
|
\e69256dac09ef122b1a986818a7cb624532f062c1d1f8722084861c5c3291ccf\
|
||||||
\e69256dac09ef122b1a986818a7cb624532f062c1d1f8722084861c5c3291ccf\
|
\fef4ec687441048d2455d2403e08708fc1f556002f1b6cd83f992d085097f997\
|
||||||
\fef4ec687441048d2455d2403e08708fc1f556002f1b6cd83f992d085097f997\
|
\4ab08a28838f07896fbab08f39495e15fa6fad6edbfb1e754e35fa1c7844c41f\
|
||||||
\4ab08a28838f07896fbab08f39495e15fa6fad6edbfb1e754e35fa1c7844c41f\
|
\322a1863d4621353ae"
|
||||||
\322a1863d4621353ae"
|
)
|
||||||
)
|
]
|
||||||
]
|
|
||||||
|
|
||||||
scriptSigSignatures :: [Text]
|
scriptSigSignatures :: [Text]
|
||||||
scriptSigSignatures =
|
scriptSigSignatures =
|
||||||
|
-- Signature in input of txid
|
||||||
|
-- 1983a69265920c24f89aac81942b1a59f7eb30821a8b3fb258f88882b6336053
|
||||||
|
[ "304402205ca6249f43538908151fe67b26d020306c0e59fa206cf9f3ccf641f333\
|
||||||
|
\57119d02206c82f244d04ac0a48024fb9cc246b66e58598acf206139bdb7b75a29\
|
||||||
|
\41a2b1e401"
|
||||||
-- Signature in input of txid
|
-- Signature in input of txid
|
||||||
-- 1983a69265920c24f89aac81942b1a59f7eb30821a8b3fb258f88882b6336053
|
-- fb0a1d8d34fa5537e461ac384bac761125e1bfa7fec286fa72511240fa66864d.
|
||||||
[ "304402205ca6249f43538908151fe67b26d020306c0e59fa206cf9f3ccf641f333\
|
-- Strange DER sizes, but in Blockchain. Now invalid as Haskoin can only
|
||||||
\57119d02206c82f244d04ac0a48024fb9cc246b66e58598acf206139bdb7b75a29\
|
-- decode strict signatures.
|
||||||
\41a2b1e401"
|
-- "3048022200002b83d59c1d23c08efd82ee0662fec23309c3adbcbd1f0b8695378d\
|
||||||
-- Signature in input of txid
|
-- \b4b14e736602220000334a96676e58b1bb01784cb7c556dd8ce1c220171904da22\
|
||||||
-- fb0a1d8d34fa5537e461ac384bac761125e1bfa7fec286fa72511240fa66864d.
|
-- \e18fe1e7d1510db501"
|
||||||
-- Strange DER sizes, but in Blockchain. Now invalid as Haskoin can only
|
]
|
||||||
-- decode strict signatures.
|
|
||||||
-- "3048022200002b83d59c1d23c08efd82ee0662fec23309c3adbcbd1f0b8695378d\
|
|
||||||
-- \b4b14e736602220000334a96676e58b1bb01784cb7c556dd8ce1c220171904da22\
|
|
||||||
-- \e18fe1e7d1510db501"
|
|
||||||
]
|
|
||||||
|
|
||||||
encodeScriptVector :: Assertion
|
encodeScriptVector :: Assertion
|
||||||
encodeScriptVector =
|
encodeScriptVector =
|
||||||
assertEqual "Encode script" res (encodeHex $ runPutS $ serialize s)
|
assertEqual "Encode script" res (encodeHex $ runPutS $ serialize s)
|
||||||
where
|
where
|
||||||
res =
|
res =
|
||||||
"514104cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef58b\
|
"514104cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef58b\
|
||||||
\bfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d11fcdd0d\
|
\bfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d11fcdd0d\
|
||||||
\348ac4410461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2f\
|
\348ac4410461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2f\
|
||||||
\cfdeb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39f58b\
|
\cfdeb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39f58b\
|
||||||
\25c15342af52ae"
|
\25c15342af52ae"
|
||||||
s =
|
s =
|
||||||
Script
|
Script
|
||||||
[ OP_1
|
[ OP_1,
|
||||||
, opPushData $
|
opPushData $
|
||||||
d
|
d
|
||||||
"04cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef5\
|
"04cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef5\
|
||||||
\8bbfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d\
|
\8bbfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d\
|
||||||
\11fcdd0d348ac4"
|
\11fcdd0d348ac4",
|
||||||
, opPushData $
|
opPushData $
|
||||||
d
|
d
|
||||||
"0461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2fcf\
|
"0461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2fcf\
|
||||||
\deb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39\
|
\deb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39\
|
||||||
\f58b25c15342af"
|
\f58b25c15342af",
|
||||||
, OP_2
|
OP_2,
|
||||||
, OP_CHECKMULTISIG
|
OP_CHECKMULTISIG
|
||||||
]
|
]
|
||||||
d = fromJust . decodeHex
|
d = fromJust . decodeHex
|
||||||
|
File diff suppressed because it is too large
Load Diff
@ -1,189 +1,181 @@
|
|||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Haskoin.Transaction.TaprootSpec (spec) where
|
module Haskoin.Transaction.TaprootSpec (spec) where
|
||||||
|
|
||||||
import Control.Applicative ((<|>))
|
import Control.Applicative ((<|>))
|
||||||
import Control.Monad (zipWithM, (<=<))
|
import Control.Monad (zipWithM, (<=<))
|
||||||
import Data.Aeson (FromJSON (parseJSON), withObject, (.:), (.:?))
|
import Data.Aeson
|
||||||
import Data.Aeson.Types (Parser)
|
import Data.Aeson.Types
|
||||||
import qualified Data.ByteArray as BA
|
import Data.ByteArray qualified as BA
|
||||||
import Data.ByteString (ByteString)
|
import Data.ByteString (ByteString)
|
||||||
import qualified Data.ByteString as BS
|
import Data.ByteString qualified as BS
|
||||||
import Data.Bytes.Get (runGetS)
|
import Data.Bytes.Get (runGetS)
|
||||||
import Data.Bytes.Put (runPutS)
|
import Data.Bytes.Put (runPutS)
|
||||||
import Data.Bytes.Serial (deserialize, serialize)
|
import Data.Bytes.Serial (deserialize, serialize)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Word (Word8)
|
import Data.Word (Word8)
|
||||||
import Haskoin (
|
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 Test.HUnit (assertBool, (@?=))
|
import Test.HUnit (assertBool, (@?=))
|
||||||
import Test.Hspec (Spec, describe, it, runIO)
|
import Test.Hspec (Spec, describe, it, runIO)
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = do
|
spec = prepareContext $ \ctx -> do
|
||||||
TestVector{testScriptPubKey} <- runIO $ readTestFile "bip341.json"
|
TestVector {testScriptPubKey} <-
|
||||||
describe "Taproot" $ do
|
runIO $
|
||||||
it "should calculate the correct hashes" $ mapM_ testHashes testScriptPubKey
|
readTestFileParser (testVectorParseJSON ctx) "bip341.json"
|
||||||
it "should build the correct output key" $ mapM_ testOutputKey testScriptPubKey
|
describe "Taproot" $ do
|
||||||
it "should build the correct script output" $ mapM_ testScriptOutput testScriptPubKey
|
it "should calculate the correct hashes" $
|
||||||
it "should calculate the correct control blocks" $ mapM_ testControlBlocks testScriptPubKey
|
mapM_ testHashes testScriptPubKey
|
||||||
it "should arrive at the correct address" $ mapM_ testAddress 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 :: TestScriptPubKey -> IO ()
|
||||||
testHashes testData =
|
testHashes testData =
|
||||||
mapM_ checkMASTDetails $ (taprootMAST . tspkGiven) testData
|
mapM_ checkMASTDetails $ ((.mast) . tspkGiven) testData
|
||||||
where
|
where
|
||||||
checkMASTDetails theMAST = do
|
checkMASTDetails theMAST = do
|
||||||
-- Leaf hashes
|
-- Leaf hashes
|
||||||
(Just . getLeafHashes) theMAST @?= (spkiLeafHashes . tspkIntermediary) testData
|
(Just . getLeafHashes) theMAST @?= (spkiLeafHashes . tspkIntermediary) testData
|
||||||
-- Merkle root
|
-- Merkle root
|
||||||
(Just . BA.convert . mastCommitment) theMAST @?= (spkiMerkleRoot . tspkIntermediary) testData
|
(Just . BA.convert . mastCommitment) theMAST @?= (spkiMerkleRoot . tspkIntermediary) testData
|
||||||
|
|
||||||
getLeafHashes = \case
|
getLeafHashes = \case
|
||||||
MASTBranch branchL branchR -> getLeafHashes branchL <> getLeafHashes branchR
|
MASTBranch branchL branchR -> getLeafHashes branchL <> getLeafHashes branchR
|
||||||
leaf@MASTLeaf{} -> [BA.convert $ mastCommitment leaf]
|
leaf@MASTLeaf {} -> [BA.convert $ mastCommitment leaf]
|
||||||
MASTCommitment{} -> mempty -- The test vectors have complete trees
|
MASTCommitment {} -> mempty -- The test vectors have complete trees
|
||||||
|
|
||||||
testOutputKey :: TestScriptPubKey -> IO ()
|
testOutputKey :: Ctx -> TestScriptPubKey -> IO ()
|
||||||
testOutputKey testData = do
|
testOutputKey ctx testData = do
|
||||||
XOnlyPubKey (taprootOutputKey theOutput) @?= theOutputKey
|
XOnlyPubKey (taprootOutputKey ctx theOutput) @?= theOutputKey
|
||||||
where
|
where
|
||||||
theOutput = tspkGiven testData
|
theOutput = tspkGiven testData
|
||||||
theOutputKey = XOnlyPubKey . spkiTweakedPubKey $ tspkIntermediary testData
|
theOutputKey = XOnlyPubKey . spkiTweakedPubKey $ tspkIntermediary testData
|
||||||
|
|
||||||
testScriptOutput :: TestScriptPubKey -> IO ()
|
testScriptOutput :: Ctx -> TestScriptPubKey -> IO ()
|
||||||
testScriptOutput testData =
|
testScriptOutput ctx testData =
|
||||||
taprootScriptOutput (tspkGiven testData) @?= (spkeScriptPubKey . tspkExpected) testData
|
taprootScriptOutput ctx (tspkGiven testData) @?= (spkeScriptPubKey . tspkExpected) testData
|
||||||
|
|
||||||
testControlBlocks :: TestScriptPubKey -> IO ()
|
testControlBlocks :: Ctx -> TestScriptPubKey -> IO ()
|
||||||
testControlBlocks testData = do
|
testControlBlocks ctx testData = do
|
||||||
mapM_ onExamples exampleControlBlocks
|
mapM_ onExamples exampleControlBlocks
|
||||||
mapM_ checkVerification scriptPathSpends
|
mapM_ checkVerification scriptPathSpends
|
||||||
where
|
where
|
||||||
theOutput = tspkGiven testData
|
theOutput = tspkGiven testData
|
||||||
theOutputKey = taprootOutputKey theOutput
|
theOutputKey = taprootOutputKey ctx theOutput
|
||||||
exampleControlBlocks = spkeControlBlocks $ tspkExpected testData
|
exampleControlBlocks = spkeControlBlocks $ tspkExpected testData
|
||||||
calculatedControlBlocks =
|
calculatedControlBlocks =
|
||||||
(!! 1) . encodeTaprootWitness . ScriptPathSpend <$> scriptPathSpends
|
(!! 1) . encodeTaprootWitness ctx . ScriptPathSpend <$> scriptPathSpends
|
||||||
scriptPathSpends =
|
scriptPathSpends =
|
||||||
fmap mkScriptPathSpend
|
mkScriptPathSpend <$> maybe mempty getMerkleProofs theOutput.mast
|
||||||
. maybe mempty getMerkleProofs
|
mkScriptPathSpend (leafVersion, script, proof) =
|
||||||
$ taprootMAST theOutput
|
ScriptPathData
|
||||||
mkScriptPathSpend (scriptPathLeafVersion, scriptPathScript, proof) =
|
{ annex = Nothing,
|
||||||
ScriptPathData
|
stack = mempty,
|
||||||
{ scriptPathAnnex = Nothing
|
script,
|
||||||
, scriptPathStack = mempty
|
extIsOdd = odd $ keyParity ctx theOutputKey,
|
||||||
, scriptPathScript
|
leafVersion,
|
||||||
, scriptPathExternalIsOdd = odd $ keyParity theOutputKey
|
internalKey = theOutput.internalKey,
|
||||||
, scriptPathLeafVersion
|
control = BA.convert <$> proof
|
||||||
, scriptPathInternalKey = taprootInternalKey theOutput
|
}
|
||||||
, scriptPathControl = BA.convert <$> proof
|
|
||||||
}
|
|
||||||
onExamples = zipWithM (@?=) calculatedControlBlocks
|
onExamples = zipWithM (@?=) calculatedControlBlocks
|
||||||
checkVerification = assertBool "Script verifies" . verifyScriptPathData theOutputKey
|
checkVerification = assertBool "Script verifies" . verifyScriptPathData ctx theOutputKey
|
||||||
|
|
||||||
keyParity :: PubKey -> Word8
|
keyParity :: Ctx -> PubKey -> Word8
|
||||||
keyParity key = case BS.unpack . runPutS . serialize $ PubKeyI key True of
|
keyParity ctx key =
|
||||||
|
case BS.unpack . marshal ctx $ PublicKey key True of
|
||||||
0x02 : _ -> 0x00
|
0x02 : _ -> 0x00
|
||||||
_ -> 0x01
|
_ -> 0x01
|
||||||
|
|
||||||
testAddress :: TestScriptPubKey -> IO ()
|
testAddress :: Ctx -> TestScriptPubKey -> IO ()
|
||||||
testAddress testData = computedAddress @?= (Just . spkeAddress . tspkExpected) testData
|
testAddress ctx testData =
|
||||||
|
computedAddress @?= (Just . spkeAddress . tspkExpected) testData
|
||||||
where
|
where
|
||||||
computedAddress = (addrToText btc <=< outputAddress) . taprootScriptOutput $ tspkGiven testData
|
computedAddress =
|
||||||
|
(addrToText btc <=< outputAddress ctx)
|
||||||
|
. taprootScriptOutput ctx
|
||||||
|
$ tspkGiven testData
|
||||||
|
|
||||||
newtype SpkGiven = SpkGiven {unSpkGiven :: TaprootOutput}
|
newtype SpkGiven = SpkGiven {unSpkGiven :: TaprootOutput}
|
||||||
|
|
||||||
instance FromJSON SpkGiven where
|
spkGivenParseJSON :: Ctx -> Value -> Parser SpkGiven
|
||||||
parseJSON = withObject "SpkGiven" $ \obj ->
|
spkGivenParseJSON ctx = withObject "SpkGiven" $ \obj -> do
|
||||||
fmap SpkGiven $
|
pxopk@XOnlyPubKey {} <- unmarshalValue ctx =<< obj .: "internalPubkey"
|
||||||
TaprootOutput
|
tree <- traverse parseScriptTree =<< obj .:? "scriptTree"
|
||||||
<$> (xOnlyPubKey <$> obj .: "internalPubkey")
|
return $ SpkGiven $ TaprootOutput pxopk.point tree
|
||||||
<*> (obj .:? "scriptTree" >>= traverse parseScriptTree)
|
where
|
||||||
where
|
parseScriptTree v =
|
||||||
parseScriptTree v =
|
parseScriptLeaf v
|
||||||
parseScriptLeaf v
|
<|> parseScriptBranch v
|
||||||
<|> parseScriptBranch v
|
<|> fail "Unable to parse scriptTree"
|
||||||
<|> fail "Unable to parse scriptTree"
|
parseScriptLeaf = withObject "ScriptTree leaf" $ \obj ->
|
||||||
parseScriptLeaf = withObject "ScriptTree leaf" $ \obj ->
|
MASTLeaf
|
||||||
MASTLeaf
|
<$> obj .: "leafVersion"
|
||||||
<$> obj .: "leafVersion"
|
<*> (obj .: "script" >>= hexScript)
|
||||||
<*> (obj .: "script" >>= hexScript)
|
parseScriptBranch v =
|
||||||
parseScriptBranch v =
|
parseJSON v >>= \case
|
||||||
parseJSON v >>= \case
|
[v1, v2] -> MASTBranch <$> parseScriptTree v1 <*> parseScriptTree v2
|
||||||
[v1, v2] -> MASTBranch <$> parseScriptTree v1 <*> parseScriptTree v2
|
_ -> fail "ScriptTree branch"
|
||||||
_ -> fail "ScriptTree branch"
|
hexScript = either fail pure . runGetS deserialize <=< jsonHex
|
||||||
hexScript = either fail pure . runGetS deserialize <=< jsonHex
|
|
||||||
|
|
||||||
data SpkIntermediary = SpkIntermediary
|
data SpkIntermediary = SpkIntermediary
|
||||||
{ spkiLeafHashes :: Maybe [ByteString]
|
{ spkiLeafHashes :: Maybe [ByteString],
|
||||||
, spkiMerkleRoot :: Maybe ByteString
|
spkiMerkleRoot :: Maybe ByteString,
|
||||||
, spkiTweakedPubKey :: PubKey
|
spkiTweakedPubKey :: PubKey
|
||||||
}
|
}
|
||||||
|
|
||||||
instance FromJSON SpkIntermediary where
|
spkIntermediaryParseJSON :: Ctx -> Value -> Parser SpkIntermediary
|
||||||
parseJSON = withObject "SpkIntermediary" $ \obj ->
|
spkIntermediaryParseJSON ctx = withObject "SpkIntermediary" $ \obj ->
|
||||||
SpkIntermediary
|
SpkIntermediary
|
||||||
<$> (obj .:? "leafHashes" >>= (traverse . traverse) jsonHex)
|
<$> (obj .:? "leafHashes" >>= (traverse . traverse) jsonHex)
|
||||||
<*> (obj .: "merkleRoot" >>= traverse jsonHex)
|
<*> (obj .: "merkleRoot" >>= traverse jsonHex)
|
||||||
<*> (xOnlyPubKey <$> obj .: "tweakedPubkey")
|
<*> fmap
|
||||||
|
(\(XOnlyPubKey k) -> k)
|
||||||
|
(unmarshalValue ctx =<< obj .: "tweakedPubkey")
|
||||||
|
|
||||||
data SpkExpected = SpkExpected
|
data SpkExpected = SpkExpected
|
||||||
{ spkeScriptPubKey :: ScriptOutput
|
{ spkeScriptPubKey :: ScriptOutput,
|
||||||
, spkeControlBlocks :: Maybe [ByteString]
|
spkeControlBlocks :: Maybe [ByteString],
|
||||||
, spkeAddress :: Text
|
spkeAddress :: Text
|
||||||
}
|
}
|
||||||
|
|
||||||
instance FromJSON SpkExpected where
|
spkExpectedParseJSON :: Ctx -> Value -> Parser SpkExpected
|
||||||
parseJSON = withObject "SpkExpected" $ \obj ->
|
spkExpectedParseJSON ctx = withObject "SpkExpected" $ \obj ->
|
||||||
SpkExpected
|
SpkExpected
|
||||||
<$> obj .: "scriptPubKey"
|
<$> (unmarshalValue ctx =<< obj .: "scriptPubKey")
|
||||||
<*> (obj .:? "scriptPathControlBlocks" >>= (traverse . traverse) jsonHex)
|
<*> ((traverse . traverse) jsonHex =<< obj .:? "scriptPathControlBlocks")
|
||||||
<*> obj .: "bip350Address"
|
<*> obj .: "bip350Address"
|
||||||
|
|
||||||
data TestScriptPubKey = TestScriptPubKey
|
data TestScriptPubKey = TestScriptPubKey
|
||||||
{ tspkGiven :: TaprootOutput
|
{ tspkGiven :: TaprootOutput,
|
||||||
, tspkIntermediary :: SpkIntermediary
|
tspkIntermediary :: SpkIntermediary,
|
||||||
, tspkExpected :: SpkExpected
|
tspkExpected :: SpkExpected
|
||||||
}
|
}
|
||||||
|
|
||||||
instance FromJSON TestScriptPubKey where
|
testScriptPubKeyParseJSON :: Ctx -> Value -> Parser TestScriptPubKey
|
||||||
parseJSON = withObject "TestScriptPubKey" $ \obj ->
|
testScriptPubKeyParseJSON ctx = withObject "TestScriptPubKey" $ \obj -> do
|
||||||
TestScriptPubKey
|
given <- unSpkGiven <$> (spkGivenParseJSON ctx =<< obj .: "given")
|
||||||
<$> (unSpkGiven <$> obj .: "given")
|
inter <- spkIntermediaryParseJSON ctx =<< obj .: "intermediary"
|
||||||
<*> obj .: "intermediary"
|
expect <- spkExpectedParseJSON ctx =<< obj .: "expected"
|
||||||
<*> obj .: "expected"
|
return $ TestScriptPubKey given inter expect
|
||||||
|
|
||||||
newtype TestVector = TestVector
|
newtype TestVector = TestVector
|
||||||
{ testScriptPubKey :: [TestScriptPubKey]
|
{ testScriptPubKey :: [TestScriptPubKey]
|
||||||
}
|
}
|
||||||
|
|
||||||
instance FromJSON TestVector where
|
testVectorParseJSON :: Ctx -> Value -> Parser TestVector
|
||||||
parseJSON = withObject "TestVector" $ \obj ->
|
testVectorParseJSON ctx = withObject "TestVector" $ \obj ->
|
||||||
TestVector <$> obj .: "scriptPubKey"
|
TestVector <$> (mapM (testScriptPubKeyParseJSON ctx) =<< obj .: "scriptPubKey")
|
||||||
|
|
||||||
jsonHex :: Text -> Parser ByteString
|
jsonHex :: Text -> Parser ByteString
|
||||||
jsonHex = maybe (fail "Unable to decode hex") pure . decodeHex
|
jsonHex = maybe (fail "Unable to decode hex") pure . decodeHex
|
||||||
|
@ -1,8 +1,14 @@
|
|||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
|
{-# LANGUAGE OverloadedRecordDot #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
|
||||||
module Haskoin.TransactionSpec (spec) where
|
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.Get
|
||||||
import Data.Bytes.Put
|
import Data.Bytes.Put
|
||||||
import Data.Bytes.Serial
|
import Data.Bytes.Serial
|
||||||
@ -13,9 +19,9 @@ import Data.String.Conversions
|
|||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Word (Word32, Word64)
|
import Data.Word (Word32, Word64)
|
||||||
import Haskoin.Address
|
import Haskoin.Address
|
||||||
import Haskoin.Constants
|
import Haskoin.Crypto
|
||||||
import Haskoin.Data
|
import Haskoin.Network.Constants
|
||||||
import Haskoin.Keys
|
import Haskoin.Network.Data
|
||||||
import Haskoin.Script
|
import Haskoin.Script
|
||||||
import Haskoin.Transaction
|
import Haskoin.Transaction
|
||||||
import Haskoin.Util
|
import Haskoin.Util
|
||||||
@ -25,345 +31,317 @@ import Test.Hspec
|
|||||||
import Test.Hspec.QuickCheck
|
import Test.Hspec.QuickCheck
|
||||||
import Test.QuickCheck
|
import Test.QuickCheck
|
||||||
|
|
||||||
serialVals :: [SerialBox]
|
serialVals :: Ctx -> [SerialBox]
|
||||||
serialVals =
|
serialVals ctx =
|
||||||
[ SerialBox $ arbitraryTx =<< arbitraryNetwork
|
[ SerialBox $ flip arbitraryTx ctx =<< arbitraryNetwork,
|
||||||
, SerialBox $ arbitraryWitnessTx =<< arbitraryNetwork
|
SerialBox $ flip arbitraryWitnessTx ctx =<< arbitraryNetwork,
|
||||||
, SerialBox $ arbitraryLegacyTx =<< arbitraryNetwork
|
SerialBox $ flip arbitraryLegacyTx ctx =<< arbitraryNetwork,
|
||||||
, SerialBox $ arbitraryTxIn =<< arbitraryNetwork
|
SerialBox $ flip arbitraryTxIn ctx =<< arbitraryNetwork,
|
||||||
, SerialBox $ arbitraryTxOut =<< arbitraryNetwork
|
SerialBox $ flip arbitraryTxOut ctx =<< arbitraryNetwork,
|
||||||
, SerialBox arbitraryOutPoint
|
SerialBox arbitraryOutPoint
|
||||||
]
|
]
|
||||||
|
|
||||||
readVals :: [ReadBox]
|
readVals :: Ctx -> [ReadBox]
|
||||||
readVals =
|
readVals ctx =
|
||||||
[ ReadBox arbitraryTxHash
|
[ ReadBox arbitraryTxHash,
|
||||||
, ReadBox $ arbitraryTx =<< arbitraryNetwork
|
ReadBox $ flip arbitraryTx ctx =<< arbitraryNetwork,
|
||||||
, ReadBox $ arbitraryTxIn =<< arbitraryNetwork
|
ReadBox $ flip arbitraryTxIn ctx =<< arbitraryNetwork,
|
||||||
, ReadBox $ arbitraryTxOut =<< arbitraryNetwork
|
ReadBox $ flip arbitraryTxOut ctx =<< arbitraryNetwork,
|
||||||
, ReadBox arbitraryOutPoint
|
ReadBox arbitraryOutPoint
|
||||||
]
|
]
|
||||||
|
|
||||||
jsonVals :: [JsonBox]
|
jsonVals :: Ctx -> [JsonBox]
|
||||||
jsonVals =
|
jsonVals ctx =
|
||||||
[ JsonBox arbitraryTxHash
|
[ JsonBox arbitraryTxHash,
|
||||||
, JsonBox $ arbitraryTx =<< arbitraryNetwork
|
JsonBox $ flip arbitraryTx ctx =<< arbitraryNetwork,
|
||||||
, JsonBox $ arbitraryWitnessTx =<< arbitraryNetwork
|
JsonBox $ flip arbitraryWitnessTx ctx =<< arbitraryNetwork,
|
||||||
, JsonBox $ arbitraryLegacyTx =<< arbitraryNetwork
|
JsonBox $ flip arbitraryLegacyTx ctx =<< arbitraryNetwork,
|
||||||
, JsonBox $ arbitraryTxIn =<< arbitraryNetwork
|
JsonBox $ flip arbitraryTxIn ctx =<< arbitraryNetwork,
|
||||||
, JsonBox $ arbitraryTxOut =<< arbitraryNetwork
|
JsonBox $ flip arbitraryTxOut ctx =<< arbitraryNetwork,
|
||||||
, JsonBox arbitraryOutPoint
|
JsonBox arbitraryOutPoint
|
||||||
]
|
]
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = do
|
spec = prepareContext $ \ctx -> do
|
||||||
testIdentity serialVals readVals jsonVals []
|
testIdentity (serialVals ctx) (readVals ctx) (jsonVals ctx) []
|
||||||
describe "Transaction properties" $ do
|
describe "Transaction properties" $ do
|
||||||
prop "decode and encode txid" $
|
prop "decode and encode txid" $
|
||||||
forAll arbitraryTxHash $ \h -> hexToTxHash (txHashToHex h) == Just h
|
forAll arbitraryTxHash $
|
||||||
prop "from string transaction id" $
|
\h -> hexToTxHash (txHashToHex h) == Just h
|
||||||
forAll arbitraryTxHash $ \h -> fromString (cs $ txHashToHex h) == h
|
prop "from string transaction id" $
|
||||||
prop "building address tx" $
|
forAll arbitraryTxHash $
|
||||||
forAll arbitraryNetwork $ \net ->
|
\h -> fromString (cs $ txHashToHex h) == h
|
||||||
forAll arbitraryAddress $
|
prop "building address tx" $
|
||||||
forAll (arbitrarySatoshi net) . testBuildAddrTx net
|
forAll arbitraryNetwork $ \net ->
|
||||||
prop "guess transaction size" $
|
forAll arbitraryAddress $
|
||||||
forAll arbitraryNetwork $ \net ->
|
forAll (arbitrarySatoshi net) . testBuildAddrTx net ctx
|
||||||
forAll (arbitraryAddrOnlyTxFull net) (testGuessSize net)
|
prop "guess transaction size" $
|
||||||
prop "choose coins" $
|
forAll arbitraryNetwork $ \net ->
|
||||||
forAll arbitraryNetwork $ \net ->
|
forAll (arbitraryAddrOnlyTxFull net ctx) (testGuessSize net ctx)
|
||||||
forAll (listOf (arbitrarySatoshi net)) testChooseCoins
|
prop "choose coins" $
|
||||||
prop "choose multisig coins" $
|
forAll arbitraryNetwork $ \net ->
|
||||||
forAll arbitraryNetwork $ \net ->
|
forAll (listOf (arbitrarySatoshi net)) testChooseCoins
|
||||||
forAll arbitraryMSParam $
|
prop "choose multisig coins" $
|
||||||
forAll (listOf (arbitrarySatoshi net)) . testChooseMSCoins
|
forAll arbitraryNetwork $ \net ->
|
||||||
prop "sign and validate transaction" $
|
forAll arbitraryMSParam $
|
||||||
forAll arbitraryNetwork $ \net ->
|
forAll (listOf (arbitrarySatoshi net)) . testChooseMSCoins
|
||||||
forAll (arbitrarySigningData net) (testDetSignTx net)
|
prop "sign and validate transaction" $
|
||||||
prop "sign and validate (nested) transaction" $
|
forAll arbitraryNetwork $ \net ->
|
||||||
forAll arbitraryNetwork $ \net ->
|
forAll (arbitrarySigningData net ctx) (testDetSignTx net ctx)
|
||||||
forAll (arbitrarySigningData net) (testDetSignNestedTx net)
|
prop "sign and validate (nested) transaction" $
|
||||||
prop "merge partially signed transactions" $
|
forAll arbitraryNetwork $ \net ->
|
||||||
forAll arbitraryNetwork $ \net ->
|
forAll (arbitrarySigningData net ctx) (testDetSignNestedTx net ctx)
|
||||||
property $ forAll (arbitraryPartialTxs net) (testMergeTx net)
|
prop "merge partially signed transactions" $
|
||||||
describe "Transaction vectors" $ do
|
forAll arbitraryNetwork $ \net ->
|
||||||
it "compute txid from tx" $ mapM_ testTxidVector txidVectors
|
property $ forAll (arbitraryPartialTxs net ctx) (testMergeTx net ctx)
|
||||||
it "build pkhash transaction (generated from bitcoind)" $
|
describe "Transaction vectors" $ do
|
||||||
mapM_ testPKHashVector pkHashVectors
|
it "compute txid from tx" $ mapM_ testTxidVector txidVectors
|
||||||
|
it "build pkhash transaction (generated from bitcoind)" $
|
||||||
|
mapM_ (testPKHashVector ctx) pkHashVectors
|
||||||
|
|
||||||
-- Txid Vectors
|
-- Txid Vectors
|
||||||
|
|
||||||
testTxidVector :: (Text, Text) -> Assertion
|
testTxidVector :: (Text, Text) -> Assertion
|
||||||
testTxidVector (tid, tx) =
|
testTxidVector (tid, tx) =
|
||||||
assertEqual "txid" (Just tid) (txHashToHex . txHash <$> txM)
|
assertEqual "txid" (Just tid) (txHashToHex . txHash <$> txM)
|
||||||
where
|
where
|
||||||
txM = eitherToMaybe . runGetS deserialize =<< decodeHex tx
|
txM = eitherToMaybe . runGetS deserialize =<< decodeHex tx
|
||||||
|
|
||||||
txidVectors :: [(Text, Text)]
|
txidVectors :: [(Text, Text)]
|
||||||
txidVectors =
|
txidVectors =
|
||||||
[
|
[ ( "23b397edccd3740a74adb603c9756370fafcde9bcc4483eb271ecad09a94dd63",
|
||||||
( "23b397edccd3740a74adb603c9756370fafcde9bcc4483eb271ecad09a94dd63"
|
"0100000001b14bdcbc3e01bdaad36cc08e81e69c82e1060bc14e518db2b49aa4\
|
||||||
, "0100000001b14bdcbc3e01bdaad36cc08e81e69c82e1060bc14e518db2b49aa4\
|
\3ad90ba26000000000490047304402203f16c6f40162ab686621ef3000b04e75\
|
||||||
\3ad90ba26000000000490047304402203f16c6f40162ab686621ef3000b04e75\
|
\418a0c0cb2d8aebeac894ae360ac1e780220ddc15ecdfc3507ac48e1681a33eb\
|
||||||
\418a0c0cb2d8aebeac894ae360ac1e780220ddc15ecdfc3507ac48e1681a33eb\
|
\60996631bf6bf5bc0a0682c4db743ce7ca2b01ffffffff0140420f0000000000\
|
||||||
\60996631bf6bf5bc0a0682c4db743ce7ca2b01ffffffff0140420f0000000000\
|
\1976a914660d4ef3a743e3e696ad990364e555c271ad504b88ac00000000"
|
||||||
\1976a914660d4ef3a743e3e696ad990364e555c271ad504b88ac00000000"
|
),
|
||||||
)
|
( "c99c49da4c38af669dea436d3e73780dfdb6c1ecf9958baa52960e8baee30e73",
|
||||||
,
|
"01000000010276b76b07f4935c70acf54fbf1f438a4c397a9fb7e633873c4dd3\
|
||||||
( "c99c49da4c38af669dea436d3e73780dfdb6c1ecf9958baa52960e8baee30e73"
|
\bc062b6b40000000008c493046022100d23459d03ed7e9511a47d13292d3430a\
|
||||||
, "01000000010276b76b07f4935c70acf54fbf1f438a4c397a9fb7e633873c4dd3\
|
\04627de6235b6e51a40f9cd386f2abe3022100e7d25b080f0bb8d8d5f878bba7\
|
||||||
\bc062b6b40000000008c493046022100d23459d03ed7e9511a47d13292d3430a\
|
\d54ad2fda650ea8d158a33ee3cbd11768191fd004104b0e2c879e4daf7b9ab68\
|
||||||
\04627de6235b6e51a40f9cd386f2abe3022100e7d25b080f0bb8d8d5f878bba7\
|
\350228c159766676a14f5815084ba166432aab46198d4cca98fa3e9981d0a90b\
|
||||||
\d54ad2fda650ea8d158a33ee3cbd11768191fd004104b0e2c879e4daf7b9ab68\
|
\2effc514b76279476550ba3663fdcaff94c38420e9d5000000000100093d0000\
|
||||||
\350228c159766676a14f5815084ba166432aab46198d4cca98fa3e9981d0a90b\
|
\0000001976a9149a7b0f3b80c6baaeedce0a0842553800f832ba1f88ac000000\
|
||||||
\2effc514b76279476550ba3663fdcaff94c38420e9d5000000000100093d0000\
|
\00"
|
||||||
\0000001976a9149a7b0f3b80c6baaeedce0a0842553800f832ba1f88ac000000\
|
),
|
||||||
\00"
|
( "f7fdd091fa6d8f5e7a8c2458f5c38faffff2d3f1406b6e4fe2c99dcc0d2d1cbb",
|
||||||
)
|
"01000000023d6cf972d4dff9c519eff407ea800361dd0a121de1da8b6f4138a2\
|
||||||
,
|
\f25de864b4000000008a4730440220ffda47bfc776bcd269da4832626ac332ad\
|
||||||
( "f7fdd091fa6d8f5e7a8c2458f5c38faffff2d3f1406b6e4fe2c99dcc0d2d1cbb"
|
\fca6dd835e8ecd83cd1ebe7d709b0e022049cffa1cdc102a0b56e0e04913606c\
|
||||||
, "01000000023d6cf972d4dff9c519eff407ea800361dd0a121de1da8b6f4138a2\
|
\70af702a1149dc3b305ab9439288fee090014104266abb36d66eb4218a6dd31f\
|
||||||
\f25de864b4000000008a4730440220ffda47bfc776bcd269da4832626ac332ad\
|
\09bb92cf3cfa803c7ea72c1fc80a50f919273e613f895b855fb7465ccbc8919a\
|
||||||
\fca6dd835e8ecd83cd1ebe7d709b0e022049cffa1cdc102a0b56e0e04913606c\
|
\d1bd4a306c783f22cd3227327694c4fa4c1c439affffffff21ebc9ba20594737\
|
||||||
\70af702a1149dc3b305ab9439288fee090014104266abb36d66eb4218a6dd31f\
|
\864352e95b727f1a565756f9d365083eb1a8596ec98c97b7010000008a473044\
|
||||||
\09bb92cf3cfa803c7ea72c1fc80a50f919273e613f895b855fb7465ccbc8919a\
|
\0220503ff10e9f1e0de731407a4a245531c9ff17676eda461f8ceeb8c06049fa\
|
||||||
\d1bd4a306c783f22cd3227327694c4fa4c1c439affffffff21ebc9ba20594737\
|
\2c810220c008ac34694510298fa60b3f000df01caa244f165b727d4896eb84f8\
|
||||||
\864352e95b727f1a565756f9d365083eb1a8596ec98c97b7010000008a473044\
|
\1e46bcc4014104266abb36d66eb4218a6dd31f09bb92cf3cfa803c7ea72c1fc8\
|
||||||
\0220503ff10e9f1e0de731407a4a245531c9ff17676eda461f8ceeb8c06049fa\
|
\0a50f919273e613f895b855fb7465ccbc8919ad1bd4a306c783f22cd32273276\
|
||||||
\2c810220c008ac34694510298fa60b3f000df01caa244f165b727d4896eb84f8\
|
\94c4fa4c1c439affffffff01f0da5200000000001976a914857ccd42dded6df3\
|
||||||
\1e46bcc4014104266abb36d66eb4218a6dd31f09bb92cf3cfa803c7ea72c1fc8\
|
\2949d4646dfa10a92458cfaa88ac00000000"
|
||||||
\0a50f919273e613f895b855fb7465ccbc8919ad1bd4a306c783f22cd32273276\
|
),
|
||||||
\94c4fa4c1c439affffffff01f0da5200000000001976a914857ccd42dded6df3\
|
( "afd9c17f8913577ec3509520bd6e5d63e9c0fd2a5f70c787993b097ba6ca9fae",
|
||||||
\2949d4646dfa10a92458cfaa88ac00000000"
|
"010000000370ac0a1ae588aaf284c308d67ca92c69a39e2db81337e563bf40c5\
|
||||||
)
|
\9da0a5cf63000000006a4730440220360d20baff382059040ba9be98947fd678\
|
||||||
,
|
\fb08aab2bb0c172efa996fd8ece9b702201b4fb0de67f015c90e7ac8a193aeab\
|
||||||
( "afd9c17f8913577ec3509520bd6e5d63e9c0fd2a5f70c787993b097ba6ca9fae"
|
\486a1f587e0f54d0fb9552ef7f5ce6caec032103579ca2e6d107522f012cd00b\
|
||||||
, "010000000370ac0a1ae588aaf284c308d67ca92c69a39e2db81337e563bf40c5\
|
\52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff7d815b6447e35fbe\
|
||||||
\9da0a5cf63000000006a4730440220360d20baff382059040ba9be98947fd678\
|
\a097e00e028fb7dfbad4f3f0987b4734676c84f3fcd0e804010000006b483045\
|
||||||
\fb08aab2bb0c172efa996fd8ece9b702201b4fb0de67f015c90e7ac8a193aeab\
|
\022100c714310be1e3a9ff1c5f7cacc65c2d8e781fc3a88ceb063c6153bf9506\
|
||||||
\486a1f587e0f54d0fb9552ef7f5ce6caec032103579ca2e6d107522f012cd00b\
|
\50802102200b2d0979c76e12bb480da635f192cc8dc6f905380dd4ac1ff35a4f\
|
||||||
\52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff7d815b6447e35fbe\
|
\68f462fffd032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e3\
|
||||||
\a097e00e028fb7dfbad4f3f0987b4734676c84f3fcd0e804010000006b483045\
|
\77c48f526a44741affffffff3f1f097333e4d46d51f5e77b53264db8f7f5d2e1\
|
||||||
\022100c714310be1e3a9ff1c5f7cacc65c2d8e781fc3a88ceb063c6153bf9506\
|
\8217e1099957d0f5af7713ee010000006c493046022100b663499ef73273a378\
|
||||||
\50802102200b2d0979c76e12bb480da635f192cc8dc6f905380dd4ac1ff35a4f\
|
\8dea342717c2640ac43c5a1cf862c9e09b206fcb3f6bb8022100b09972e75972\
|
||||||
\68f462fffd032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e3\
|
\d9148f2bdd462e5cb69b57c1214b88fc55ca638676c07cfc10d8032103579ca2\
|
||||||
\77c48f526a44741affffffff3f1f097333e4d46d51f5e77b53264db8f7f5d2e1\
|
\e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffff\
|
||||||
\8217e1099957d0f5af7713ee010000006c493046022100b663499ef73273a378\
|
\ff0380841e00000000001976a914bfb282c70c4191f45b5a6665cad1682f2c9c\
|
||||||
\8dea342717c2640ac43c5a1cf862c9e09b206fcb3f6bb8022100b09972e75972\
|
\fdfb88ac80841e00000000001976a9149857cc07bed33a5cf12b9c5e0500b675\
|
||||||
\d9148f2bdd462e5cb69b57c1214b88fc55ca638676c07cfc10d8032103579ca2\
|
\d500c81188ace0fd1c00000000001976a91443c52850606c872403c0601e69fa\
|
||||||
\e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffff\
|
\34b26f62db4a88ac00000000"
|
||||||
\ff0380841e00000000001976a914bfb282c70c4191f45b5a6665cad1682f2c9c\
|
)
|
||||||
\fdfb88ac80841e00000000001976a9149857cc07bed33a5cf12b9c5e0500b675\
|
]
|
||||||
\d500c81188ace0fd1c00000000001976a91443c52850606c872403c0601e69fa\
|
|
||||||
\34b26f62db4a88ac00000000"
|
|
||||||
)
|
|
||||||
]
|
|
||||||
|
|
||||||
-- Build address transactions vectors generated from bitcoin-core raw tx API
|
-- Build address transactions vectors generated from bitcoin-core raw tx API
|
||||||
|
|
||||||
testPKHashVector :: ([(Text, Word32)], [(Text, Word64)], Text) -> Assertion
|
testPKHashVector :: Ctx -> ([(Text, Word32)], [(Text, Word64)], Text) -> Assertion
|
||||||
testPKHashVector (is, os, res) =
|
testPKHashVector ctx (is, os, res) =
|
||||||
assertEqual
|
assertEqual
|
||||||
"Build PKHash Tx"
|
"Build PKHash Tx"
|
||||||
(Right res)
|
(Right res)
|
||||||
(encodeHex . runPutS . serialize <$> txE)
|
(encodeHex . runPutS . serialize <$> txE)
|
||||||
where
|
where
|
||||||
txE = buildAddrTx btc (map f is) os
|
txE = buildAddrTx btc ctx (map f is) os
|
||||||
f (tid, ix) = OutPoint (fromJust $ hexToTxHash tid) ix
|
f (tid, ix) = OutPoint (fromJust $ hexToTxHash tid) ix
|
||||||
|
|
||||||
pkHashVectors :: [([(Text, Word32)], [(Text, Word64)], Text)]
|
pkHashVectors :: [([(Text, Word32)], [(Text, Word64)], Text)]
|
||||||
pkHashVectors =
|
pkHashVectors =
|
||||||
[
|
[ ( [ ( "eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db",
|
||||||
(
|
14
|
||||||
[
|
|
||||||
( "eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db"
|
|
||||||
, 14
|
|
||||||
)
|
|
||||||
]
|
|
||||||
, [("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb", 90000000)]
|
|
||||||
, "0100000001db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654\
|
|
||||||
\a1eb29eb0e00000000ffffffff01804a5d05000000001976a91424aa604689cc58\
|
|
||||||
\2292b97668bedd91dd5bf9374c88ac00000000"
|
|
||||||
)
|
)
|
||||||
,
|
],
|
||||||
(
|
[("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb", 90000000)],
|
||||||
[
|
"0100000001db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654\
|
||||||
( "eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db"
|
\a1eb29eb0e00000000ffffffff01804a5d05000000001976a91424aa604689cc58\
|
||||||
, 0
|
\2292b97668bedd91dd5bf9374c88ac00000000"
|
||||||
)
|
),
|
||||||
,
|
( [ ( "eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db",
|
||||||
( "0001000000000000000000000000000000000000000000000000000000000000"
|
0
|
||||||
, 2147483647
|
),
|
||||||
)
|
( "0001000000000000000000000000000000000000000000000000000000000000",
|
||||||
]
|
2147483647
|
||||||
,
|
|
||||||
[ ("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb", 1)
|
|
||||||
, ("19VCgS642vzEA1sdByoSn6GsWBwraV8D4n", 2100000000000000)
|
|
||||||
]
|
|
||||||
, "0100000002db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654\
|
|
||||||
\a1eb29eb0000000000ffffffff0000000000000000000000000000000000000000\
|
|
||||||
\000000000000000000000100ffffff7f00ffffffff0201000000000000001976a9\
|
|
||||||
\1424aa604689cc582292b97668bedd91dd5bf9374c88ac0040075af07507001976\
|
|
||||||
\a9145d16672f53981ff21c5f42b40d1954993cbca54f88ac00000000"
|
|
||||||
)
|
)
|
||||||
,
|
],
|
||||||
(
|
[ ("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb", 1),
|
||||||
[
|
("19VCgS642vzEA1sdByoSn6GsWBwraV8D4n", 2100000000000000)
|
||||||
( "eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db"
|
],
|
||||||
, 0
|
"0100000002db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654\
|
||||||
)
|
\a1eb29eb0000000000ffffffff0000000000000000000000000000000000000000\
|
||||||
,
|
\000000000000000000000100ffffff7f00ffffffff0201000000000000001976a9\
|
||||||
( "0001000000000000000000000000000000000000000000000000000000000000"
|
\1424aa604689cc582292b97668bedd91dd5bf9374c88ac0040075af07507001976\
|
||||||
, 2147483647
|
\a9145d16672f53981ff21c5f42b40d1954993cbca54f88ac00000000"
|
||||||
)
|
),
|
||||||
]
|
( [ ( "eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db",
|
||||||
, []
|
0
|
||||||
, "0100000002db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654a\
|
),
|
||||||
\1eb29eb0000000000ffffffff000000000000000000000000000000000000000000\
|
( "0001000000000000000000000000000000000000000000000000000000000000",
|
||||||
\0000000000000000000100ffffff7f00ffffffff0000000000"
|
2147483647
|
||||||
)
|
)
|
||||||
,
|
],
|
||||||
( []
|
[],
|
||||||
,
|
"0100000002db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654a\
|
||||||
[ ("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb", 1)
|
\1eb29eb0000000000ffffffff000000000000000000000000000000000000000000\
|
||||||
, ("19VCgS642vzEA1sdByoSn6GsWBwraV8D4n", 2100000000000000)
|
\0000000000000000000100ffffff7f00ffffffff0000000000"
|
||||||
]
|
),
|
||||||
, "01000000000201000000000000001976a91424aa604689cc582292b97668bedd91d\
|
( [],
|
||||||
\d5bf9374c88ac0040075af07507001976a9145d16672f53981ff21c5f42b40d1954\
|
[ ("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb", 1),
|
||||||
\993cbca54f88ac00000000"
|
("19VCgS642vzEA1sdByoSn6GsWBwraV8D4n", 2100000000000000)
|
||||||
)
|
],
|
||||||
]
|
"01000000000201000000000000001976a91424aa604689cc582292b97668bedd91d\
|
||||||
|
\d5bf9374c88ac0040075af07507001976a9145d16672f53981ff21c5f42b40d1954\
|
||||||
|
\993cbca54f88ac00000000"
|
||||||
|
)
|
||||||
|
]
|
||||||
|
|
||||||
-- Transaction Properties --
|
-- Transaction Properties --
|
||||||
|
|
||||||
testBuildAddrTx :: Network -> Address -> TestCoin -> Bool
|
testBuildAddrTx :: Network -> Ctx -> Address -> TestCoin -> Bool
|
||||||
testBuildAddrTx net a (TestCoin v)
|
testBuildAddrTx net ctx a (TestCoin v)
|
||||||
| isPubKeyAddress a = Right (PayPKHash (getAddrHash160 a)) == out
|
| isPubKeyAddress a = PayPKHash a.hash160 == out
|
||||||
| isScriptAddress a = Right (PayScriptHash (getAddrHash160 a)) == out
|
| isScriptAddress a = PayScriptHash a.hash160 == out
|
||||||
| otherwise = undefined
|
| otherwise = undefined
|
||||||
where
|
where
|
||||||
tx = buildAddrTx net [] [(fromJust (addrToText net a), v)]
|
out = either error id $ do
|
||||||
out =
|
tx <- buildAddrTx net ctx [] [(fromJust (addrToText net a), v)]
|
||||||
decodeOutputBS $
|
unmarshal ctx (head tx.outputs).script
|
||||||
scriptOutput $
|
|
||||||
head $ txOut (fromRight (error "Could not build transaction") tx)
|
|
||||||
|
|
||||||
-- We compute an upper bound but it should be close enough to the real size
|
-- 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)
|
-- We give 2 bytes of slack on every signature (1 on r and 1 on s)
|
||||||
testGuessSize :: Network -> Tx -> Bool
|
testGuessSize :: Network -> Ctx -> Tx -> Bool
|
||||||
testGuessSize net tx =
|
testGuessSize net ctx tx =
|
||||||
guess >= len && guess <= len + 2 * delta
|
guess >= len && guess <= len + 2 * delta
|
||||||
where
|
where
|
||||||
delta = pki + sum (map fst msi)
|
delta = pki + sum (map fst msi)
|
||||||
guess = guessTxSize pki msi pkout msout
|
guess = guessTxSize pki msi pkout msout
|
||||||
len = B.length $ runPutS $ serialize tx
|
len = B.length $ runPutS $ serialize tx
|
||||||
ins = map f $ txIn tx
|
ins = map f tx.inputs
|
||||||
f i =
|
f i = either error id $ unmarshal (net, ctx) i.script
|
||||||
fromRight (error "Could not decode input") $
|
|
||||||
decodeInputBS net $ scriptInput i
|
|
||||||
pki = length $ filter isSpendPKHash ins
|
pki = length $ filter isSpendPKHash ins
|
||||||
msi = concatMap shData ins
|
msi = concatMap shData ins
|
||||||
shData (ScriptHashInput _ (PayMulSig keys r)) = [(r, length keys)]
|
shData (ScriptHashInput _ (PayMulSig keys r)) = [(r, length keys)]
|
||||||
shData _ = []
|
shData _ = []
|
||||||
out =
|
out = map (either error id . unmarshal ctx . (.script)) tx.outputs
|
||||||
map
|
|
||||||
( fromRight (error "Could not decode transaction output")
|
|
||||||
. decodeOutputBS
|
|
||||||
. scriptOutput
|
|
||||||
)
|
|
||||||
$ txOut tx
|
|
||||||
pkout = length $ filter isPayPKHash out
|
pkout = length $ filter isPayPKHash out
|
||||||
msout = length $ filter isPayScriptHash out
|
msout = length $ filter isPayScriptHash out
|
||||||
|
|
||||||
testChooseCoins :: [TestCoin] -> Word64 -> Word64 -> Int -> Property
|
testChooseCoins :: [TestCoin] -> Word64 -> Word64 -> Int -> Property
|
||||||
testChooseCoins coins target byteFee nOut =
|
testChooseCoins coins target byteFee nOut =
|
||||||
nOut >= 0
|
nOut >= 0 ==>
|
||||||
==> case chooseCoins target byteFee nOut True coins of
|
case chooseCoins target byteFee nOut True coins of
|
||||||
Right (chosen, change) ->
|
Right (chosen, change) ->
|
||||||
let outSum = sum $ map coinValue chosen
|
let outSum = sum $ map coinValue chosen
|
||||||
fee = guessTxFee byteFee nOut (length chosen)
|
fee = guessTxFee byteFee nOut (length chosen)
|
||||||
in outSum == target + change + fee
|
in outSum == target + change + fee
|
||||||
Left _ ->
|
Left _ ->
|
||||||
let fee = guessTxFee byteFee nOut (length coins)
|
let fee = guessTxFee byteFee nOut (length coins)
|
||||||
in target == 0 || s < target + fee
|
in target == 0 || s < target + fee
|
||||||
where
|
where
|
||||||
s = sum $ map coinValue coins
|
s = sum $ map coinValue coins
|
||||||
|
|
||||||
testChooseMSCoins ::
|
testChooseMSCoins ::
|
||||||
(Int, Int) ->
|
(Int, Int) ->
|
||||||
[TestCoin] ->
|
[TestCoin] ->
|
||||||
Word64 ->
|
Word64 ->
|
||||||
Word64 ->
|
Word64 ->
|
||||||
Int ->
|
Int ->
|
||||||
Property
|
Property
|
||||||
testChooseMSCoins (m, n) coins target byteFee nOut =
|
testChooseMSCoins (m, n) coins target byteFee nOut =
|
||||||
nOut >= 0
|
nOut >= 0 ==>
|
||||||
==> case chooseMSCoins target byteFee (m, n) nOut True coins of
|
case chooseMSCoins target byteFee (m, n) nOut True coins of
|
||||||
Right (chosen, change) ->
|
Right (chosen, change) ->
|
||||||
let outSum = sum $ map coinValue chosen
|
let outSum = sum $ map coinValue chosen
|
||||||
fee = guessMSTxFee byteFee (m, n) nOut (length chosen)
|
fee = guessMSTxFee byteFee (m, n) nOut (length chosen)
|
||||||
in outSum == target + change + fee
|
in outSum == target + change + fee
|
||||||
Left _ ->
|
Left _ ->
|
||||||
let fee = guessMSTxFee byteFee (m, n) nOut (length coins)
|
let fee = guessMSTxFee byteFee (m, n) nOut (length coins)
|
||||||
in target == 0 || s < target + fee
|
in target == 0 || s < target + fee
|
||||||
where
|
where
|
||||||
s = sum $ map coinValue coins
|
s = sum $ map coinValue coins
|
||||||
|
|
||||||
{- Signing Transactions -}
|
{- Signing Transactions -}
|
||||||
|
|
||||||
testDetSignTx :: Network -> (Tx, [SigInput], [SecKeyI]) -> Bool
|
testDetSignTx :: Network -> Ctx -> (Tx, [SigInput], [PrivateKey]) -> Bool
|
||||||
testDetSignTx net (tx, sigis, prv) =
|
testDetSignTx net ctx (tx, sigis, prv) =
|
||||||
not (verifyStdTx net tx verData)
|
not verify1 && not verify2 && verify3
|
||||||
&& not (verifyStdTx net txSigP verData)
|
|
||||||
&& verifyStdTx net txSigC verData
|
|
||||||
where
|
where
|
||||||
txSigP =
|
verify1 = verifyStdTx net ctx tx verData
|
||||||
fromRight (error "Could not decode transaction") $
|
verify2 = verifyStdTx net ctx txSigP verData
|
||||||
signTx net tx sigis (map secKeyData (tail prv))
|
verify3 = verifyStdTx net ctx txSigC verData
|
||||||
txSigC =
|
txSigP = either error id $ signTx net ctx tx sigis (map (.key) (tail prv))
|
||||||
fromRight (error "Could not decode transaction") $
|
txSigC = either error id $ signTx net ctx txSigP sigis [(head prv).key]
|
||||||
signTx net txSigP sigis [secKeyData (head prv)]
|
sigData SigInput {..} = (script, value, outpoint)
|
||||||
verData = map (\(SigInput s v o _ _) -> (s, v, o)) sigis
|
verData = map sigData sigis
|
||||||
|
|
||||||
testDetSignNestedTx :: Network -> (Tx, [SigInput], [SecKeyI]) -> Bool
|
testDetSignNestedTx :: Network -> Ctx -> (Tx, [SigInput], [PrivateKey]) -> Bool
|
||||||
testDetSignNestedTx net (tx, sigis, prv) =
|
testDetSignNestedTx net ctx (tx, sigis, prv) =
|
||||||
not (verifyStdTx net tx verData)
|
not verify1 && not verify2 && verify3
|
||||||
&& not (verifyStdTx net txSigP verData)
|
|
||||||
&& verifyStdTx net txSigC verData
|
|
||||||
where
|
where
|
||||||
|
verify1 = verifyStdTx net ctx tx verData
|
||||||
|
verify2 = verifyStdTx net ctx txSigP verData
|
||||||
|
verify3 = verifyStdTx net ctx txSigC verData
|
||||||
txSigP =
|
txSigP =
|
||||||
fromRight (error "Could not decode transaction") $
|
either error id $
|
||||||
signNestedWitnessTx net tx sigis (secKeyData <$> tail prv)
|
signNestedWitnessTx net ctx tx sigis ((.key) <$> tail prv)
|
||||||
txSigC =
|
txSigC =
|
||||||
fromRight (error "Could not decode transaction") $
|
either error id $
|
||||||
signNestedWitnessTx net txSigP sigis [secKeyData (head prv)]
|
signNestedWitnessTx net ctx txSigP sigis [(head prv).key]
|
||||||
verData = handleSegwit <$> sigis
|
verData = handleSegwit <$> sigis
|
||||||
handleSegwit (SigInput s v o _ _)
|
handleSegwit (SigInput s v o _ _)
|
||||||
| isSegwit s = (toP2SH $ encodeOutput s, v, o)
|
| isSegwit s = (toP2SH (encodeOutput ctx s), v, o)
|
||||||
| otherwise = (s, v, o)
|
| otherwise = (s, v, o)
|
||||||
|
|
||||||
testMergeTx :: Network -> ([Tx], [(ScriptOutput, Word64, OutPoint, Int, Int)]) -> Bool
|
testMergeTx :: Network -> Ctx -> ([Tx], [(ScriptOutput, Word64, OutPoint, Int, Int)]) -> Bool
|
||||||
testMergeTx net (txs, os) =
|
testMergeTx net ctx (txs, os) =
|
||||||
and
|
and
|
||||||
[ isRight mergeRes
|
[ isRight mergeRes,
|
||||||
, length (txIn mergedTx) == length os
|
length mergedTx.inputs == length os,
|
||||||
, if enoughSigs
|
if enoughSigs
|
||||||
then isValid
|
then isValid
|
||||||
else not isValid
|
else not isValid,
|
||||||
, -- Signature count == min (length txs) (sum required signatures)
|
-- Signature count == min (length txs) (sum required signatures)
|
||||||
sum (map snd sigMap) == min (length txs) (sum (map fst sigMap))
|
sum (map snd sigMap) == min (length txs) (sum (map fst sigMap))
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
outs = map (\(so, val, op, _, _) -> (so, val, op)) os
|
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
|
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
|
enoughSigs = all (\(m, c) -> c >= m) sigMap
|
||||||
sigMap =
|
sigFun (_, _, _, m, _) inp = (m, sigCnt inp)
|
||||||
map (\((_, _, _, m, _), inp) -> (m, sigCnt inp)) $
|
sigMap = zipWith sigFun os mergedTx.inputs
|
||||||
zip os $ txIn mergedTx
|
|
||||||
sigCnt inp =
|
sigCnt inp =
|
||||||
case decodeInputBS net $ scriptInput inp of
|
case unmarshal (net, ctx) inp.script of
|
||||||
Right (RegularInput (SpendMulSig sigs)) -> length sigs
|
Right (RegularInput (SpendMulSig sigs)) -> length sigs
|
||||||
Right (ScriptHashInput (SpendMulSig sigs) _) -> length sigs
|
Right (ScriptHashInput (SpendMulSig sigs) _) -> length sigs
|
||||||
_ -> error "Invalid input script type"
|
_ -> error "Invalid input script type"
|
||||||
|
@ -1,58 +1,57 @@
|
|||||||
module Haskoin.UtilSpec (
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
spec,
|
|
||||||
customCerealID,
|
|
||||||
readTestFile,
|
|
||||||
) where
|
|
||||||
|
|
||||||
import Data.Aeson (FromJSON, ToJSON)
|
module Haskoin.UtilSpec (spec) where
|
||||||
import qualified Data.Aeson as A
|
|
||||||
|
import Data.Aeson
|
||||||
import Data.Aeson.Encoding (encodingToLazyByteString)
|
import Data.Aeson.Encoding (encodingToLazyByteString)
|
||||||
import Data.Aeson.Types (Parser, parseMaybe)
|
import Data.Aeson.Types (Parser, parse)
|
||||||
import qualified Data.ByteString as BS
|
import Data.ByteString (ByteString)
|
||||||
|
import Data.ByteString qualified as B
|
||||||
import Data.Either (fromLeft, fromRight, isLeft, isRight)
|
import Data.Either (fromLeft, fromRight, isLeft, isRight)
|
||||||
import Data.Foldable (toList)
|
import Data.Foldable (toList)
|
||||||
import Data.List (permutations)
|
import Data.List (permutations)
|
||||||
import Data.Map.Strict (singleton)
|
import Data.Map.Strict (singleton)
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import qualified Data.Sequence as Seq
|
import Data.Sequence qualified as Seq
|
||||||
import Data.Serialize as S
|
import Data.Serialize as S
|
||||||
|
import Haskoin.Crypto
|
||||||
import Haskoin.Util
|
import Haskoin.Util
|
||||||
import Haskoin.Util.Arbitrary
|
import Haskoin.Util.Arbitrary
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
import Test.Hspec.QuickCheck
|
import Test.Hspec.QuickCheck
|
||||||
import Test.QuickCheck
|
import Test.QuickCheck (forAll)
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec =
|
spec =
|
||||||
describe "utility functions" $ do
|
describe "utility functions" $ do
|
||||||
prop "bsToInteger . integerToBS" getPutInteger
|
prop "bsToInteger . integerToBS" getPutInteger
|
||||||
prop "decodeHex . encodeHex" $ forAll arbitraryBS fromToHex
|
prop "decodeHex . encodeHex" $ forAll arbitraryBS fromToHex
|
||||||
prop "compare updateIndex with Data.Sequence" testUpdateIndex
|
prop "compare updateIndex with Data.Sequence" testUpdateIndex
|
||||||
prop "matchTemplate" testMatchTemplate
|
prop "matchTemplate" testMatchTemplate
|
||||||
prop "testing matchTemplate with two lists" testMatchTemplateLen
|
prop "testing matchTemplate with two lists" testMatchTemplateLen
|
||||||
prop "test eitherToMaybe" testEitherToMaybe
|
prop "test eitherToMaybe" testEitherToMaybe
|
||||||
prop "test maybeToEither" testMaybeToEither
|
prop "test maybeToEither" testMaybeToEither
|
||||||
|
|
||||||
{- Various utilities -}
|
{- Various utilities -}
|
||||||
|
|
||||||
getPutInteger :: Integer -> Bool
|
getPutInteger :: Integer -> Bool
|
||||||
getPutInteger i = bsToInteger (integerToBS $ abs i) == abs i
|
getPutInteger i = bsToInteger (integerToBS $ abs i) == abs i
|
||||||
|
|
||||||
fromToHex :: BS.ByteString -> Bool
|
fromToHex :: ByteString -> Bool
|
||||||
fromToHex bs = decodeHex (encodeHex bs) == Just bs
|
fromToHex bs = decodeHex (encodeHex bs) == Just bs
|
||||||
|
|
||||||
testUpdateIndex :: [Int] -> Int -> Int -> Bool
|
testUpdateIndex :: [Int] -> Int -> Int -> Bool
|
||||||
testUpdateIndex xs v i =
|
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 :: [Int] -> Int -> Bool
|
||||||
testMatchTemplate as i = catMaybes res == bs
|
testMatchTemplate as i = catMaybes res == bs
|
||||||
where
|
where
|
||||||
res = matchTemplate as bs (==)
|
res = matchTemplate as bs (==)
|
||||||
idx =
|
idx =
|
||||||
if null as
|
if null as
|
||||||
then 0
|
then 0
|
||||||
else i `mod` length as
|
else i `mod` length as
|
||||||
bs = permutations as !! idx
|
bs = permutations as !! idx
|
||||||
|
|
||||||
testMatchTemplateLen :: [Int] -> [Int] -> Bool
|
testMatchTemplateLen :: [Int] -> [Int] -> Bool
|
||||||
@ -67,14 +66,3 @@ testEitherToMaybe e = isNothing (eitherToMaybe e)
|
|||||||
testMaybeToEither :: Maybe Int -> String -> Bool
|
testMaybeToEither :: Maybe Int -> String -> Bool
|
||||||
testMaybeToEither (Just v) str = maybeToEither str (Just v) == Right v
|
testMaybeToEither (Just v) str = maybeToEither str (Just v) == Right v
|
||||||
testMaybeToEither m str = maybeToEither str m == Left str
|
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