haskoin/haskoin-core
1
1
Fork 0
mirror of https://github.com/haskoin/haskoin-core.git synced 2024-08-16 21:41:22 +03:00
Code Issues Projects Releases Wiki Activity

Backwards-incompatible modernisation of package

Browse Source 
- 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:
JP Rupp 2023-07-28 19:48:43 +01:00
parent 64ceb860e1
commit 8fb472f60d
No known key found for this signature in database
GPG Key ID: 93391726EAFA0C5D
83 changed files with 15974 additions and 15777 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

261
CHANGELOG.md
View File

@ -1,289 +1,420 @@
# Changelog
All notable changes to this project will be documented in this file.
The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)
and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html).
## 0.21.2
## [1.0.0]
### Changed
- Shorten all field names allow duplicates, using DuplicateRecordFields extension.
- Use OverloadedRecordDot language extension and syntax.
- Use explicit context object from secp256k1-haskell library.
- Unify serialization into custom Marhsal and MarshalJSON classes.
- Use ormolu for formatting.
- Simplify module organisation.
- Strongly break backwards compatibility.
## [0.22.0] - 2023-06-28
### Changed
- Upgrade to lastest secp256k1 and base16 packages.
## [0.21.2] - 2022-04-13
### Changed
- Serialisation test now works for both strict and lazy bytestrings.
## 0.21.1
## [0.21.1] - 2021-12-13
### Changed
- Make Base58 faster.
## 0.21.0
## [0.21.0] - 2022-11-23
### Added
- BCH Testnet4 support.
### Changed
- Use a newtype for Fingerprint, which uses an 8 digit hex string for various
instances. This fixes inconsistent (de)serialization across the package.
- Fix inconsistent serialization/deserialization issues.
### Fixed
- Makes `finalScriptWitness` field encoding conform to bitcoin core.
- Fixes bug in `finalizeTransaction`
### Added
- Signing support for PSBTs
- Helper function for merging PSBTs
- More PSBT tests
- Partial support for taproot
## 0.20.5
## [0.20.5] - 2021-09-13
### Added
- Support Bech32m address format for Taproot.
## 0.20.4
## [0.20.4] - 2021-06-08
### Fixed
- Add missing case for witness version.
## 0.20.3
## [0.20.3] - 2021-05-17
### Fixed
- Allow unknown inv types.
## 0.20.2
## [0.20.2] - 2021-05-17
### Fixed
- Allow unknown messages of zero length.
## 0.20.1
## [0.20.1] - 2021-05-14
### Fixed
- Correct case where binary search returned the wrong element.
## 0.20.0
## [0.20.0] - 2021-02-22
### Chaged
- Use bytes instead of binary or cereal.
## 0.19.0
## [0.19.0] - 2021-01-25
### Added
- Hashable instances for extended keys.
### Changed
- Mnemonic passphrases now `Text` instead of `ByteString`.
### Fixed
- Tests now pass for witness addresses.
## 0.18.0
## [0.18.0] - 2020-12-10
### Added
- Support SegWit addresses with version other than 0.
## 0.17.6
## [0.17.6] - 2020-12-07
### Added
- Serialize instances for `XPubKey` and `XPrvKey`.
## 0.17.5
## [0.17.5] - 2020-12-03
### Fixed
- Handle special case in block header binary search function.
## 0.17.4
## [0.17.4] - 2020-12-03
### Fixed
- Bounds check too restrictive in block header binary search function.
## 0.17.3
## [0.17.3] - 2020-11-17
### Changed
- Reduce minimum version of text package dependency.
## 0.17.2
## [0.17.2] - 2020-11-17
### Changed
- Update lists of seeds for all networks.
## 0.17.1
### Changed
- Use the C-preprocessor to handle versions of `base16-bytestring` including 1.0
(with a breaking API change)
## [0.17.1] - 2020-11-02
### Changed
- Use the C-preprocessor to handle versions of `base16-bytestring`
## [0.17.0] - 2020-10-21
## 0.17.0
### Added
- Support for Bitcoin Cash November 2020 hard fork.
- Functions to find block headers matching arbitrary sorted attributes.
### Removed
- GenesisNode constructor for BlockNode type.
## 0.15.0
## [0.15.0] - 2020-07-23
### Added
- Add more test vectors
### Changed
- stringToAddr renamed to textToAddr
- Move ScriptOutput to Standard.hs
- Move WIF encoding/decoding to Keys.hs
- (breaking) rename `OP_NOP2` and `OP_NOP3` to `OP_CHECKLOCKTIMEVERIFY` and
`OP_CHECKSEQUENCEVERIFY` resp.
- (breaking) rename `OP_NOP2` and `OP_NOP3` to `OP_CHECKLOCKTIMEVERIFY` and `OP_CHECKSEQUENCEVERIFY` resp.
- Update to latest secp256k1 bindings.
## 0.14.1
## [0.14.1] - 2020-06-14
### Fixed
- Correct some Bitcoin Cash Testnet3 seeds.
- Add helpers for writing Data.Serialize and Data.Aeson identity tests
## 0.14.0
## [0.14.0] - 2020-06-14
### Changed
- Expose all modules for tests.
- Tests depend on library instead of having access to its source code.
- Use MIT license.
- Update seeds.
- Bump secp256k1-haskell dependency.
## 0.13.6
## [0.13.6] - 2020-06-05
### Changed
- Expose the Arbitrary test instances under Haskoin.Util.Arbitrary
## 0.13.5
## [0.13.5] - 2020-05-16
### Changed
- Provide meaningful JSON instances for most types.
## 0.13.4
## [0.13.4] - 2020-05-14
### Added
- Support for Bitcoin Cash May 2020 hard fork.
## 0.13.3
## [0.13.3] - 2020-05-08
### Changed
- Improve code and documentation organisation.
## 0.13.2
## [0.13.2] - 2020-05-08
### Changed
- Move all packages from Network.Haskoin namespace to Haskoin namespace.
- Expose all top-level modules directly.
## 0.13.1
## [0.13.1] - 2020-05-06
### Changed
- Faster JSON serialization.
## 0.13.0
## [0.13.0] - 2020-05-06
### Changed
- Consolidate all modules in Haskoin module.
### Removed
- Deprecate Network.Haskoin namespace.
- Hide QuickCheck generators in test suite.
## 0.12.0
### Added
- Support for signing segwit transactions.
## [0.12.0] - 2020-04-10
## 0.11.0
### Added
- Support for signing segwit transactions.
- High-level representation of segwit v0 data and auxilliary functions.
### Changed
- Adds handling of segwit signing parameters to transaction signing code.
## 0.10.1
## [0.10.1] - 2020-02-08
### Added
- Lower bound versions for some dependencies.
## 0.10.0
## [0.10.0] - 2020-01-15
### Added
- DeepSeq instances for all data types.
### Changed
- There is no `SockAddr` inside `NetworkAddress` anymore.
## 0.9.8
## [0.9.8] - 2020-01-01
### Added
- Ord instance for `DerivPathI`
## 0.9.7
## [0.9.7] - 2019-12-04
### Added
- JSON encoding/decoding for blocks.
### Fixed
- Fix lowercase HRP test for Bech32.
## 0.9.6
## [0.9.6] - 2019-10-29
### Added
- `bloomRelevantUpdate` implementation for Bloom filters (thanks to @IlyasRidhuan).
### Fixed
- Fix for Bech32 encoding (thanks to @pavel-main).
## 0.9.5
## [0.9.5] - 2019-10-23
### Added
- Expose functions added in 0.9.4.
## 0.9.4
## [0.9.4] - 2019-10-23
### Added
- Support for (P2SH-)P2WPKH addresses derived from extended keys.
### Changed
- Change names of backwards-compatible P2SH-P2WPKH functions from 0.9.3.
## 0.9.3
## [0.9.3] - 2019-10-22
### Added
- Some support for P2WPKH-over-P2SH addresses.
## 0.9.2
## [0.9.2] - 2019-10-09
### Removed
- Disable unnecessary `-O2` optimisation added in previous version.
### Added
- Allow decoding unknown P2P messages.
## 0.9.1
## [0.9.1] - 2019-10-02
### Added
- Add a function to produce a structured signature over a transaction.
- Enable `-O2` optimisations.
## 0.9.0
## [0.9.0] - 2019-04-12
### Changed
- Address conversion to string now defined for all inputs.
## 0.8.4
### Added
- Add reward computation to block functions.
- Add PSBT [BIP-174](https://github.com/bitcoin/bips/blob/master/bip-0174.mediawiki) types and functions
## [0.8.4] - 2018-12-05
## 0.8.3
### Added
- Add reward computation to block functions.
- Add PSBT BIP-174 types and functions.
## [0.8.3] - 2018-12-04
### Added
- Add reward halving interval parameter to network constants.
## 0.8.2
## [0.8.2] - 2018-11-06
### Added
- Recognize `OP_CHECKDATASIG` and `OP_CHECKDATASIGVERIFY` opcodes.
## 0.8.1
## [0.8.1] - 2018-10-13
### Added
- Add instances of `Hashable` and `Generic` where possible.
## 0.8.0
## [0.8.0] - 2018-10-13
### Removed
- Remove `deepseq` dependency.
- Remove network constant reference from address and extended keys.
## 0.7.0
## [0.7.0] - 2018-10-13
### Added
- Add `Serialize` instance for network constants.
- Add `Serialize` instance for addresses that includes network constants.
### Changed
- Move functions related to addresses from `Script` to `Address` module.
## 0.6.1
## [0.6.1] - 2018-10-09
### Added
- Compatibility with latest GHC and base.
### Changed
- Update minimum base to 4.9.
## 0.6.0
## [0.6.0] - 2018-10-08
### Changed
- Force initialization of addresses through smart constructor.
- Assume addresses are always valid when instantiated in code.
- Allow to provide unwrapped private keys to transaction signing functions.
## 0.5.2
## [0.5.2] - 2018-09-10
### Changed
- Make dependencies more specific.
## 0.5.1
## [0.5.1] - 2018-09-10
### Changed
- Remove some unneeded dependencies from `stack.yaml`.
- Change `secp256k1` dependency to `secp256k1-haskell`.
## 0.5.0
## [0.5.0] - 2018-09-09
### Added
- Support for Bitcoin Cash network block sychronization.
- Support for Bitcoin Cash signatures.
- Initial work on SegWit support.
@ -299,6 +430,7 @@ and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.
- Support for CashAddr addresses.
### Changed
- Use of hpack `package.yaml` file to auto-generate Cabal file.
- Removal of dependency version limits, relying on `stack.yaml` instead.
- Tests moved to `hspec`.
@ -309,6 +441,7 @@ and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.
- Target LTS Haskell 12.9.
### Removed
- Removed `.stylish-haskell.yaml` files.
- Removed old `haskoin-node` and `haskoin-wallet` packages from main repository.
- Removed support for non-strict signatures and related tests.

3
README.md
View File

@ -17,4 +17,5 @@ Haskoin Core is a library of Bitcoin and Bitcoin Cash functions written in Haske
## Contributing
Please use `ormolu` (or `fourmolu`) to format code prior to submission. See `scripts/pre-commit.sh` for an example pre-commit hook.
All code is formatted with [Ormolu](https://github.com/tweag/ormolu).
Convenience formatting script available at [scripts/format](scripts/format)

0
data/rfc6979DERabc.json → data/rfc6979DERcash.json
View File

0
data/rfc6979abc.json → data/rfc6979cash.json
View File

34
haskoin-core.cabal
View File

@ -1,11 +1,11 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.35.1.
-- This file has been generated from package.yaml by hpack version 0.35.2.
--
-- see: https://github.com/sol/hpack
name: haskoin-core
version: 0.22.0
version: 1.0.0
synopsis: Bitcoin & Bitcoin Cash library for Haskell
description: Please see the README on GitHub at <https://github.com/haskoin/haskoin-core#readme>
category: Bitcoin, Finance, Network
@ -25,9 +25,9 @@ extra-source-files:
data/forkid_sighash.json
data/key_io_invalid.json
data/key_io_valid.json
data/rfc6979abc.json
data/rfc6979cash.json
data/rfc6979core.json
data/rfc6979DERabc.json
data/rfc6979DERcash.json
data/rfc6979DERcore.json
data/script_tests.json
data/sig_nonstrict.json
@ -51,18 +51,18 @@ library
Haskoin.Block.Common
Haskoin.Block.Headers
Haskoin.Block.Merkle
Haskoin.Constants
Haskoin.Crypto
Haskoin.Crypto.Hash
Haskoin.Crypto.Keys
Haskoin.Crypto.Keys.Common
Haskoin.Crypto.Keys.Extended
Haskoin.Crypto.Keys.Mnemonic
Haskoin.Crypto.Signature
Haskoin.Data
Haskoin.Keys
Haskoin.Keys.Common
Haskoin.Keys.Extended
Haskoin.Keys.Mnemonic
Haskoin.Network
Haskoin.Network.Bloom
Haskoin.Network.Common
Haskoin.Network.Constants
Haskoin.Network.Data
Haskoin.Network.Message
Haskoin.Script
Haskoin.Script.Common
@ -87,8 +87,10 @@ library
Haskoin.Util.Arbitrary.Script
Haskoin.Util.Arbitrary.Transaction
Haskoin.Util.Arbitrary.Util
Haskoin.Util.Helpers
Haskoin.Util.Marshal
other-modules:
Haskoin.Keys.Extended.Internal
Haskoin.Crypto.Keys.Extended.Internal
hs-source-dirs:
src
build-depends:
@ -114,7 +116,7 @@ library
, network >=3.1.1.1
, safe >=0.3.18
, scientific >=0.3.6.2
, secp256k1-haskell >=0.7.0
, secp256k1-haskell >=1.0.0
, split >=0.2.3.3
, string-conversions >=0.4.0.1
, text >=1.2.3.0
@ -133,10 +135,10 @@ test-suite spec
Haskoin.AddressSpec
Haskoin.BlockSpec
Haskoin.Crypto.HashSpec
Haskoin.Crypto.Keys.ExtendedSpec
Haskoin.Crypto.Keys.MnemonicSpec
Haskoin.Crypto.KeysSpec
Haskoin.Crypto.SignatureSpec
Haskoin.Keys.ExtendedSpec
Haskoin.Keys.MnemonicSpec
Haskoin.KeysSpec
Haskoin.NetworkSpec
Haskoin.ScriptSpec
Haskoin.Transaction.PartialSpec
@ -174,7 +176,7 @@ test-suite spec
, network >=3.1.1.1
, safe >=0.3.18
, scientific >=0.3.6.2
, secp256k1-haskell >=0.7.0
, secp256k1-haskell >=1.0.0
, split >=0.2.3.3
, string-conversions >=0.4.0.1
, text >=1.2.3.0

6
hie.yaml Normal file
View File

@ -0,0 +1,6 @@
cradle:
stack:
- path: "./src"
component: haskoin-core:lib
- path: "./test"
component: haskoin-core:test:spec

6
package.yaml
View File

@ -1,5 +1,5 @@
name: haskoin-core
version: 0.22.0
version: 1.0.0
synopsis: Bitcoin & Bitcoin Cash library for Haskell
description: Please see the README on GitHub at <https://github.com/haskoin/haskoin-core#readme>
category: Bitcoin, Finance, Network
@ -41,7 +41,7 @@ dependencies:
- split >= 0.2.3.3
- safe >= 0.3.18
- scientific >= 0.3.6.2
- secp256k1-haskell >= 0.7.0
- secp256k1-haskell >= 1.0.0
- string-conversions >= 0.4.0.1
- text >= 1.2.3.0
- time >= 1.9.3
@ -51,7 +51,7 @@ dependencies:
library:
source-dirs: src
other-modules:
Haskoin.Keys.Extended.Internal
Haskoin.Crypto.Keys.Extended.Internal
when:
- condition: false
other-modules: Paths_haskoin_core

4
scripts/format
View File

@ -1,4 +1,4 @@
#!/usr/bin/env bash
find src -type f -name "*.hs" | xargs fourmolu -i
find test -type f -name "*.hs" | xargs fourmolu -i
find src -type f -name "*.hs" | xargs ormolu -i
find test -type f -name "*.hs" | xargs ormolu -i

36
src/Haskoin.hs
View File

@ -1,34 +1,28 @@
{- |
Module : Haskoin
Description : Bitcoin (BTC/BCH) Libraries for Haskell
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
This module exports almost all of Haskoin Core, excluding only a few highly
specialized address and block-related functions.
-}
module Haskoin (
module Data,
module Constants,
module Address,
-- |
-- Module : Haskoin
-- Description : Bitcoin (BTC/BCH) Libraries for Haskell
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- This module exports almost all of Haskoin Core, excluding only a few highly
-- specialized address and block-related functions.
module Haskoin
( module Address,
module Block,
module Transaction,
module Script,
module Keys,
module Crypto,
module Network,
module Util,
) where
)
where
import Haskoin.Address as Address
import Haskoin.Block as Block
import Haskoin.Constants as Constants
import Haskoin.Crypto as Crypto
import Haskoin.Data as Data
import Haskoin.Keys as Keys
import Haskoin.Network as Network
import Haskoin.Script as Script
import Haskoin.Transaction as Transaction

452
src/Haskoin/Address.hs
View File

@ -1,22 +1,26 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoFieldSelectors #-}
{- |
Module : Haskoin.Address
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
Base58, CashAddr, Bech32 address and WIF private key serialization support.
-}
module Haskoin.Address (
-- * Addresses
-- |
-- Module : Haskoin.Address
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- Base58, CashAddr, Bech32 address and WIF private key serialization support.
module Haskoin.Address
( -- * Addresses
Address (..),
isPubKeyAddress,
isScriptAddress,
@ -28,9 +32,6 @@ module Haskoin.Address (
bech32ToAddr,
cashToAddr,
base58ToAddr,
addrToJSON,
addrToEncoding,
addrFromJSON,
pubKeyAddr,
pubKeyWitnessAddr,
pubKeyCompatWitnessAddr,
@ -51,248 +52,241 @@ module Haskoin.Address (
module Haskoin.Address.Base58,
module Haskoin.Address.Bech32,
module Haskoin.Address.CashAddr,
) where
)
where
import Control.Applicative
import Control.Applicative (Alternative ((<|>)))
import Control.Arrow (second)
import Control.DeepSeq
import Control.Monad
import Data.Aeson as A
import Data.Aeson.Encoding as A
import Data.Aeson.Types
import Control.DeepSeq (NFData)
import Control.Monad ((<=<))
import Crypto.Secp256k1
import Data.Aeson (ToJSON (toJSON), Value, withText)
import Data.Aeson.Encoding (Encoding, null_, text)
import Data.Aeson.Types (Encoding, Parser, ToJSON (toJSON), Value, withText)
import Data.Binary (Binary (..))
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import Data.Hashable
import Data.Maybe
import Data.ByteString qualified as B
import Data.Bytes.Get (MonadGet (getByteString, getWord64be, getWord8), runGetS)
import Data.Bytes.Put (MonadPut (putByteString, putWord64be, putWord8), runPutS)
import Data.Bytes.Serial (Serial (..))
import Data.Hashable (Hashable)
import Data.Maybe (isNothing)
import Data.Serialize (Serialize (..))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text qualified as T
import Data.Word (Word8)
import GHC.Generics (Generic)
import Haskoin.Address.Base58
import Haskoin.Address.Bech32
import Haskoin.Address.CashAddr
import Haskoin.Crypto
import Haskoin.Data
import Haskoin.Keys.Common
import Haskoin.Script
import Haskoin.Crypto.Hash
import Haskoin.Crypto.Keys.Common
import Haskoin.Network.Data
import Haskoin.Script.Common
import Haskoin.Script.Standard
import Haskoin.Util
-- | Address format for Bitcoin and Bitcoin Cash.
data Address
= -- | pay to public key hash (regular)
PubKeyAddress
{ -- | RIPEMD160 hash of public key's SHA256 hash
getAddrHash160 :: !Hash160
}
| -- | pay to script hash
ScriptAddress
{ -- | RIPEMD160 hash of script's SHA256 hash
getAddrHash160 :: !Hash160
}
| -- | pay to witness public key hash
WitnessPubKeyAddress
{ -- | RIPEMD160 hash of public key's SHA256 hash
getAddrHash160 :: !Hash160
}
| -- | pay to witness script hash
WitnessScriptAddress
{ -- | HASH256 hash of script
getAddrHash256 :: !Hash256
}
| -- | other witness address
WitnessAddress
{ getAddrVersion :: !Word8
, getAddrData :: !ByteString
}
deriving
(Eq, Ord, Generic, Show, Read, Hashable, NFData)
= -- | pay to public key hash (regular)
PubKeyAddress
{ -- | RIPEMD160 hash of public key's SHA256 hash
hash160 :: !Hash160
}
| -- | pay to script hash
ScriptAddress
{ -- | RIPEMD160 hash of script's SHA256 hash
hash160 :: !Hash160
}
| -- | pay to witness public key hash
WitnessPubKeyAddress
{ -- | RIPEMD160 hash of public key's SHA256 hash
hash160 :: !Hash160
}
| -- | pay to witness script hash
WitnessScriptAddress
{ -- | HASH256 hash of script
hash256 :: !Hash256
}
| -- | other witness address
WitnessAddress
{ version :: !Word8,
bytes :: !ByteString
}
deriving
(Eq, Ord, Generic, Show, Read, Hashable, NFData)
instance Serial Address where
serialize (PubKeyAddress k) = do
putWord8 0x00
serialize k
serialize (ScriptAddress s) = do
putWord8 0x01
serialize s
serialize (WitnessPubKeyAddress h) = do
putWord8 0x02
serialize h
serialize (WitnessScriptAddress s) = do
putWord8 0x03
serialize s
serialize (WitnessAddress v d) = do
putWord8 0x04
putWord8 v
putWord64be (fromIntegral (B.length d))
putByteString d
serialize (PubKeyAddress k) = do
putWord8 0x00
serialize k
serialize (ScriptAddress s) = do
putWord8 0x01
serialize s
serialize (WitnessPubKeyAddress h) = do
putWord8 0x02
serialize h
serialize (WitnessScriptAddress s) = do
putWord8 0x03
serialize s
serialize (WitnessAddress v d) = do
putWord8 0x04
putWord8 v
putWord64be (fromIntegral (B.length d))
putByteString d
deserialize =
getWord8 >>= \case
0x00 -> PubKeyAddress <$> deserialize
0x01 -> ScriptAddress <$> deserialize
0x02 -> WitnessPubKeyAddress <$> deserialize
0x03 -> WitnessScriptAddress <$> deserialize
0x04 ->
WitnessAddress <$> getWord8
<*> (getByteString . fromIntegral =<< getWord64be)
b ->
fail . T.unpack $
"Could not decode address type byte: "
<> encodeHex (B.singleton b)
deserialize =
getWord8 >>= \case
0x00 -> PubKeyAddress <$> deserialize
0x01 -> ScriptAddress <$> deserialize
0x02 -> WitnessPubKeyAddress <$> deserialize
0x03 -> WitnessScriptAddress <$> deserialize
0x04 ->
WitnessAddress
<$> getWord8
<*> (getByteString . fromIntegral =<< getWord64be)
b ->
fail . T.unpack $
"Could not decode address type byte: "
<> encodeHex (B.singleton b)
instance Serialize Address where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance Binary Address where
put = serialize
get = deserialize
put = serialize
get = deserialize
-- | 'Address' pays to a public key hash.
isPubKeyAddress :: Address -> Bool
isPubKeyAddress PubKeyAddress{} = True
isPubKeyAddress PubKeyAddress {} = True
isPubKeyAddress _ = False
-- | 'Address' pays to a script hash.
isScriptAddress :: Address -> Bool
isScriptAddress ScriptAddress{} = True
isScriptAddress ScriptAddress {} = True
isScriptAddress _ = False
{- | 'Address' pays to a witness public key hash. Only valid for SegWit
networks.
-}
-- | 'Address' pays to a witness public key hash. Only valid for SegWit
-- networks.
isWitnessPubKeyAddress :: Address -> Bool
isWitnessPubKeyAddress WitnessPubKeyAddress{} = True
isWitnessPubKeyAddress WitnessPubKeyAddress {} = True
isWitnessPubKeyAddress _ = False
isWitnessScriptAddress :: Address -> Bool
isWitnessScriptAddress WitnessScriptAddress{} = True
isWitnessScriptAddress WitnessScriptAddress {} = True
isWitnessScriptAddress _ = False
isWitnessAddress :: Address -> Bool
isWitnessAddress WitnessAddress{} = True
isWitnessAddress WitnessAddress {} = True
isWitnessAddress _ = False
addrToJSON :: Network -> Address -> Value
addrToJSON net a = toJSON (addrToText net a)
addrToEncoding :: Network -> Address -> Encoding
addrToEncoding net = maybe null_ text . addrToText net
{- | JSON parsing for Bitcoin addresses. Works with 'Base58', 'CashAddr' and
'Bech32'.
-}
addrFromJSON :: Network -> Value -> Parser Address
addrFromJSON net =
instance MarshalJSON Network Address where
marshalValue net a = toJSON (addrToText net a)
marshalEncoding net = maybe null_ text . addrToText net
unmarshalValue net =
withText "address" $ \t ->
case textToAddr net t of
Nothing -> fail "could not decode address"
Just x -> return x
case textToAddr net t of
Nothing -> fail "could not decode address"
Just x -> return x
{- | Convert address to human-readable string. Uses 'Base58', 'Bech32', or
'CashAddr' depending on network.
-}
-- | Convert address to human-readable string. Uses 'Base58', 'Bech32', or
-- 'CashAddr' depending on network.
addrToText :: Network -> Address -> Maybe Text
addrToText net a@PubKeyAddress{getAddrHash160 = h}
| isNothing (getCashAddrPrefix net) =
Just . encodeBase58Check . runPutS $ base58put net a
| otherwise = cashAddrEncode net 0 (runPutS $ serialize h)
addrToText net a@ScriptAddress{getAddrHash160 = h}
| isNothing (getCashAddrPrefix net) =
Just . encodeBase58Check . runPutS $ base58put net a
| otherwise =
cashAddrEncode net 1 (runPutS $ serialize h)
addrToText net WitnessPubKeyAddress{getAddrHash160 = h} = do
hrp <- getBech32Prefix net
segwitEncode hrp 0 (B.unpack (runPutS $ serialize h))
addrToText net WitnessScriptAddress{getAddrHash256 = h} = do
hrp <- getBech32Prefix net
segwitEncode hrp 0 (B.unpack (runPutS $ serialize h))
addrToText net WitnessAddress{getAddrVersion = v, getAddrData = d} = do
hrp <- getBech32Prefix net
segwitEncode hrp v (B.unpack d)
addrToText net a@PubKeyAddress {hash160 = h}
| isNothing net.cashAddrPrefix =
Just . encodeBase58Check . runPutS $ base58put net a
| otherwise = cashAddrEncode net 0 (runPutS $ serialize h)
addrToText net a@ScriptAddress {hash160 = h}
| isNothing net.cashAddrPrefix =
Just . encodeBase58Check . runPutS $ base58put net a
| otherwise =
cashAddrEncode net 1 (runPutS $ serialize h)
addrToText net WitnessPubKeyAddress {hash160 = h} = do
hrp <- net.bech32Prefix
segwitEncode hrp 0 (B.unpack (runPutS $ serialize h))
addrToText net WitnessScriptAddress {hash256 = h} = do
hrp <- net.bech32Prefix
segwitEncode hrp 0 (B.unpack (runPutS $ serialize h))
addrToText net WitnessAddress {version = v, bytes = d} = do
hrp <- net.bech32Prefix
segwitEncode hrp v (B.unpack d)
-- | Parse 'Base58', 'Bech32' or 'CashAddr' address, depending on network.
textToAddr :: Network -> Text -> Maybe Address
textToAddr net txt =
cashToAddr net txt <|> bech32ToAddr net txt <|> base58ToAddr net txt
cashToAddr net txt <|> bech32ToAddr net txt <|> base58ToAddr net txt
cashToAddr :: Network -> Text -> Maybe Address
cashToAddr net txt = do
(ver, bs) <- cashAddrDecode net txt
case ver of
0 -> PubKeyAddress <$> eitherToMaybe (runGetS deserialize bs)
1 -> ScriptAddress <$> eitherToMaybe (runGetS deserialize bs)
_ -> Nothing
(ver, bs) <- cashAddrDecode net txt
case ver of
0 -> PubKeyAddress <$> eitherToMaybe (runGetS deserialize bs)
1 -> ScriptAddress <$> eitherToMaybe (runGetS deserialize bs)
_ -> Nothing
bech32ToAddr :: Network -> Text -> Maybe Address
bech32ToAddr net txt = do
hrp <- getBech32Prefix net
(ver, bs) <- second B.pack <$> segwitDecode hrp txt
case ver of
0 -> case B.length bs of
20 -> WitnessPubKeyAddress <$> eitherToMaybe (runGetS deserialize bs)
32 -> WitnessScriptAddress <$> eitherToMaybe (runGetS deserialize bs)
_ -> Nothing
_ -> Just $ WitnessAddress ver bs
hrp <- net.bech32Prefix
(ver, bs) <- second B.pack <$> segwitDecode hrp txt
case ver of
0 -> case B.length bs of
20 -> WitnessPubKeyAddress <$> eitherToMaybe (runGetS deserialize bs)
32 -> WitnessScriptAddress <$> eitherToMaybe (runGetS deserialize bs)
_ -> Nothing
_ -> Just $ WitnessAddress ver bs
base58ToAddr :: Network -> Text -> Maybe Address
base58ToAddr net txt =
eitherToMaybe . runGetS (base58get net) =<< decodeBase58Check txt
eitherToMaybe . runGetS (base58get net) =<< decodeBase58Check txt
base58get :: MonadGet m => Network -> m Address
base58get :: (MonadGet m) => Network -> m Address
base58get net = do
pfx <- getWord8
addr <- deserialize
f pfx addr
pfx <- getWord8
addr <- deserialize
f pfx addr
where
f x a
| x == getAddrPrefix net = return $ PubKeyAddress a
| x == getScriptPrefix net = return $ ScriptAddress a
| otherwise = fail "Does not recognize address prefix"
| x == net.addrPrefix = return $ PubKeyAddress a
| x == net.scriptPrefix = return $ ScriptAddress a
| otherwise = fail "Does not recognize address prefix"
base58put :: MonadPut m => Network -> Address -> m ()
base58put :: (MonadPut m) => Network -> Address -> m ()
base58put net (PubKeyAddress h) = do
putWord8 (getAddrPrefix net)
serialize h
putWord8 net.addrPrefix
serialize h
base58put net (ScriptAddress h) = do
putWord8 (getScriptPrefix net)
serialize h
putWord8 net.scriptPrefix
serialize h
base58put _ _ = error "Cannot serialize this address as Base58"
-- | Obtain a standard pay-to-public-key-hash address from a public key.
pubKeyAddr :: PubKeyI -> Address
pubKeyAddr = PubKeyAddress . addressHash . runPutS . serialize
pubKeyAddr :: Ctx -> PublicKey -> Address
pubKeyAddr ctx = PubKeyAddress . addressHash . marshal ctx
-- | Obtain a standard pay-to-public-key-hash (P2PKH) address from a 'Hash160'.
p2pkhAddr :: Hash160 -> Address
p2pkhAddr = PubKeyAddress
{- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a
public key.
-}
pubKeyWitnessAddr :: PubKeyI -> Address
pubKeyWitnessAddr = WitnessPubKeyAddress . addressHash . runPutS . serialize
-- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a
-- public key.
pubKeyWitnessAddr :: Ctx -> PublicKey -> Address
pubKeyWitnessAddr ctx =
WitnessPubKeyAddress . addressHash . marshal ctx
-- | Obtain a backwards-compatible SegWit P2SH-P2WPKH address from a public key.
pubKeyCompatWitnessAddr :: PubKeyI -> Address
pubKeyCompatWitnessAddr =
p2shAddr
. addressHash
. encodeOutputBS
. PayWitnessPKHash
. addressHash
. runPutS
. serialize
pubKeyCompatWitnessAddr :: Ctx -> PublicKey -> Address
pubKeyCompatWitnessAddr ctx =
p2shAddr
. addressHash
. marshal ctx
. PayWitnessPKHash
. addressHash
. marshal ctx
{- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a
'Hash160'.
-}
-- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a
-- 'Hash160'.
p2wpkhAddr :: Hash160 -> Address
p2wpkhAddr = WitnessPubKeyAddress
@ -305,66 +299,68 @@ p2wshAddr :: Hash256 -> Address
p2wshAddr = WitnessScriptAddress
-- | Compute a standard pay-to-script-hash (P2SH) address for an output script.
payToScriptAddress :: ScriptOutput -> Address
payToScriptAddress = p2shAddr . addressHash . encodeOutputBS
payToScriptAddress :: Ctx -> ScriptOutput -> Address
payToScriptAddress ctx = p2shAddr . addressHash . marshal ctx
{- | Compute a SegWit pay-to-witness-script-hash (P2WSH) address for an output
script.
-}
payToWitnessScriptAddress :: ScriptOutput -> Address
payToWitnessScriptAddress = p2wshAddr . sha256 . encodeOutputBS
-- | Compute a SegWit pay-to-witness-script-hash (P2WSH) address for an output
-- script.
payToWitnessScriptAddress :: Ctx -> ScriptOutput -> Address
payToWitnessScriptAddress ctx = p2wshAddr . sha256 . marshal ctx
-- | Compute a backwards-compatible SegWit P2SH-P2WSH address.
payToNestedScriptAddress :: ScriptOutput -> Address
payToNestedScriptAddress =
p2shAddr . addressHash . encodeOutputBS . toP2WSH . encodeOutput
payToNestedScriptAddress :: Ctx -> ScriptOutput -> Address
payToNestedScriptAddress ctx =
p2shAddr . addressHash . marshal ctx . toP2WSH . encodeOutput ctx
{- | Encode an output script from an address. Will fail if using a
pay-to-witness address on a non-SegWit network.
-}
-- | Encode an output script from an address. Will fail if using a
-- pay-to-witness address on a non-SegWit network.
addressToOutput :: Address -> ScriptOutput
addressToOutput =
\case
PubKeyAddress h -> PayPKHash h
ScriptAddress h -> PayScriptHash h
WitnessPubKeyAddress h -> PayWitnessPKHash h
WitnessScriptAddress h -> PayWitnessScriptHash h
WitnessAddress v d -> PayWitness v d
\case
PubKeyAddress h -> PayPKHash h
ScriptAddress h -> PayScriptHash h
WitnessPubKeyAddress h -> PayWitnessPKHash h
WitnessScriptAddress h -> PayWitnessScriptHash h
WitnessAddress v d -> PayWitness v d
-- | Get output script AST for an 'Address'.
addressToScript :: Address -> Script
addressToScript = encodeOutput . addressToOutput
addressToScript :: Ctx -> Address -> Script
addressToScript ctx = encodeOutput ctx . addressToOutput
-- | Encode address as output script in 'ByteString' form.
addressToScriptBS :: Address -> ByteString
addressToScriptBS = runPutS . serialize . addressToScript
addressToScriptBS :: Ctx -> Address -> ByteString
addressToScriptBS ctx = runPutS . serialize . addressToScript ctx
-- | Decode an output script into an 'Address' if it has such representation.
scriptToAddress :: Script -> Either String Address
scriptToAddress =
maybeToEither "Could not decode address" . outputAddress <=< decodeOutput
scriptToAddress :: Ctx -> Script -> Either String Address
scriptToAddress ctx =
maybeToEither e . outputAddress ctx <=< decodeOutput ctx
where
e = "Could not decode address"
-- | Decode a serialized script into an 'Address'.
scriptToAddressBS :: ByteString -> Either String Address
scriptToAddressBS =
maybeToEither "Could not decode address" . outputAddress <=< decodeOutputBS
scriptToAddressBS :: Ctx -> ByteString -> Either String Address
scriptToAddressBS ctx =
maybeToEither e . outputAddress ctx <=< unmarshal ctx
where
e = "Could not decode address"
-- | Get the 'Address' of a 'ScriptOutput'.
outputAddress :: ScriptOutput -> Maybe Address
outputAddress =
\case
PayPKHash h -> Just $ PubKeyAddress h
PayScriptHash h -> Just $ ScriptAddress h
PayPK k -> Just $ pubKeyAddr k
PayWitnessPKHash h -> Just $ WitnessPubKeyAddress h
PayWitnessScriptHash h -> Just $ WitnessScriptAddress h
PayWitness v d -> Just $ WitnessAddress v d
_ -> Nothing
outputAddress :: Ctx -> ScriptOutput -> Maybe Address
outputAddress ctx =
\case
PayPKHash h -> Just $ PubKeyAddress h
PayScriptHash h -> Just $ ScriptAddress h
PayPK k -> Just $ pubKeyAddr ctx k
PayWitnessPKHash h -> Just $ WitnessPubKeyAddress h
PayWitnessScriptHash h -> Just $ WitnessScriptAddress h
PayWitness v d -> Just $ WitnessAddress v d
_ -> Nothing
-- | Infer the 'Address' of a 'ScriptInput'.
inputAddress :: ScriptInput -> Maybe Address
inputAddress =
\case
(RegularInput (SpendPKHash _ key)) -> Just $ pubKeyAddr key
(ScriptHashInput _ rdm) -> Just $ payToScriptAddress rdm
_ -> Nothing
inputAddress :: Ctx -> ScriptInput -> Maybe Address
inputAddress ctx =
\case
(RegularInput (SpendPKHash _ key)) -> Just $ pubKeyAddr ctx key
(ScriptHashInput _ rdm) -> Just $ payToScriptAddress ctx rdm
_ -> Nothing

125
src/Haskoin/Address/Base58.hs
View File

@ -1,41 +1,43 @@
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoFieldSelectors #-}
{- |
Module : Haskoin.Address.Base58
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
Support for legacy 'Base58' addresses. Superseded by Bech32 for Bitcoin SegWit
(BTC) and CashAddr for Bitcoin Cash (BCH).
-}
module Haskoin.Address.Base58 (
-- * Base58
-- |
-- Module : Haskoin.Address.Base58
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- Support for legacy 'Base58' addresses. Superseded by Bech32 for Bitcoin SegWit
-- (BTC) and CashAddr for Bitcoin Cash (BCH).
module Haskoin.Address.Base58
( -- * Base58
Base58,
encodeBase58,
decodeBase58,
encodeBase58Check,
decodeBase58Check,
) where
)
where
import Control.Monad
import Data.Array
import Control.Monad (guard)
import Data.Array (Array, assocs, listArray, (!), (//))
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import Data.Char
import Data.ByteString qualified as B
import Data.ByteString.Char8 qualified as C
import Data.Bytes.Get ()
import Data.Bytes.Put (runPutS)
import Data.Bytes.Serial (Serial (serialize))
import Data.Char (chr, ord)
import Data.Maybe (fromMaybe, isJust, listToMaybe)
import Data.String.Conversions (cs)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Word
import Haskoin.Crypto.Hash
import Haskoin.Util
import Data.Text qualified as T
import Data.Word (Word8)
import Haskoin.Crypto.Hash (checkSum32)
import Haskoin.Util.Helpers (bsToInteger, integerToBS)
import Numeric (readInt, showIntAtBase)
-- | 'Base58' classic Bitcoin address format.
@ -46,16 +48,19 @@ b58Data :: ByteString
b58Data = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
b58Array :: Array Int Word8
b58Array = listArray (0, 57) (BS.unpack b58Data)
b58Array = listArray (0, 57) (B.unpack b58Data)
b58InvArray :: Array Word8 (Maybe Int)
b58InvArray = listArray (minBound, maxBound) (repeat Nothing) // map swap (assocs b58Array)
b58InvArray =
listArray
(minBound, maxBound)
(repeat Nothing)
// map swap (assocs b58Array)
where
swap (i, c) = (c, Just i)
{- | Convert a number less than or equal to provided integer into a 'Base58'
character.
-}
-- | Convert a number less than or equal to provided integer into a 'Base58'
-- character.
b58 :: Int -> Word8
b58 = (b58Array !)
@ -63,62 +68,58 @@ b58 = (b58Array !)
b58' :: Word8 -> Maybe Int
b58' = (b58InvArray !)
{- | Encode an arbitrary-length 'Integer' into a 'Base58' string. Leading zeroes
will not be part of the resulting string.
-}
-- | Encode an arbitrary-length 'Integer' into a 'Base58' string. Leading zeroes
-- will not be part of the resulting string.
encodeBase58I :: Integer -> Base58
encodeBase58I i = cs $ showIntAtBase 58 (chr . fromIntegral . b58) i ""
-- | Decode a 'Base58' string into an arbitrary-length 'Integer'.
decodeBase58I :: Base58 -> Maybe Integer
decodeBase58I s =
case go of
Just (r, []) -> Just r
_ -> Nothing
case go of
Just (r, []) -> Just r
_ -> Nothing
where
p = isJust . b58' . fromIntegral . ord
f = fromMaybe e . b58' . fromIntegral . ord
go = listToMaybe $ readInt 58 p f (cs s)
e = error "Could not decode base58"
{- | Encode an arbitrary 'ByteString' into a its 'Base58' representation,
preserving leading zeroes.
-}
-- | Encode an arbitrary 'ByteString' into a its 'Base58' representation,
-- preserving leading zeroes.
encodeBase58 :: ByteString -> Base58
encodeBase58 bs =
l <> r
l <> r
where
(z, b) = BS.span (== 0) bs
l = cs $ BS.replicate (BS.length z) (b58 0) -- preserve leading 0's
(z, b) = B.span (== 0) bs
l = cs $ B.replicate (B.length z) (b58 0) -- preserve leading 0's
r
| BS.null b = T.empty
| otherwise = encodeBase58I $ bsToInteger b
| B.null b = T.empty
| otherwise = encodeBase58I $ bsToInteger b
-- | Decode a 'Base58'-encoded 'Text' to a 'ByteString'.
decodeBase58 :: Base58 -> Maybe ByteString
decodeBase58 t =
BS.append prefix <$> r
B.append prefix <$> r
where
(z, b) = BS.span (== b58 0) (cs t)
prefix = BS.replicate (BS.length z) 0 -- preserve leading 1's
(z, b) = B.span (== b58 0) (cs t)
prefix = B.replicate (B.length z) 0 -- preserve leading 1's
r
| BS.null b = Just BS.empty
| otherwise = integerToBS <$> decodeBase58I (cs b)
| B.null b = Just B.empty
| otherwise = integerToBS <$> decodeBase58I (cs b)
{- | Computes a checksum for the input 'ByteString' and encodes the input and
the checksum as 'Base58'.
-}
-- | Computes a checksum for the input 'ByteString' and encodes the input and
-- the checksum as 'Base58'.
encodeBase58Check :: ByteString -> Base58
encodeBase58Check bs =
encodeBase58 $ BS.append bs $ runPutS $ serialize $ checkSum32 bs
(encodeBase58 . B.append bs . runPutS . serialize . checkSum32) bs
{- | Decode a 'Base58'-encoded string that contains a checksum. This function
returns 'Nothing' if the input string contains invalid 'Base58' characters or
if the checksum fails.
-}
-- | Decode a 'Base58'-encoded string that contains a checksum. This function
-- returns 'Nothing' if the input string contains invalid 'Base58' characters or
-- if the checksum fails.
decodeBase58Check :: Base58 -> Maybe ByteString
decodeBase58Check bs = do
rs <- decodeBase58 bs
let (res, chk) = BS.splitAt (BS.length rs - 4) rs
guard $ chk == runPutS (serialize (checkSum32 res))
return res
rs <- decodeBase58 bs
let (res, chk) = B.splitAt (B.length rs - 4) rs
guard $ chk == (runPutS . serialize . checkSum32) res
return res

199
src/Haskoin/Address/Bech32.hs
View File

@ -1,19 +1,20 @@
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoFieldSelectors #-}
{- |
Module : Haskoin.Address.Base58
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
Support for Bitcoin SegWit (BTC) Bech32 addresses. This module is a modified
version of Marko Bencun's reference implementation.
-}
module Haskoin.Address.Bech32 (
-- * Bech32
-- |
-- Module : Haskoin.Address.Base58
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- Support for Bitcoin SegWit (BTC) Bech32 addresses. This module is a modified
-- version of Marko Bencun's reference implementation.
module Haskoin.Address.Bech32
( -- * Bech32
HRP,
Bech32,
Bech32Encoding (..),
@ -28,38 +29,39 @@ module Haskoin.Address.Bech32 (
Word5 (..),
word5,
fromWord5,
) where
)
where
import Control.Monad (guard)
import Data.Array (
Array,
import Data.Array
( Array,
assocs,
bounds,
listArray,
(!),
(//),
)
import Data.Bits (
Bits,
)
import Data.Bits
( Bits,
testBit,
unsafeShiftL,
unsafeShiftR,
xor,
(.&.),
(.|.),
)
import qualified Data.ByteString as B
)
import Data.ByteString qualified as B
import Data.Char (toUpper)
import Data.Foldable (foldl')
import Data.Functor.Identity (Identity, runIdentity)
import Data.Ix (Ix (..))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Data.Text qualified as T
import Data.Text.Encoding qualified as E
import Data.Word (Word8)
data Bech32Encoding = Bech32 | Bech32m
deriving (Eq, Show, Ord, Enum)
deriving (Eq, Show, Ord, Enum)
-- | Bech32 human-readable string.
type Bech32 = Text
@ -70,28 +72,28 @@ type HRP = Text
-- | Data part of 'Bech32' address.
type Data = [Word8]
(.>>.), (.<<.) :: Bits a => a -> Int -> a
(.>>.), (.<<.) :: (Bits a) => a -> Int -> a
(.>>.) = unsafeShiftR
(.<<.) = unsafeShiftL
-- | Five-bit word for Bech32.
newtype Word5
= UnsafeWord5 Word8
deriving (Eq, Ord)
= UnsafeWord5 Word8
deriving (Eq, Ord)
instance Ix Word5 where
range (UnsafeWord5 m, UnsafeWord5 n) = map UnsafeWord5 $ range (m, n)
index (UnsafeWord5 m, UnsafeWord5 n) (UnsafeWord5 i) = index (m, n) i
inRange (m, n) i = m <= i && i <= n
range (UnsafeWord5 m, UnsafeWord5 n) = map UnsafeWord5 $ range (m, n)
index (UnsafeWord5 m, UnsafeWord5 n) (UnsafeWord5 i) = index (m, n) i
inRange (m, n) i = m <= i && i <= n
-- | Convert an integer number into a five-bit word.
word5 :: Integral a => a -> Word5
word5 :: (Integral a) => a -> Word5
word5 x = UnsafeWord5 (fromIntegral x .&. 31)
{-# INLINE word5 #-}
{-# SPECIALIZE INLINE word5 :: Word8 -> Word5 #-}
-- | Convert a five-bit word into a number.
fromWord5 :: Num a => Word5 -> a
fromWord5 :: (Num a) => Word5 -> a
fromWord5 (UnsafeWord5 x) = fromIntegral x
{-# INLINE fromWord5 #-}
{-# SPECIALIZE INLINE fromWord5 :: Word5 -> Word8 #-}
@ -99,13 +101,13 @@ fromWord5 (UnsafeWord5 x) = fromIntegral x
-- | 'Bech32' character map as array of five-bit integers to character.
charset :: Array Word5 Char
charset =
listArray (UnsafeWord5 0, UnsafeWord5 31) "qpzry9x8gf2tvdw0s3jn54khce6mua7l"
listArray (UnsafeWord5 0, UnsafeWord5 31) "qpzry9x8gf2tvdw0s3jn54khce6mua7l"
-- | Convert a character to its five-bit value from 'Bech32' 'charset'.
charsetMap :: Char -> Maybe Word5
charsetMap c
| inRange (bounds inv) upperC = inv ! upperC
| otherwise = Nothing
| inRange (bounds inv) upperC = inv ! upperC
| otherwise = Nothing
where
upperC = toUpper c
inv = listArray ('0', 'Z') (repeat Nothing) // map swap (assocs charset)
@ -116,19 +118,18 @@ bech32Polymod :: [Word5] -> Word
bech32Polymod values = foldl' go 1 values .&. 0x3fffffff
where
go chk value =
foldl' xor chk' [g | (g, i) <- zip generator [25 ..], testBit chk i]
foldl' xor chk' [g | (g, i) <- zip generator [25 ..], testBit chk i]
where
generator = [0x3b6a57b2, 0x26508e6d, 0x1ea119fa, 0x3d4233dd, 0x2a1462b3]
chk' = chk .<<. 5 `xor` fromWord5 value
{- | Convert human-readable part of 'Bech32' string into a list of five-bit
words.
-}
-- | Convert human-readable part of 'Bech32' string into a list of five-bit
-- words.
bech32HRPExpand :: HRP -> [Word5]
bech32HRPExpand hrp =
map (UnsafeWord5 . (.>>. 5)) hrpBytes
++ [UnsafeWord5 0]
++ map word5 hrpBytes
map (UnsafeWord5 . (.>>. 5)) hrpBytes
++ [UnsafeWord5 0]
++ map word5 hrpBytes
where
hrpBytes = B.unpack $ E.encodeUtf8 hrp
@ -147,49 +148,47 @@ bech32CreateChecksum enc hrp dat = [word5 (polymod .>>. i) | i <- [25, 20 .. 0]]
-- | Verify Bech32 checksum for a human-readable part and string of five-bit words.
bech32VerifyChecksum :: HRP -> [Word5] -> Maybe Bech32Encoding
bech32VerifyChecksum hrp dat =
let poly = bech32Polymod (bech32HRPExpand hrp ++ dat)
in if
| poly == bech32Const Bech32 -> Just Bech32
| poly == bech32Const Bech32m -> Just Bech32m
| otherwise -> Nothing
let poly = bech32Polymod (bech32HRPExpand hrp ++ dat)
in if
| poly == bech32Const Bech32 -> Just Bech32
| poly == bech32Const Bech32m -> Just Bech32m
| otherwise -> Nothing
-- | Maximum length of a Bech32 result.
maxBech32Length :: Int
maxBech32Length = 90
{- | Encode string of five-bit words into 'Bech32' using a provided
human-readable part. Can fail if 'HRP' is invalid or result would be longer
than 90 characters.
-}
-- | Encode string of five-bit words into 'Bech32' using a provided
-- human-readable part. Can fail if 'HRP' is invalid or result would be longer
-- than 90 characters.
bech32Encode :: Bech32Encoding -> HRP -> [Word5] -> Maybe Bech32
bech32Encode enc hrp dat = do
guard $ checkHRP hrp
let dat' = dat ++ bech32CreateChecksum enc (T.toLower hrp) dat
rest = map (charset !) dat'
result = T.concat [T.toLower hrp, T.pack "1", T.pack rest]
guard $ T.length result <= maxBech32Length
return result
guard $ checkHRP hrp
let dat' = dat ++ bech32CreateChecksum enc (T.toLower hrp) dat
rest = map (charset !) dat'
result = T.concat [T.toLower hrp, T.pack "1", T.pack rest]
guard $ T.length result <= maxBech32Length
return result
-- | Check that human-readable part is valid for a 'Bech32' string.
checkHRP :: HRP -> Bool
checkHRP hrp =
not (T.null hrp)
&& T.all (\char -> char >= '\x21' && char <= '\x7e') hrp
not (T.null hrp)
&& T.all (\char -> char >= '\x21' && char <= '\x7e') hrp
{- | Decode human-readable 'Bech32' string into a human-readable part and a
string of five-bit words.
-}
-- | Decode human-readable 'Bech32' string into a human-readable part and a
-- string of five-bit words.
bech32Decode :: Bech32 -> Maybe (Bech32Encoding, HRP, [Word5])
bech32Decode bech32 = do
guard $ T.length bech32 <= maxBech32Length
guard $ T.toUpper bech32 == bech32 || lowerBech32 == bech32
let (hrp, dat) = T.breakOnEnd "1" lowerBech32
guard $ T.length dat >= 6
hrp' <- T.stripSuffix "1" hrp
guard $ checkHRP hrp'
dat' <- mapM charsetMap $ T.unpack dat
enc <- bech32VerifyChecksum hrp' dat'
return (enc, hrp', take (T.length dat - 6) dat')
guard $ T.length bech32 <= maxBech32Length
guard $ T.toUpper bech32 == bech32 || lowerBech32 == bech32
let (hrp, dat) = T.breakOnEnd "1" lowerBech32
guard $ T.length dat >= 6
hrp' <- T.stripSuffix "1" hrp
guard $ checkHRP hrp'
dat' <- mapM charsetMap $ T.unpack dat
enc <- bech32VerifyChecksum hrp' dat'
return (enc, hrp', take (T.length dat - 6) dat')
where
lowerBech32 = T.toLower bech32
@ -202,67 +201,65 @@ yesPadding _ _ padValue result = return $ [padValue] : result
noPadding :: Pad Maybe
noPadding frombits bits padValue result = do
guard $ bits < frombits && padValue == 0
return result
guard $ bits < frombits && padValue == 0
return result
{-# INLINE noPadding #-}
{- | Big endian conversion of a bytestring from base \(2^{frombits}\) to base
\(2^{tobits}\). {frombits} and {twobits} must be positive and
\(2^{frombits}\) and \(2^{tobits}\) must be smaller than the size of Word.
Every value in 'dat' must be strictly smaller than \(2^{frombits}\).
-}
convertBits :: Functor f => [Word] -> Int -> Int -> Pad f -> f [Word]
-- | Big endian conversion of a bytestring from base \(2^{frombits}\) to base
-- \(2^{tobits}\). {frombits} and {twobits} must be positive and
-- \(2^{frombits}\) and \(2^{tobits}\) must be smaller than the size of Word.
-- Every value in 'dat' must be strictly smaller than \(2^{frombits}\).
convertBits :: (Functor f) => [Word] -> Int -> Int -> Pad f -> f [Word]
convertBits dat frombits tobits pad = concat . reverse <$> go dat 0 0 []
where
go [] acc bits result =
let padValue = (acc .<<. (tobits - bits)) .&. maxv
in pad frombits bits padValue result
let padValue = (acc .<<. (tobits - bits)) .&. maxv
in pad frombits bits padValue result
go (value : dat') acc bits result =
go dat' acc' (bits' `rem` tobits) (result' : result)
go dat' acc' (bits' `rem` tobits) (result' : result)
where
acc' = (acc .<<. frombits) .|. fromIntegral value
bits' = bits + frombits
result' =
[ (acc' .>>. b) .&. maxv
[ (acc' .>>. b) .&. maxv
| b <- [bits' - tobits, bits' - 2 * tobits .. 0]
]
]
maxv = (1 .<<. tobits) - 1
{-# INLINE convertBits #-}
-- | Convert from eight-bit to five-bit word string, adding padding as required.
toBase32 :: [Word8] -> [Word5]
toBase32 dat =
map word5 $ runIdentity $ convertBits (map fromIntegral dat) 8 5 yesPadding
map word5 $ runIdentity $ convertBits (map fromIntegral dat) 8 5 yesPadding
-- | Convert from five-bit word string to eight-bit word string, ignoring padding.
toBase256 :: [Word5] -> Maybe [Word8]
toBase256 dat =
map fromIntegral <$> convertBits (map fromWord5 dat) 5 8 noPadding
map fromIntegral <$> convertBits (map fromWord5 dat) 5 8 noPadding
-- | Check if witness version and program are valid.
segwitCheck :: Bech32Encoding -> Word8 -> Data -> Bool
segwitCheck enc witver witprog =
witver <= 16
&& if witver == 0
then enc == Bech32 && (length witprog == 20 || length witprog == 32)
else enc == Bech32m && (length witprog >= 2 && length witprog <= 40)
witver <= 16
&& if witver == 0
then enc == Bech32 && (length witprog == 20 || length witprog == 32)
else enc == Bech32m && (length witprog >= 2 && length witprog <= 40)
-- | Decode SegWit 'Bech32' address from a string and expected human-readable part.
segwitDecode :: HRP -> Bech32 -> Maybe (Word8, Data)
segwitDecode hrp addr = do
(enc, hrp', dat) <- bech32Decode addr
guard $ (hrp == hrp') && not (null dat)
let (UnsafeWord5 witver : datBase32) = dat
decoded <- toBase256 datBase32
guard $ segwitCheck enc witver decoded
return (witver, decoded)
(enc, hrp', dat) <- bech32Decode addr
guard $ (hrp == hrp') && not (null dat)
let (UnsafeWord5 witver : datBase32) = dat
decoded <- toBase256 datBase32
guard $ segwitCheck enc witver decoded
return (witver, decoded)
{- | Encode 'Data' as a SegWit 'Bech32' address. Needs human-readable part and
witness program version.
-}
-- | Encode 'Data' as a SegWit 'Bech32' address. Needs human-readable part and
-- witness program version.
segwitEncode :: HRP -> Word8 -> Data -> Maybe Text
segwitEncode hrp witver witprog = do
guard $ segwitCheck enc witver witprog
bech32Encode enc hrp $ UnsafeWord5 witver : toBase32 witprog
guard $ segwitCheck enc witver witprog
bech32Encode enc hrp $ UnsafeWord5 witver : toBase32 witprog
where
enc = if witver == 0 then Bech32 else Bech32m

270
src/Haskoin/Address/CashAddr.hs
View File

@ -1,17 +1,20 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoFieldSelectors #-}
{- |
Module : Haskoin.Address.CashAddr
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
Support for Bitcoin Cash (BCH) CashAddr format.
-}
module Haskoin.Address.CashAddr (
-- * CashAddr
-- |
-- Module : Haskoin.Address.CashAddr
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- Support for Bitcoin Cash (BCH) CashAddr format.
module Haskoin.Address.CashAddr
( -- * CashAddr
CashPrefix,
CashVersion,
CashAddr,
@ -22,26 +25,35 @@ module Haskoin.Address.CashAddr (
cash32encodeType,
cash32decode,
cash32encode,
) where
)
where
import Control.Monad
import Control.Monad (guard)
import Data.Bits
( Bits
( shiftL,
shiftR,
testBit,
xor,
(.&.),
(.|.)
),
)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C
import Data.Char
import Data.List
import Data.ByteString qualified as B
import Data.ByteString.Char8 qualified as C
import Data.Char (ord, toLower, toUpper)
import Data.List (elemIndex, foldl')
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Data.Word
import Haskoin.Data
import Haskoin.Util
import Data.Text qualified as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Word (Word64, Word8)
import Haskoin.Network.Data (Network (cashAddrPrefix))
import Haskoin.Util.Helpers (convertBits)
{- | 'CashAddr' prefix, usually shown before the colon in addresses, but sometimes
omitted. It is used in the checksum calculation to avoid parsing an address
from the wrong network.
-}
-- | 'CashAddr' prefix, usually shown before the colon in addresses, but sometimes
-- omitted. It is used in the checksum calculation to avoid parsing an address
-- from the wrong network.
type CashPrefix = Text
-- | 'CashAddr' version, until new address schemes appear it will be zero.
@ -50,9 +62,8 @@ type CashVersion = Word8
-- | High level 'CashAddr' human-reabale string, with explicit or implicit prefix.
type CashAddr = Text
{- | Low level 'Cash32' is the human-readable low-level encoding used by 'CashAddr'. It
need not encode a valid address but any binary data.
-}
-- | Low level 'Cash32' is the human-readable low-level encoding used by 'CashAddr'.
-- It need not encode a valid address but any binary data.
type Cash32 = Text
-- | Symbols for encoding 'Cash32' data in human-readable strings.
@ -63,156 +74,147 @@ charset = "qpzry9x8gf2tvdw0s3jn54khce6mua7l"
base32char :: Char -> Maybe Word8
base32char = fmap fromIntegral . (`elemIndex` charset)
{- | High-Level: decode 'CashAddr' string if it is valid for the
provided 'Network'. Prefix may be omitted from the string.
-}
-- | High-Level: decode 'CashAddr' string if it is valid for the
-- provided 'Network'. Prefix may be omitted from the string.
cashAddrDecode :: Network -> CashAddr -> Maybe (CashVersion, ByteString)
cashAddrDecode net ca = do
epfx <- getCashAddrPrefix net
let (cpfx, cdat) = T.breakOnEnd ":" (T.toLower ca)
guard (T.null cpfx || T.init cpfx == epfx)
(dpfx, ver, bs) <- cash32decodeType (epfx <> ":" <> cdat)
guard (dpfx == epfx)
return (ver, bs)
epfx <- net.cashAddrPrefix
let (cpfx, cdat) = T.breakOnEnd ":" (T.toLower ca)
guard (T.null cpfx || T.init cpfx == epfx)
(dpfx, ver, bs) <- cash32decodeType (epfx <> ":" <> cdat)
guard (dpfx == epfx)
return (ver, bs)
{- | High-Level: encode 'CashAddr' string for the provided network and hash.
Fails if the 'CashVersion' or length of hash 'ByteString' is invalid.
-}
-- | High-Level: encode 'CashAddr' string for the provided network and hash.
-- Fails if the 'CashVersion' or length of hash 'ByteString' is invalid.
cashAddrEncode :: Network -> CashVersion -> ByteString -> Maybe CashAddr
cashAddrEncode net cv bs = do
pfx <- getCashAddrPrefix net
cash32encodeType pfx cv bs
pfx <- net.cashAddrPrefix
cash32encodeType pfx cv bs
{- | Mid-Level: decode 'CashAddr' string containing arbitrary prefix, plus a
version byte before the 'ByteString' that encodes type and length.
-}
-- | Mid-Level: decode 'CashAddr' string containing arbitrary prefix, plus a
-- version byte before the 'ByteString' that encodes type and length.
cash32decodeType :: Cash32 -> Maybe (CashPrefix, CashVersion, ByteString)
cash32decodeType ca' = do
guard (T.toUpper ca' == ca' || ca == ca')
(dpfx, bs) <- cash32decode ca
guard (not (B.null bs))
let vb = B.head bs
pay = B.tail bs
(ver, len) <- decodeVersionByte vb
guard (B.length pay == len)
return (dpfx, ver, pay)
guard (T.toUpper ca' == ca' || ca == ca')
(dpfx, bs) <- cash32decode ca
guard (not (B.null bs))
let vb = B.head bs
pay = B.tail bs
(ver, len) <- decodeVersionByte vb
guard (B.length pay == len)
return (dpfx, ver, pay)
where
ca = T.toLower ca'
{- | Mid-Level: encode 'CashAddr' string containing arbitrary prefix and
'CashVersion'. Length must be among those allowed by the standard.
-}
-- | Mid-Level: encode 'CashAddr' string containing arbitrary prefix and
-- 'CashVersion'. Length must be among those allowed by the standard.
cash32encodeType :: CashPrefix -> CashVersion -> ByteString -> Maybe Cash32
cash32encodeType pfx cv bs = do
let len = B.length bs
vb <- encodeVersionByte cv len
let pl = vb `B.cons` bs
return (cash32encode pfx pl)
let len = B.length bs
vb <- encodeVersionByte cv len
let pl = vb `B.cons` bs
return (cash32encode pfx pl)
{- | Low-Level: decode 'Cash32' string. 'CashPrefix' must be part of the string.
No version or hash length validation is performed.
-}
-- | Low-Level: decode 'Cash32' string. 'CashPrefix' must be part of the string.
-- No version or hash length validation is performed.
cash32decode :: Cash32 -> Maybe (CashPrefix, ByteString)
cash32decode text = do
let bs = C.map toLower bs'
guard (C.map toUpper bs' == bs' || bs == bs')
let (pfx', dat) = C.breakEnd (== ':') bs
pfx <-
if B.null pfx' || pfx' == C.singleton ':'
then Nothing
else Just (B.init pfx')
b32 <- B.pack <$> mapM base32char (C.unpack dat)
let px = B.map (.&. 0x1f) pfx
pd = px <> B.singleton 0 <> b32
cs = cash32Polymod pd
bb = B.take (B.length b32 - 8) b32
guard (verifyCash32Polymod cs)
let out = toBase256 bb
return (E.decodeUtf8 pfx, out)
let bs = C.map toLower bs'
guard (C.map toUpper bs' == bs' || bs == bs')
let (pfx', dat) = C.breakEnd (== ':') bs
pfx <-
if B.null pfx' || pfx' == C.singleton ':'
then Nothing
else Just (B.init pfx')
b32 <- B.pack <$> mapM base32char (C.unpack dat)
let px = B.map (.&. 0x1f) pfx
pd = px <> B.singleton 0 <> b32
cs = cash32Polymod pd
bb = B.take (B.length b32 - 8) b32
guard (verifyCash32Polymod cs)
let out = toBase256 bb
return (decodeUtf8 pfx, out)
where
bs' = E.encodeUtf8 text
bs' = encodeUtf8 text
{- | Low-Level: encode 'Cash32' string for 'CashPrefix' provided. Can encode
arbitrary data. No prefix or length validation is performed.
-}
-- | Low-Level: encode 'Cash32' string for 'CashPrefix' provided. Can encode
-- arbitrary data. No prefix or length validation is performed.
cash32encode :: CashPrefix -> ByteString -> Cash32
cash32encode pfx bs =
let b32 = toBase32 bs
px = B.map (.&. 0x1f) (E.encodeUtf8 pfx)
pd = px <> B.singleton 0 <> b32 <> B.replicate 8 0
cs = cash32Polymod pd
c32 = B.map f (b32 <> cs)
f = fromIntegral . ord . (charset !!) . fromIntegral
in pfx <> ":" <> E.decodeUtf8 c32
let b32 = toBase32 bs
px = B.map (.&. 0x1f) (encodeUtf8 pfx)
pd = px <> B.singleton 0 <> b32 <> B.replicate 8 0
cs = cash32Polymod pd
c32 = B.map f (b32 <> cs)
f = fromIntegral . ord . (charset !!) . fromIntegral
in pfx <> ":" <> decodeUtf8 c32
{- | Convert base of 'ByteString' from eight bits per byte to five bits per
byte, adding padding as necessary.
-}
-- | Convert base of 'ByteString' from eight bits per byte to five bits per
-- byte, adding padding as necessary.
toBase32 :: ByteString -> ByteString
toBase32 =
B.pack
. map fromIntegral
. fst
. convertBits True 8 5
. map fromIntegral
. B.unpack
B.pack
. map fromIntegral
. fst
. convertBits True 8 5
. map fromIntegral
. B.unpack
{- | Convert base of 'ByteString' from five to eight bits per byte. Ignore
padding to be symmetric with respect to 'toBase32' function.
-}
-- | Convert base of 'ByteString' from five to eight bits per byte. Ignore
-- padding to be symmetric with respect to 'toBase32' function.
toBase256 :: ByteString -> ByteString
toBase256 =
B.pack
. map fromIntegral
. fst
. convertBits False 5 8
. map fromIntegral
. B.unpack
B.pack
. map fromIntegral
. fst
. convertBits False 5 8
. map fromIntegral
. B.unpack
-- | Obtain 'CashVersion' and payload length from 'CashAddr' version byte.
decodeVersionByte :: Word8 -> Maybe (CashVersion, Int)
decodeVersionByte vb = do
guard (vb .&. 0x80 == 0)
return (ver, len)
guard (vb .&. 0x80 == 0)
return (ver, len)
where
ver = vb `shiftR` 3
len = ls !! fromIntegral (vb .&. 0x07)
ls = [20, 24, 28, 32, 40, 48, 56, 64]
{- | Encode 'CashVersion' and length into version byte. Fail if version is
larger than five bits, or length incorrect, since that is invalid.
-}
-- | Encode 'CashVersion' and length into version byte. Fail if version is
-- larger than five bits, or length incorrect, since that is invalid.
encodeVersionByte :: CashVersion -> Int -> Maybe Word8
encodeVersionByte ver len = do
guard (ver == ver .&. 0x0f)
l <- case len of
20 -> Just 0
24 -> Just 1
28 -> Just 2
32 -> Just 3
40 -> Just 4
48 -> Just 5
56 -> Just 6
64 -> Just 7
_ -> Nothing
return ((ver `shiftL` 3) .|. l)
guard (ver == ver .&. 0x0f)
l <- case len of
20 -> Just 0
24 -> Just 1
28 -> Just 2
32 -> Just 3
40 -> Just 4
48 -> Just 5
56 -> Just 6
64 -> Just 7
_ -> Nothing
return ((ver `shiftL` 3) .|. l)
-- | Calculate or validate checksum from base32 'ByteString' (excluding prefix).
cash32Polymod :: ByteString -> ByteString
cash32Polymod v =
B.pack
[fromIntegral (polymod `shiftR` (5 * (7 - i))) .&. 0x1f | i <- [0 .. 7]]
B.pack
[fromIntegral (polymod `shiftR` (5 * (7 - i))) .&. 0x1f | i <- [0 .. 7]]
where
polymod = B.foldl' outer (1 :: Word64) v `xor` 1
outer c d =
let c0 = (fromIntegral (c `shiftR` 35) :: Word8)
c' = ((c .&. 0x07ffffffff) `shiftL` 5) `xor` fromIntegral d
in foldl' (inner c0) c' (zip [0 ..] generator)
let c0 = (fromIntegral (c `shiftR` 35) :: Word8)
c' = ((c .&. 0x07ffffffff) `shiftL` 5) `xor` fromIntegral d
in foldl' (inner c0) c' (zip [0 ..] generator)
generator =
[0x98f2bc8e61, 0x79b76d99e2, 0xf33e5fb3c4, 0xae2eabe2a8, 0x1e4f43e470]
[0x98f2bc8e61, 0x79b76d99e2, 0xf33e5fb3c4, 0xae2eabe2a8, 0x1e4f43e470]
inner c0 c (b, g)
| c0 `testBit` b = c `xor` g
| otherwise = c
| c0 `testBit` b = c `xor` g
| otherwise = c
-- | Validate that polymod 'ByteString' (eight bytes) is equal to zero.
verifyCash32Polymod :: ByteString -> Bool

26
src/Haskoin/Block.hs
View File

@ -1,18 +1,18 @@
{- |
Module : Haskoin.Block
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
Most functions relating to blocks are exported by this module.
-}
module Haskoin.Block (
module Haskoin.Block.Common,
-- |
-- Module : Haskoin.Block
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- Most functions relating to blocks are exported by this module.
module Haskoin.Block
( module Haskoin.Block.Common,
module Haskoin.Block.Headers,
module Haskoin.Block.Merkle,
) where
)
where
import Haskoin.Block.Common
import Haskoin.Block.Headers

573
src/Haskoin/Block/Common.hs
View File

@ -1,19 +1,21 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoFieldSelectors #-}
{- |
Module : Haskoin.Block.Common
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
Common data types and functions to handle blocks from the block chain.
-}
module Haskoin.Block.Common (
-- * Blocks
-- |
-- Module : Haskoin.Block.Common
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- Common data types and functions to handle blocks from the block chain.
module Haskoin.Block.Common
( -- * Blocks
Block (..),
BlockHeight,
Timestamp,
@ -29,53 +31,34 @@ module Haskoin.Block.Common (
Headers (..),
decodeCompact,
encodeCompact,
) where
)
where
import Control.DeepSeq
import Control.Monad (forM_, liftM2, mzero, replicateM, (<=<))
import Data.Aeson (
FromJSON (..),
ToJSON (..),
Value (..),
object,
toJSON,
withObject,
withText,
(.:),
(.=),
)
import Data.Aeson.Encoding (pairs, unsafeToEncoding)
import Control.Monad
import Data.Aeson
import Data.Aeson.Encoding
import Data.Binary (Binary (..))
import Data.Bits (shiftL, shiftR, (.&.), (.|.))
import qualified Data.ByteString as B
import Data.Bits
import Data.ByteString qualified as B
import Data.ByteString.Builder (char7)
import qualified Data.ByteString.Lazy as BL
import Data.Bytes.Get (
MonadGet,
getWord32le,
runGetL,
runGetS,
)
import Data.Bytes.Put (
MonadPut,
putWord32le,
runPutL,
runPutS,
)
import Data.Bytes.Serial (Serial (..))
import Data.Hashable (Hashable)
import Data.Maybe (fromMaybe)
import Data.ByteString.Lazy qualified as L
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import Data.Hashable
import Data.Maybe
import Data.Serialize (Serialize (..))
import Data.String (IsString, fromString)
import Data.String.Conversions (cs)
import Data.String
import Data.String.Conversions
import Data.Text (Text)
import Data.Word (Word32)
import GHC.Generics (Generic)
import Data.Word
import GHC.Generics
import Haskoin.Crypto.Hash
import Haskoin.Network.Common
import Haskoin.Transaction.Common
import Haskoin.Util
import qualified Text.Read as R
import Haskoin.Util.Helpers
import Text.Read qualified as R
-- | Height of a block in the block chain, starting at 0 for Genesis.
type BlockHeight = Word32
@ -85,311 +68,312 @@ type Timestamp = Word32
-- | Block header and transactions.
data Block = Block
{ blockHeader :: !BlockHeader
, blockTxns :: ![Tx]
}
deriving (Eq, Show, Read, Generic, Hashable, NFData)
{ header :: !BlockHeader,
txs :: ![Tx]
}
deriving (Eq, Show, Read, Generic, Hashable, NFData)
instance Serial Block where
deserialize = do
header <- deserialize
(VarInt c) <- deserialize
txs <- replicateM (fromIntegral c) deserialize
return $ Block header txs
serialize (Block h txs) = do
serialize h
putVarInt $ length txs
forM_ txs serialize
deserialize = do
header <- deserialize
(VarInt c) <- deserialize
txs <- replicateM (fromIntegral c) deserialize
return $ Block header txs
serialize (Block h txs) = do
serialize h
putVarInt $ length txs
forM_ txs serialize
instance Serialize Block where
get = deserialize
put = serialize
get = deserialize
put = serialize
instance Binary Block where
get = deserialize
put = serialize
get = deserialize
put = serialize
instance ToJSON Block where
toJSON (Block h t) = object ["header" .= h, "transactions" .= t]
toEncoding (Block h t) = pairs $ "header" .= h <> "transactions" .= t
toJSON (Block h t) =
object ["header" .= h, "transactions" .= t]
toEncoding (Block h t) =
pairs $
mconcat
[ "header" `pair` toEncoding h,
"transactions" `pair` list toEncoding t
]
instance FromJSON Block where
parseJSON =
withObject "Block" $ \o ->
Block <$> o .: "header" <*> o .: "transactions"
parseJSON =
withObject "Block" $ \o ->
Block <$> o .: "header" <*> o .: "transactions"
-- | Block header hash. To be serialized reversed for display purposes.
newtype BlockHash = BlockHash
{ getBlockHash :: Hash256
}
deriving (Eq, Ord, Generic, Hashable, Serial, NFData)
newtype BlockHash = BlockHash {get :: Hash256}
deriving (Eq, Ord, Generic, Hashable, Serial, NFData)
instance Serialize BlockHash where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance Binary BlockHash where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance Show BlockHash where
showsPrec _ = shows . blockHashToHex
showsPrec _ = shows . blockHashToHex
instance Read BlockHash where
readPrec = do
R.String str <- R.lexP
maybe R.pfail return $ hexToBlockHash $ cs str
readPrec = do
R.String str <- R.lexP
maybe R.pfail return $ hexToBlockHash $ cs str
instance IsString BlockHash where
fromString s =
let e = error "Could not read block hash from hex string"
in fromMaybe e $ hexToBlockHash $ cs s
fromString s =
fromMaybe (error "Could not read block hash from hex string") $
hexToBlockHash $
cs s
instance FromJSON BlockHash where
parseJSON =
withText "BlockHash" $
maybe mzero return . hexToBlockHash
parseJSON =
withText "BlockHash" $
maybe mzero return . hexToBlockHash
instance ToJSON BlockHash where
toJSON = String . blockHashToHex
toEncoding h =
unsafeToEncoding $
char7 '"'
<> hexBuilder (BL.reverse (runPutL (serialize h)))
<> char7 '"'
toJSON = String . blockHashToHex
toEncoding = hexEncoding . L.reverse . runPutL . serialize
{- | Block hashes are reversed with respect to the in-memory byte order in a
block hash when displayed.
-}
-- | Block hashes are reversed with respect to the in-memory byte order in a
-- block hash when displayed.
blockHashToHex :: BlockHash -> Text
blockHashToHex (BlockHash h) = encodeHex (B.reverse (runPutS (serialize h)))
{- | Convert a human-readable hex block hash into a 'BlockHash'. Bytes are
reversed as normal.
-}
-- | Convert a human-readable hex block hash into a 'BlockHash'. Bytes are
-- reversed as normal.
hexToBlockHash :: Text -> Maybe BlockHash
hexToBlockHash hex = do
bs <- B.reverse <$> decodeHex hex
h <- eitherToMaybe (runGetS deserialize bs)
return $ BlockHash h
bs <- B.reverse <$> decodeHex hex
h <- eitherToMaybe (runGetS deserialize bs)
return $ BlockHash h
{- | Data type recording information of a 'Block'. The hash of a block is
defined as the hash of this data structure, serialized. The block mining
process involves finding a partial hash collision by varying the nonce in the
'BlockHeader' and/or additional entropy in the coinbase 'Transaction' of this
'Block'. Variations in the coinbase will result in different merkle roots in
the 'BlockHeader'.
-}
-- | Data type recording information of a 'Block'. The hash of a block is
-- defined as the hash of this data structure, serialized. The block mining
-- process involves finding a partial hash collision by varying the nonce in the
-- 'BlockHeader' and/or additional entropy in the coinbase 'Transaction' of this
-- 'Block'. Variations in the coinbase will result in different merkle roots in
-- the 'BlockHeader'.
data BlockHeader = BlockHeader
{ blockVersion :: !Word32 -- 4 bytes
, -- | hash of the previous block (parent)
prevBlock :: !BlockHash -- 32 bytes
, -- | root of the merkle tree of transactions
merkleRoot :: !Hash256 -- 32 bytes
, -- | unix timestamp
blockTimestamp :: !Timestamp -- 4 bytes
, -- | difficulty target
blockBits :: !Word32 -- 4 bytes
, -- | random nonce
bhNonce :: !Word32 -- 4 bytes
}
deriving (Eq, Ord, Show, Read, Generic, Hashable, NFData)
{ version :: !Word32, -- 4 bytes
-- | hash of the previous block (parent)
prev :: !BlockHash, -- 32 bytes
-- | root of the merkle tree of transactions
merkle :: !Hash256, -- 32 bytes
-- | unix timestamp
timestamp :: !Timestamp, -- 4 bytes
-- | difficulty target
bits :: !Word32, -- 4 bytes
-- | random nonce
nonce :: !Word32 -- 4 bytes
}
deriving (Eq, Ord, Show, Read, Generic, Hashable, NFData)
-- 80 bytes
instance ToJSON BlockHeader where
toJSON (BlockHeader v p m t b n) =
object
[ "version" .= v
, "prevblock" .= p
, "merkleroot" .= encodeHex (runPutS (serialize m))
, "timestamp" .= t
, "bits" .= b
, "nonce" .= n
]
toEncoding (BlockHeader v p m t b n) =
pairs
( "version" .= v
<> "prevblock" .= p
<> "merkleroot" .= encodeHex (runPutS (serialize m))
<> "timestamp" .= t
<> "bits" .= b
<> "nonce" .= n
)
toJSON (BlockHeader v p m t b n) =
object
[ "version" .= v,
"prevblock" .= p,
"merkleroot" .= encodeHex (runPutS $ serialize m),
"timestamp" .= t,
"bits" .= b,
"nonce" .= n
]
toEncoding (BlockHeader v p m t b n) =
pairs $
mconcat
[ "version" `pair` word32 v,
"prevblock" `pair` toEncoding p,
"merkleroot" `pair` hexEncoding (runPutL $ serialize m),
"timestamp" `pair` toEncoding t,
"bits" `pair` toEncoding b,
"nonce" `pair` toEncoding n
]
instance FromJSON BlockHeader where
parseJSON =
withObject "BlockHeader" $ \o ->
BlockHeader <$> o .: "version"
<*> o .: "prevblock"
<*> (f =<< o .: "merkleroot")
<*> o .: "timestamp"
<*> o .: "bits"
<*> o .: "nonce"
where
f = maybe mzero return . (eitherToMaybe . runGetS deserialize <=< decodeHex)
parseJSON =
withObject "BlockHeader" $ \o ->
BlockHeader
<$> o .: "version"
<*> o .: "prevblock"
<*> (f =<< o .: "merkleroot")
<*> o .: "timestamp"
<*> o .: "bits"
<*> o .: "nonce"
where
f = maybe mzero return . (eitherToMaybe . runGetS deserialize <=< decodeHex)
instance Serial BlockHeader where
deserialize = do
v <- getWord32le
p <- deserialize
m <- deserialize
t <- getWord32le
b <- getWord32le
n <- getWord32le
return
BlockHeader
{ blockVersion = v
, prevBlock = p
, merkleRoot = m
, blockTimestamp = t
, blockBits = b
, bhNonce = n
}
serialize (BlockHeader v p m bt bb n) = do
putWord32le v
serialize p
serialize m
putWord32le bt
putWord32le bb
putWord32le n
deserialize = do
v <- getWord32le
p <- deserialize
m <- deserialize
t <- getWord32le
b <- getWord32le
n <- getWord32le
return
BlockHeader
{ version = v,
prev = p,
merkle = m,
timestamp = t,
bits = b,
nonce = n
}
serialize (BlockHeader v p m bt bb n) = do
putWord32le v
serialize p
serialize m
putWord32le bt
putWord32le bb
putWord32le n
instance Binary BlockHeader where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance Serialize BlockHeader where
put = serialize
get = deserialize
put = serialize
get = deserialize
-- | Compute hash of 'BlockHeader'.
headerHash :: BlockHeader -> BlockHash
headerHash = BlockHash . doubleSHA256 . runPutS . serialize
{- | A block locator is a set of block headers, denser towards the best block
and sparser towards the genesis block. It starts at the highest block known.
It is used by a node to synchronize against the network. When the locator is
provided to a peer, it will send back block hashes starting from the first
block in the locator that it recognizes.
-}
-- | A block locator is a set of block headers, denser towards the best block
-- and sparser towards the genesis block. It starts at the highest block known.
-- It is used by a node to synchronize against the network. When the locator is
-- provided to a peer, it will send back block hashes starting from the first
-- block in the locator that it recognizes.
type BlockLocator = [BlockHash]
{- | Data type representing a getblocks message request. It is used in the
bitcoin protocol to retrieve blocks from a peer by providing it a
'BlockLocator' object. The response to a 'GetBlocks' message is an 'Inv'
message containing a list of block hashes that the peer believes this node is
missing. The number of block hashes in that inv message will end at the stop
block hash, at at the tip of the chain, or after 500 entries, whichever comes
earlier.
-}
-- | Data type representing a getblocks message request. It is used in the
-- bitcoin protocol to retrieve blocks from a peer by providing it a
-- 'BlockLocator' object. The response to a 'GetBlocks' message is an 'Inv'
-- message containing a list of block hashes that the peer believes this node is
-- missing. The number of block hashes in that inv message will end at the stop
-- block hash, at at the tip of the chain, or after 500 entries, whichever comes
-- earlier.
data GetBlocks = GetBlocks
{ getBlocksVersion :: !Word32
, -- | block locator object
getBlocksLocator :: !BlockLocator
, -- | hash of the last desired block
getBlocksHashStop :: !BlockHash
}
deriving (Eq, Show, Read, Generic, NFData)
{ version :: !Word32,
-- | block locator object
locator :: !BlockLocator,
-- | hash of the last desired block
stop :: !BlockHash
}
deriving (Eq, Show, Read, Generic, NFData)
instance Serial GetBlocks where
deserialize =
GetBlocks
<$> getWord32le
<*> (repList =<< deserialize)
<*> deserialize
where
repList (VarInt c) = replicateM (fromIntegral c) deserialize
serialize (GetBlocks v xs h) = putGetBlockMsg v xs h
instance Serialize GetBlocks where
put = serialize
get = deserialize
putGetBlockMsg :: MonadPut m => Word32 -> BlockLocator -> BlockHash -> m ()
putGetBlockMsg v xs h = do
deserialize =
GetBlocks
<$> getWord32le
<*> (repList =<< deserialize)
<*> deserialize
where
repList (VarInt c) = replicateM (fromIntegral c) deserialize
serialize (GetBlocks v xs h) = do
putWord32le v
putVarInt $ length xs
forM_ xs serialize
serialize h
{- | Similar to the 'GetBlocks' message type but for retrieving block headers
only. The response to a 'GetHeaders' request is a 'Headers' message
containing a list of block headers. A maximum of 2000 block headers can be
returned. 'GetHeaders' is used by simplified payment verification (SPV)
clients to exclude block contents when synchronizing the block chain.
-}
instance Serialize GetBlocks where
put = serialize
get = deserialize
-- | Similar to the 'GetBlocks' message type but for retrieving block headers
-- only. The response to a 'GetHeaders' request is a 'Headers' message
-- containing a list of block headers. A maximum of 2000 block headers can be
-- returned. 'GetHeaders' is used by simplified payment verification (SPV)
-- clients to exclude block contents when synchronizing the block chain.
data GetHeaders = GetHeaders
{ getHeadersVersion :: !Word32
, -- | block locator object
getHeadersBL :: !BlockLocator
, -- | hash of the last desired block header
getHeadersHashStop :: !BlockHash
}
deriving (Eq, Show, Read, Generic, NFData)
{ version :: !Word32,
-- | block locator object
locator :: !BlockLocator,
-- | hash of the last desired block header
stop :: !BlockHash
}
deriving (Eq, Show, Read, Generic, NFData)
instance Serial GetHeaders where
deserialize =
GetHeaders
<$> getWord32le
<*> (repList =<< deserialize)
<*> deserialize
where
repList (VarInt c) = replicateM (fromIntegral c) deserialize
serialize (GetHeaders v xs h) = putGetBlockMsg v xs h
deserialize =
GetHeaders
<$> getWord32le
<*> (repList =<< deserialize)
<*> deserialize
where
repList (VarInt c) = replicateM (fromIntegral c) deserialize
serialize (GetHeaders v xs h) = do
putWord32le v
putVarInt $ length xs
forM_ xs serialize
serialize h
instance Serialize GetHeaders where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance Binary GetHeaders where
put = serialize
get = deserialize
put = serialize
get = deserialize
-- | 'BlockHeader' type with a transaction count as 'VarInt'
type BlockHeaderCount = (BlockHeader, VarInt)
{- | The 'Headers' type is used to return a list of block headers in
response to a 'GetHeaders' message.
-}
-- | The 'Headers' type is used to return a list of block headers in
-- response to a 'GetHeaders' message.
newtype Headers = Headers
{ -- | list of block headers with transaction count
headersList :: [BlockHeaderCount]
}
deriving (Eq, Show, Read, Generic, NFData)
{ -- | list of block headers with transaction count
list :: [BlockHeaderCount]
}
deriving (Eq, Show, Read, Generic, NFData)
instance Serial Headers where
deserialize = Headers <$> (repList =<< deserialize)
where
repList (VarInt c) = replicateM (fromIntegral c) action
action = liftM2 (,) deserialize deserialize
serialize (Headers xs) = do
putVarInt $ length xs
forM_ xs $ \(a, b) -> serialize a >> serialize b
deserialize = Headers <$> (repList =<< deserialize)
where
repList (VarInt c) = replicateM (fromIntegral c) action
action = liftM2 (,) deserialize deserialize
serialize (Headers xs) = do
putVarInt $ length xs
forM_ xs $ \(a, b) -> serialize a >> serialize b
instance Serialize Headers where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance Binary Headers where
put = serialize
get = deserialize
put = serialize
get = deserialize
{- | Decode the compact number used in the difficulty target of a block.
The compact format is a representation of a whole number \(N\) using an
unsigned 32-bit number similar to a floating point format. The most
significant 8 bits are the unsigned exponent of base 256. This exponent can
be thought of as the number of bytes of \(N\). The lower 23 bits are the
mantissa. Bit number 24 represents the sign of \(N\).
\[
N = -1^{sign} \times mantissa \times 256^{exponent-3}
\]
-}
-- | Decode the compact number used in the difficulty target of a block.
--
-- The compact format is a representation of a whole number \(N\) using an
-- unsigned 32-bit number similar to a floating point format. The most
-- significant 8 bits are the unsigned exponent of base 256. This exponent can
-- be thought of as the number of bytes of \(N\). The lower 23 bits are the
-- mantissa. Bit number 24 represents the sign of \(N\).
--
-- \[
-- N = -1^{sign} \times mantissa \times 256^{exponent-3}
-- \]
decodeCompact ::
Word32 ->
-- | true means overflow
(Integer, Bool)
Word32 ->
-- | true means overflow
(Integer, Bool)
decodeCompact nCompact = (if neg then res * (-1) else res, over)
where
nSize :: Int
@ -398,23 +382,22 @@ decodeCompact nCompact = (if neg then res * (-1) else res, over)
nWord' = nCompact .&. 0x007fffff
nWord :: Word32
nWord
| nSize <= 3 = nWord' `shiftR` (8 * (3 - nSize))
| otherwise = nWord'
| nSize <= 3 = nWord' `shiftR` (8 * (3 - nSize))
| otherwise = nWord'
res :: Integer
res
| nSize <= 3 = fromIntegral nWord
| otherwise = fromIntegral nWord `shiftL` (8 * (nSize - 3))
| nSize <= 3 = fromIntegral nWord
| otherwise = fromIntegral nWord `shiftL` (8 * (nSize - 3))
neg = nWord /= 0 && (nCompact .&. 0x00800000) /= 0
over =
nWord /= 0
&& ( nSize > 34
|| nWord > 0xff && nSize > 33
|| nWord > 0xffff && nSize > 32
)
nWord /= 0
&& ( nSize > 34
|| nWord > 0xff && nSize > 33
|| nWord > 0xffff && nSize > 32
)
{- | Encode an 'Integer' to the compact number format used in the difficulty
target of a block.
-}
-- | Encode an 'Integer' to the compact number format used in the difficulty
-- target of a block.
encodeCompact :: Integer -> Word32
encodeCompact i = nCompact
where
@ -422,23 +405,23 @@ encodeCompact i = nCompact
neg = i < 0
nSize' :: Int
nSize' =
let f 0 = 0
f n = 1 + f (n `shiftR` 8)
in f i'
let f 0 = 0
f n = 1 + f (n `shiftR` 8)
in f i'
nCompact''' :: Word32
nCompact'''
| nSize' <= 3 = fromIntegral $ (low64 .&. i') `shiftL` (8 * (3 - nSize'))
| otherwise = fromIntegral $ low64 .&. (i' `shiftR` (8 * (nSize' - 3)))
| nSize' <= 3 = fromIntegral $ (low64 .&. i') `shiftL` (8 * (3 - nSize'))
| otherwise = fromIntegral $ low64 .&. (i' `shiftR` (8 * (nSize' - 3)))
nCompact'' :: Word32
nSize :: Int
(nCompact'', nSize)
| nCompact''' .&. 0x00800000 /= 0 = (nCompact''' `shiftR` 8, nSize' + 1)
| otherwise = (nCompact''', nSize')
| nCompact''' .&. 0x00800000 /= 0 = (nCompact''' `shiftR` 8, nSize' + 1)
| otherwise = (nCompact''', nSize')
nCompact' :: Word32
nCompact' = nCompact'' .|. (fromIntegral nSize `shiftL` 24)
nCompact :: Word32
nCompact
| neg && (nCompact' .&. 0x007fffff /= 0) = nCompact' .|. 0x00800000
| otherwise = nCompact'
| neg && (nCompact' .&. 0x007fffff /= 0) = nCompact' .|. 0x00800000
| otherwise = nCompact'
low64 :: Integer
low64 = 0xffffffffffffffff

1286
src/Haskoin/Block/Headers.hs
View File

File diff suppressed because it is too large Load Diff

331
src/Haskoin/Block/Merkle.hs
View File

@ -1,18 +1,20 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE NoFieldSelectors #-}
{- |
Module : Haskoin.Block.Merkle
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
Function to deal with Merkle trees inside blocks.
-}
module Haskoin.Block.Merkle (
-- * Merkle Blocks
-- |
-- Module : Haskoin.Block.Merkle
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- Function to deal with Merkle trees inside blocks.
module Haskoin.Block.Merkle
( -- * Merkle Blocks
MerkleBlock (..),
MerkleRoot,
FlagBits,
@ -32,7 +34,8 @@ module Haskoin.Block.Merkle (
extractMatches,
splitIn,
boolsToWord8,
) where
)
where
import Control.DeepSeq
import Control.Monad (forM_, replicateM, when)
@ -50,8 +53,8 @@ import Data.Word (Word32, Word8)
import GHC.Generics
import Haskoin.Block.Common
import Haskoin.Crypto.Hash
import Haskoin.Data
import Haskoin.Network.Common
import Haskoin.Network.Data
import Haskoin.Transaction.Common
-- | Hash of the block's Merkle root.
@ -63,53 +66,52 @@ type FlagBits = [Bool]
-- | Partial Merkle tree for a filtered block.
type PartialMerkleTree = [Hash256]
{- | Filtered block: a block with a partial Merkle tree that only includes the
transactions that pass a bloom filter that was negotiated.
-}
-- | Filtered block: a block with a partial Merkle tree that only includes the
-- transactions that pass a bloom filter that was negotiated.
data MerkleBlock = MerkleBlock
{ -- | block header
merkleHeader :: !BlockHeader
, -- | total number of transactions in block
merkleTotalTxns :: !Word32
, -- | hashes in depth-first order
mHashes :: !PartialMerkleTree
, -- | bits to rebuild partial merkle tree
mFlags :: !FlagBits
}
deriving (Eq, Show, Read, Generic, Hashable, NFData)
{ -- | block header
header :: !BlockHeader,
-- | total number of transactions in block
txn :: !Word32,
-- | hashes in depth-first order
hashes :: !PartialMerkleTree,
-- | bits to rebuild partial merkle tree
flags :: !FlagBits
}
deriving (Eq, Show, Read, Generic, Hashable, NFData)
instance Serial MerkleBlock where
deserialize = do
header <- deserialize
ntx <- getWord32le
(VarInt matchLen) <- deserialize
hashes <- replicateM (fromIntegral matchLen) deserialize
(VarInt flagLen) <- deserialize
ws <- replicateM (fromIntegral flagLen) getWord8
return $ MerkleBlock header ntx hashes (decodeMerkleFlags ws)
deserialize = do
header <- deserialize
ntx <- getWord32le
(VarInt matchLen) <- deserialize
hashes <- replicateM (fromIntegral matchLen) deserialize
(VarInt flagLen) <- deserialize
ws <- replicateM (fromIntegral flagLen) getWord8
return $ MerkleBlock header ntx hashes (decodeMerkleFlags ws)
serialize (MerkleBlock h ntx hashes flags) = do
serialize h
putWord32le ntx
putVarInt $ length hashes
forM_ hashes serialize
let ws = encodeMerkleFlags flags
putVarInt $ length ws
forM_ ws putWord8
serialize (MerkleBlock h ntx hashes flags) = do
serialize h
putWord32le ntx
putVarInt $ length hashes
forM_ hashes serialize
let ws = encodeMerkleFlags flags
putVarInt $ length ws
forM_ ws putWord8
instance Binary MerkleBlock where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance Serialize MerkleBlock where
put = serialize
get = deserialize
put = serialize
get = deserialize
-- | Unpack Merkle flags into 'FlagBits' structure.
decodeMerkleFlags :: [Word8] -> FlagBits
decodeMerkleFlags ws =
[ b | p <- [0 .. length ws * 8 - 1], b <- [testBit (ws !! (p `div` 8)) (p `mod` 8)]
]
[ b | p <- [0 .. length ws * 8 - 1], b <- [testBit (ws !! (p `div` 8)) (p `mod` 8)]
]
-- | Pack Merkle flags from 'FlagBits'.
encodeMerkleFlags :: FlagBits -> [Word8]
@ -117,33 +119,32 @@ encodeMerkleFlags bs = map boolsToWord8 $ splitIn 8 bs
-- | Computes the height of a Merkle tree.
calcTreeHeight ::
-- | number of transactions (leaf nodes)
Int ->
-- | height of the merkle tree
Int
-- | number of transactions (leaf nodes)
Int ->
-- | height of the merkle tree
Int
calcTreeHeight ntx
| ntx < 2 = 0
| even ntx = 1 + calcTreeHeight (ntx `div` 2)
| otherwise = calcTreeHeight $ ntx + 1
| ntx < 2 = 0
| even ntx = 1 + calcTreeHeight (ntx `div` 2)
| otherwise = calcTreeHeight $ ntx + 1
{- | Computes the width of a Merkle tree at a specific height. The transactions
are at height 0.
-}
-- | Computes the width of a Merkle tree at a specific height. The transactions
-- are at height 0.
calcTreeWidth ::
-- | number of transactions (leaf nodes)
Int ->
-- | height at which we want to compute the width
Int ->
-- | width of the Merkle tree
Int
-- | number of transactions (leaf nodes)
Int ->
-- | height at which we want to compute the width
Int ->
-- | width of the Merkle tree
Int
calcTreeWidth ntx h = (ntx + (1 `shiftL` h) - 1) `shiftR` h
-- | Computes the root of a Merkle tree from a list of leaf node hashes.
buildMerkleRoot ::
-- | transaction hashes (leaf nodes)
[TxHash] ->
-- | root of the Merkle tree
MerkleRoot
-- | transaction hashes (leaf nodes)
[TxHash] ->
-- | root of the Merkle tree
MerkleRoot
buildMerkleRoot txs = calcHash (calcTreeHeight $ length txs) 0 txs
-- | Concatenate and compute double SHA256.
@ -152,46 +153,44 @@ hash2 a b = doubleSHA256 $ runPutS (serialize a) <> runPutS (serialize b)
-- | Computes the hash of a specific node in a Merkle tree.
calcHash ::
-- | height of the node
Int ->
-- | position of the node (0 for the leftmost node)
Int ->
-- | transaction hashes (leaf nodes)
[TxHash] ->
-- | hash of the node at the specified position
Hash256
-- | height of the node
Int ->
-- | position of the node (0 for the leftmost node)
Int ->
-- | transaction hashes (leaf nodes)
[TxHash] ->
-- | hash of the node at the specified position
Hash256
calcHash height pos txs
| height < 0 || pos < 0 = error "calcHash: Invalid parameters"
| height == 0 = getTxHash $ txs !! pos
| otherwise = hash2 left right
| height < 0 || pos < 0 = error "calcHash: Invalid parameters"
| height == 0 = (txs !! pos).get
| otherwise = hash2 left right
where
left = calcHash (height - 1) (pos * 2) txs
right
| pos * 2 + 1 < calcTreeWidth (length txs) (height - 1) =
calcHash (height - 1) (pos * 2 + 1) txs
| otherwise = left
| pos * 2 + 1 < calcTreeWidth (length txs) (height - 1) =
calcHash (height - 1) (pos * 2 + 1) txs
| otherwise = left
{- | Build a partial Merkle tree. Provide a list of tuples with all transaction
hashes in the block, and whether the transaction is to be included in the
partial tree. Returns a flag bits structure and the computed partial Merkle
tree.
-}
-- | Build a partial Merkle tree. Provide a list of tuples with all transaction
-- hashes in the block, and whether the transaction is to be included in the
-- partial tree. Returns a flag bits structure and the computed partial Merkle
-- tree.
buildPartialMerkle ::
-- | transaction hash and whether to include
[(TxHash, Bool)] ->
-- | flag bits and partial Merkle tree
(FlagBits, PartialMerkleTree)
-- | transaction hash and whether to include
[(TxHash, Bool)] ->
-- | flag bits and partial Merkle tree
(FlagBits, PartialMerkleTree)
buildPartialMerkle hs = traverseAndBuild (calcTreeHeight $ length hs) 0 hs
{- | Helper function to build partial Merkle tree. Used by 'buildPartialMerkle'
above.
-}
-- | Helper function to build partial Merkle tree. Used by 'buildPartialMerkle'
-- above.
traverseAndBuild ::
Int -> Int -> [(TxHash, Bool)] -> (FlagBits, PartialMerkleTree)
Int -> Int -> [(TxHash, Bool)] -> (FlagBits, PartialMerkleTree)
traverseAndBuild height pos txs
| height < 0 || pos < 0 = error "traverseAndBuild: Invalid parameters"
| height == 0 || not match = ([match], [calcHash height pos t])
| otherwise = (match : lb ++ rb, lh ++ rh)
| height < 0 || pos < 0 = error "traverseAndBuild: Invalid parameters"
| height == 0 || not match = ([match], [calcHash height pos t])
| otherwise = (match : lb ++ rb, lh ++ rh)
where
t = map fst txs
s = pos `shiftL` height
@ -199,88 +198,86 @@ traverseAndBuild height pos txs
match = any snd $ take (e - s) $ drop s txs
(lb, lh) = traverseAndBuild (height - 1) (pos * 2) txs
(rb, rh)
| (pos * 2 + 1) < calcTreeWidth (length txs) (height - 1) =
traverseAndBuild (height - 1) (pos * 2 + 1) txs
| otherwise = ([], [])
| (pos * 2 + 1) < calcTreeWidth (length txs) (height - 1) =
traverseAndBuild (height - 1) (pos * 2 + 1) txs
| otherwise = ([], [])
-- | Helper function to extract transaction hashes from partial Merkle tree.
traverseAndExtract ::
Int ->
Int ->
Int ->
FlagBits ->
PartialMerkleTree ->
Maybe (MerkleRoot, [TxHash], Int, Int)
Int ->
Int ->
Int ->
FlagBits ->
PartialMerkleTree ->
Maybe (MerkleRoot, [TxHash], Int, Int)
traverseAndExtract height pos ntx flags hashes
| null flags = Nothing
| height == 0 || not match = leafResult
| isNothing leftM = Nothing
| (pos * 2 + 1) >= calcTreeWidth ntx (height - 1) =
Just (hash2 lh lh, lm, lcf + 1, lch)
| isNothing rightM = Nothing
| otherwise =
Just (hash2 lh rh, lm ++ rm, lcf + rcf + 1, lch + rch)
| null flags = Nothing
| height == 0 || not match = leafResult
| isNothing leftM = Nothing
| (pos * 2 + 1) >= calcTreeWidth ntx (height - 1) =
Just (hash2 lh lh, lm, lcf + 1, lch)
| isNothing rightM = Nothing
| otherwise =
Just (hash2 lh rh, lm ++ rm, lcf + rcf + 1, lch + rch)
where
leafResult
| null hashes = Nothing
| otherwise = Just (h, [TxHash h | height == 0 && match], 1, 1)
| null hashes = Nothing
| otherwise = Just (h, [TxHash h | height == 0 && match], 1, 1)
(match : fs) = flags
(h : _) = hashes
leftM = traverseAndExtract (height - 1) (pos * 2) ntx fs hashes
(lh, lm, lcf, lch) = fromMaybe e leftM
rightM =
traverseAndExtract
(height - 1)
(pos * 2 + 1)
ntx
(drop lcf fs)
(drop lch hashes)
traverseAndExtract
(height - 1)
(pos * 2 + 1)
ntx
(drop lcf fs)
(drop lch hashes)
(rh, rm, rcf, rch) = fromMaybe e rightM
e = error "traverseAndExtract: unexpected error extracting a Maybe value"
{- | Extracts the matching hashes from a partial merkle tree. This will return
the list of transaction hashes that have been included (set to true) in
a call to 'buildPartialMerkle'.
-}
-- | Extracts the matching hashes from a partial merkle tree. This will return
-- the list of transaction hashes that have been included (set to true) in
-- a call to 'buildPartialMerkle'.
extractMatches ::
Network ->
FlagBits ->
PartialMerkleTree ->
-- | number of transaction at height 0 (leaf nodes)
Int ->
-- | Merkle root and list of matching transaction hashes
Either String (MerkleRoot, [TxHash])
Network ->
FlagBits ->
PartialMerkleTree ->
-- | number of transaction at height 0 (leaf nodes)
Int ->
-- | Merkle root and list of matching transaction hashes
Either String (MerkleRoot, [TxHash])
extractMatches net flags hashes ntx
| ntx == 0 =
Left
"extractMatches: number of transactions can not be 0"
| ntx > getMaxBlockSize net `div` 60 =
Left
"extractMatches: number of transactions excessively high"
| length hashes > ntx =
Left
"extractMatches: More hashes provided than the number of transactions"
| length flags < length hashes =
Left
"extractMatches: At least one bit per node and one bit per hash"
| isNothing resM =
Left
"extractMatches: traverseAndExtract failed"
| (nBitsUsed + 7) `div` 8 /= (length flags + 7) `div` 8 =
Left
"extractMatches: All bits were not consumed"
| nHashUsed /= length hashes =
Left $
"extractMatches: All hashes were not consumed: " ++ show nHashUsed
| otherwise = return (merkRoot, matches)
| ntx == 0 =
Left
"extractMatches: number of transactions can not be 0"
| ntx > net.maxBlockSize `div` 60 =
Left
"extractMatches: number of transactions excessively high"
| length hashes > ntx =
Left
"extractMatches: More hashes provided than the number of transactions"
| length flags < length hashes =
Left
"extractMatches: At least one bit per node and one bit per hash"
| isNothing resM =
Left
"extractMatches: traverseAndExtract failed"
| (nBitsUsed + 7) `div` 8 /= (length flags + 7) `div` 8 =
Left
"extractMatches: All bits were not consumed"
| nHashUsed /= length hashes =
Left $
"extractMatches: All hashes were not consumed: " ++ show nHashUsed
| otherwise = return (merkRoot, matches)
where
resM = traverseAndExtract (calcTreeHeight ntx) 0 ntx flags hashes
(merkRoot, matches, nBitsUsed, nHashUsed) = fromMaybe e resM
e = error "extractMatches: unexpected error extracting a Maybe value"
{- | Helper function to split a list in chunks 'Int' length. Last chunk may be
smaller.
-}
-- | Helper function to split a list in chunks 'Int' length. Last chunk may be
-- smaller.
splitIn :: Int -> [a] -> [[a]]
splitIn _ [] = []
splitIn c xs = xs1 : splitIn c xs2
@ -294,15 +291,11 @@ boolsToWord8 xs = foldl setBit 0 (map snd $ filter fst $ zip xs [0 .. 7])
-- | Get matching transactions from Merkle block.
merkleBlockTxs :: Network -> MerkleBlock -> Either String [TxHash]
merkleBlockTxs net b =
let flags = mFlags b
hs = mHashes b
n = fromIntegral $ merkleTotalTxns b
merkle = merkleRoot $ merkleHeader b
in do
(root, ths) <- extractMatches net flags hs n
when (root /= merkle) $ Left "merkleBlockTxs: Merkle root incorrect"
return ths
merkleBlockTxs net b = do
(root, ths) <- extractMatches net b.flags b.hashes (fromIntegral b.txn)
when (root /= b.header.merkle) $
Left "merkleBlockTxs: Merkle root incorrect"
return ths
-- | Check if Merkle block root is valid against the block header.
testMerkleRoot :: Network -> MerkleBlock -> Bool

615
src/Haskoin/Constants.hs
View File

@ -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]

28
src/Haskoin/Crypto.hs
View File

@ -1,19 +1,21 @@
{- |
Module : Haskoin.Crypto
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
Hashing functions and ECDSA signatures.
-}
module Haskoin.Crypto (
-- |
-- Module : Haskoin.Crypto
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- Hashing functions and ECDSA signatures.
module Haskoin.Crypto
( module Secp256k1,
module Hash,
module Keys,
module Signature,
module Secp256k1,
) where
)
where
import Crypto.Secp256k1 as Secp256k1
import Haskoin.Crypto.Hash as Hash
import Haskoin.Crypto.Keys as Keys
import Haskoin.Crypto.Signature as Signature

290
src/Haskoin/Crypto/Hash.hs
View File

@ -1,24 +1,29 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoFieldSelectors #-}
{- |
Module : Haskoin.Crypto.Hash
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
Hashing functions and corresponding data types. Uses functions from the
cryptonite library.
-}
module Haskoin.Crypto.Hash (
-- * Hashes
Hash512 (getHash512),
Hash256 (getHash256),
Hash160 (getHash160),
CheckSum32 (getCheckSum32),
-- |
-- Module : Haskoin.Crypto.Hash
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- Hashing functions and corresponding data types. Uses functions from the
-- cryptonite library.
module Haskoin.Crypto.Hash
( -- * Hashes
Hash512 (get),
Hash256 (get),
Hash160 (get),
CheckSum32 (get),
sha512,
sha256,
ripemd160,
@ -31,233 +36,232 @@ module Haskoin.Crypto.Hash (
split512,
join512,
initTaggedHash,
) where
)
where
import Control.DeepSeq
import Crypto.Hash (
Context,
RIPEMD160 (..),
SHA1 (..),
SHA256 (..),
SHA512 (..),
hashInit,
hashUpdates,
hashWith,
)
import Crypto.Hash
import Crypto.MAC.HMAC (HMAC, hmac)
import Data.Binary (Binary (..))
import Data.ByteArray (ByteArrayAccess)
import qualified Data.ByteArray as BA
import Data.ByteArray (ByteArrayAccess, convert)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.ByteString.Short (ShortByteString)
import qualified Data.ByteString.Short as BSS
import qualified Data.Bytes.Get as Get
import qualified Data.Bytes.Put as Put
import Data.ByteString qualified as B
import Data.ByteString.Short (ShortByteString, fromShort, toShort)
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial (Serial (..))
import Data.Either (fromRight)
import Data.Function (on)
import Data.Hashable (Hashable)
import Data.Serialize (Serialize (..))
import Data.String (IsString, fromString)
import Data.String.Conversions (cs)
import Data.Void (Void)
import Data.Word (Word32)
import GHC.Generics (Generic)
import Haskoin.Util
import Haskoin.Util.Helpers
import Haskoin.Util.Marshal
import Text.Read as R
-- | 'Word32' wrapped for type-safe 32-bit checksums.
newtype CheckSum32 = CheckSum32
{ getCheckSum32 :: Word32
}
deriving (Eq, Ord, Serial, Show, Read, Hashable, Generic, NFData)
{ get :: Word32
}
deriving (Eq, Ord, Show, Read, Generic)
deriving newtype (Hashable, NFData)
instance Serial CheckSum32 where
serialize (CheckSum32 c) = putWord32be c
deserialize = CheckSum32 <$> getWord32be
instance Serialize CheckSum32 where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance Binary CheckSum32 where
put = serialize
get = deserialize
put = serialize
get = deserialize
-- | Type for 512-bit hashes.
newtype Hash512 = Hash512 {getHash512 :: ShortByteString}
deriving (Eq, Ord, Hashable, Generic, NFData)
newtype Hash512 = Hash512 {get :: ShortByteString}
deriving (Eq, Ord, Generic)
deriving newtype (Hashable, NFData)
-- | Type for 256-bit hashes.
newtype Hash256 = Hash256 {getHash256 :: ShortByteString}
deriving (Eq, Ord, Hashable, Generic, NFData)
newtype Hash256 = Hash256 {get :: ShortByteString}
deriving (Eq, Ord, Generic)
deriving newtype (Hashable, NFData)
-- | Type for 160-bit hashes.
newtype Hash160 = Hash160 {getHash160 :: ShortByteString}
deriving (Eq, Ord, Hashable, Generic, NFData)
newtype Hash160 = Hash160 {get :: ShortByteString}
deriving (Eq, Ord, Generic)
deriving newtype (Hashable, NFData)
instance Show Hash512 where
showsPrec _ = shows . encodeHex . BSS.fromShort . getHash512
showsPrec _ = shows . encodeHex . fromShort . (.get)
instance Read Hash512 where
readPrec = do
R.String str <- lexP
maybe pfail return $ Hash512 . BSS.toShort <$> decodeHex (cs str)
readPrec = do
R.String str <- lexP
maybe pfail (return . Hash512 . toShort) (decodeHex (cs str))
instance Show Hash256 where
showsPrec _ = shows . encodeHex . BSS.fromShort . getHash256
showsPrec _ = shows . encodeHex . fromShort . (.get)
instance Read Hash256 where
readPrec = do
R.String str <- lexP
maybe pfail return $ Hash256 . BSS.toShort <$> decodeHex (cs str)
readPrec = do
R.String str <- lexP
maybe pfail (return . Hash256 . toShort) (decodeHex (cs str))
instance Show Hash160 where
showsPrec _ = shows . encodeHex . BSS.fromShort . getHash160
showsPrec _ = shows . encodeHex . fromShort . (.get)
instance Read Hash160 where
readPrec = do
R.String str <- lexP
maybe pfail return $ Hash160 . BSS.toShort <$> decodeHex (cs str)
readPrec = do
R.String str <- lexP
maybe pfail (return . Hash160 . toShort) (decodeHex (cs str))
instance IsString Hash512 where
fromString str =
case decodeHex $ cs str of
Nothing -> e
Just bs ->
case BS.length bs of
64 -> Hash512 (BSS.toShort bs)
_ -> e
where
e = error "Could not decode hash from hex string"
fromString str =
case decodeHex $ cs str of
Nothing -> e
Just bs ->
case B.length bs of
64 -> Hash512 (toShort bs)
_ -> e
where
e = error "Could not decode hash from hex string"
instance Serial Hash512 where
deserialize = Hash512 . BSS.toShort <$> Get.getByteString 64
serialize = Put.putByteString . BSS.fromShort . getHash512
deserialize = Hash512 . toShort <$> getByteString 64
serialize = putByteString . fromShort . (.get)
instance Serialize Hash512 where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance Binary Hash512 where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance IsString Hash256 where
fromString str =
case decodeHex $ cs str of
Nothing -> e
Just bs ->
case BS.length bs of
32 -> Hash256 (BSS.toShort bs)
_ -> e
where
e = error "Could not decode hash from hex string"
fromString str =
case decodeHex $ cs str of
Nothing -> e
Just bs ->
case B.length bs of
32 -> Hash256 (toShort bs)
_ -> e
where
e = error "Could not decode hash from hex string"
instance Serial Hash256 where
deserialize = Hash256 . BSS.toShort <$> Get.getByteString 32
serialize = Put.putByteString . BSS.fromShort . getHash256
deserialize = Hash256 . toShort <$> getByteString 32
serialize = putByteString . fromShort . (.get)
instance Serialize Hash256 where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance Binary Hash256 where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance IsString Hash160 where
fromString str =
case decodeHex $ cs str of
Nothing -> e
Just bs ->
case BS.length bs of
20 -> Hash160 (BSS.toShort bs)
_ -> e
where
e = error "Could not decode hash from hex string"
fromString str =
case decodeHex $ cs str of
Nothing -> e
Just bs ->
case B.length bs of
20 -> Hash160 (toShort bs)
_ -> e
where
e = error "Could not decode hash from hex string"
instance Serial Hash160 where
deserialize = Hash160 . BSS.toShort <$> Get.getByteString 20
serialize = Put.putByteString . BSS.fromShort . getHash160
deserialize = Hash160 . toShort <$> getByteString 20
serialize = putByteString . fromShort . (.get)
instance Serialize Hash160 where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance Binary Hash160 where
put = serialize
get = deserialize
put = serialize
get = deserialize
-- | Calculate SHA512 hash.
sha512 :: ByteArrayAccess b => b -> Hash512
sha512 = Hash512 . BSS.toShort . BA.convert . hashWith SHA512
sha512 :: (ByteArrayAccess b) => b -> Hash512
sha512 = Hash512 . toShort . convert . hashWith SHA512
-- | Calculate SHA256 hash.
sha256 :: ByteArrayAccess b => b -> Hash256
sha256 = Hash256 . BSS.toShort . BA.convert . hashWith SHA256
sha256 :: (ByteArrayAccess b) => b -> Hash256
sha256 = Hash256 . toShort . convert . hashWith SHA256
-- | Calculate RIPEMD160 hash.
ripemd160 :: ByteArrayAccess b => b -> Hash160
ripemd160 = Hash160 . BSS.toShort . BA.convert . hashWith RIPEMD160
ripemd160 :: (ByteArrayAccess b) => b -> Hash160
ripemd160 = Hash160 . toShort . convert . hashWith RIPEMD160
-- | Claculate SHA1 hash.
sha1 :: ByteArrayAccess b => b -> Hash160
sha1 = Hash160 . BSS.toShort . BA.convert . hashWith SHA1
sha1 :: (ByteArrayAccess b) => b -> Hash160
sha1 = Hash160 . toShort . convert . hashWith SHA1
-- | Compute two rounds of SHA-256.
doubleSHA256 :: ByteArrayAccess b => b -> Hash256
doubleSHA256 :: (ByteArrayAccess b) => b -> Hash256
doubleSHA256 =
Hash256 . BSS.toShort . BA.convert . hashWith SHA256 . hashWith SHA256
Hash256 . toShort . convert . hashWith SHA256 . hashWith SHA256
-- | Compute SHA-256 followed by RIPMED-160.
addressHash :: ByteArrayAccess b => b -> Hash160
addressHash :: (ByteArrayAccess b) => b -> Hash160
addressHash =
Hash160 . BSS.toShort . BA.convert . hashWith RIPEMD160 . hashWith SHA256
Hash160 . toShort . convert . hashWith RIPEMD160 . hashWith SHA256
{- CheckSum -}
-- | Computes a 32 bit checksum.
checkSum32 :: ByteArrayAccess b => b -> CheckSum32
checkSum32 :: (ByteArrayAccess b) => b -> CheckSum32
checkSum32 =
fromRight (error "Could not decode bytes as CheckSum32")
. Get.runGetS deserialize
. BS.take 4
. BA.convert
. hashWith SHA256
. hashWith SHA256
fromRight (error "Could not decode bytes as CheckSum32")
. runGetS deserialize
. B.take 4
. convert
. hashWith SHA256
. hashWith SHA256
{- HMAC -}
-- | Computes HMAC over SHA-512.
hmac512 :: ByteString -> ByteString -> Hash512
hmac512 key msg =
Hash512 $ BSS.toShort $ BA.convert (hmac key msg :: HMAC SHA512)
Hash512 $ toShort $ convert (hmac key msg :: HMAC SHA512)
-- | Computes HMAC over SHA-256.
hmac256 :: (ByteArrayAccess k, ByteArrayAccess m) => k -> m -> Hash256
hmac256 key msg =
Hash256 $ BSS.toShort $ BA.convert (hmac key msg :: HMAC SHA256)
Hash256 $ toShort $ convert (hmac key msg :: HMAC SHA256)
-- | Split a 'Hash512' into a pair of 'Hash256'.
split512 :: Hash512 -> (Hash256, Hash256)
split512 h =
(Hash256 (BSS.toShort a), Hash256 (BSS.toShort b))
(Hash256 (toShort a), Hash256 (toShort b))
where
(a, b) = BS.splitAt 32 . BSS.fromShort $ getHash512 h
(a, b) = B.splitAt 32 $ fromShort h.get
-- | Join a pair of 'Hash256' into a 'Hash512'.
join512 :: (Hash256, Hash256) -> Hash512
join512 (a, b) =
Hash512
. BSS.toShort
$ BSS.fromShort (getHash256 a) `BS.append` BSS.fromShort (getHash256 b)
join512 (a, b) = Hash512 (toShort (a.get `app` b.get))
where
app = B.append `on` fromShort
{- | Initialize tagged hash specified in BIP340
@since 0.21.0
-}
-- | Initialize tagged hash specified in BIP340
--
-- @since 0.21.0
initTaggedHash ::
-- | Hash tag
ByteString ->
Context SHA256
-- | Hash tag
ByteString ->
Context SHA256
initTaggedHash tag =
(`hashUpdates` [hashedTag, hashedTag]) $
hashInit @SHA256
(`hashUpdates` [hashedTag, hashedTag]) $
hashInit @SHA256
where
hashedTag = hashWith SHA256 tag

20
src/Haskoin/Crypto/Keys.hs Normal file
View 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
View 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
View File

File diff suppressed because it is too large Load Diff

88
src/Haskoin/Crypto/Keys/Extended/Internal.hs Normal file
View 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
View File

File diff suppressed because it is too large Load Diff

125
src/Haskoin/Crypto/Signature.hs
View File

@ -1,93 +1,106 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
Module : Haskoin.Crypto.Signature
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
ECDSA signatures using secp256k1 curve. Uses functions from upstream secp256k1
library.
-}
module Haskoin.Crypto.Signature (
-- * Signatures
putSig,
getSig,
-- |
-- Module : Haskoin.Crypto.Signature
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- ECDSA signatures using secp256k1 curve. Uses functions from upstream secp256k1
-- library.
module Haskoin.Crypto.Signature
( -- * Signatures
signHash,
verifyHashSig,
isCanonicalHalfOrder,
decodeStrictSig,
exportSig,
) where
)
where
import Control.Monad (guard, unless, when)
import Crypto.Secp256k1
import Data.Aeson
import Data.Aeson.Encoding
import Data.Binary (Binary (..))
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.ByteString qualified as B
import Data.ByteString.Lazy qualified as L
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import Data.Maybe (fromMaybe, isNothing)
import Data.Serialize (Serialize (..))
import Data.Text qualified as T
import Haskoin.Crypto.Hash
import Haskoin.Util.Helpers
import Haskoin.Util.Marshal
import Numeric (showHex)
-- | Convert 256-bit hash into a 'Msg' for signing or verification.
hashToMsg :: Hash256 -> Msg
hashToMsg =
fromMaybe e . msg . runPutS . serialize
fromMaybe e . msg . runPutS . serialize
where
e = error "Could not convert 32-byte hash to secp256k1 message"
-- | Sign a 256-bit hash using secp256k1 elliptic curve.
signHash :: SecKey -> Hash256 -> Sig
signHash k = signMsg k . hashToMsg
signHash :: Ctx -> SecKey -> Hash256 -> Sig
signHash ctx k = signMsg ctx k . hashToMsg
-- | Verify an ECDSA signature for a 256-bit hash.
verifyHashSig :: Hash256 -> Sig -> PubKey -> Bool
verifyHashSig h s p = verifySig p norm (hashToMsg h)
verifyHashSig :: Ctx -> Hash256 -> Sig -> PubKey -> Bool
verifyHashSig ctx h s p = verifySig ctx p norm (hashToMsg h)
where
norm = fromMaybe s (normalizeSig s)
norm = fromMaybe s (normalizeSig ctx s)
-- | Deserialize an ECDSA signature as commonly encoded in Bitcoin.
getSig :: MonadGet m => m Sig
getSig = do
l <-
lookAhead $ do
t <- getWord8
-- 0x30 is DER sequence type
unless (t == 0x30) $
fail $
"Bad DER identifier byte 0x" ++ showHex t ". Expecting 0x30"
l <- getWord8
when (l == 0x00) $ fail "Indeterminate form unsupported"
when (l >= 0x80) $ fail "Multi-octect length not supported"
return $ fromIntegral l
instance Marshal Ctx Sig where
marshalGet ctx = do
l <- lookAhead $ do
t <- getWord8
-- 0x30 is DER sequence type
unless (t == 0x30) $
fail $
"Bad DER identifier byte 0x" ++ showHex t ". Expecting 0x30"
l <- getWord8
when (l == 0x00) $ fail "Indeterminate form unsupported"
when (l >= 0x80) $ fail "Multi-octect length not supported"
return $ fromIntegral l
bs <- getByteString $ l + 2
case decodeStrictSig bs of
Just s -> return s
Nothing -> fail "Invalid signature"
case decodeStrictSig ctx bs of
Just s -> return s
Nothing -> fail "Invalid signature"
-- | Serialize an ECDSA signature for Bitcoin use.
putSig :: MonadPut m => Sig -> m ()
putSig s = putByteString $ exportSig s
marshalPut ctx s = putByteString $ exportSig ctx s
instance MarshalJSON Ctx Sig where
marshalValue ctx = String . encodeHex . exportSig ctx
marshalEncoding ctx = hexEncoding . L.fromStrict . exportSig ctx
unmarshalValue ctx =
withText "Sig" $ \t ->
case decodeHex t >>= importSig ctx of
Nothing -> fail $ "Could not decode signature: " <> T.unpack t
Just s -> return s
-- | Is canonical half order.
isCanonicalHalfOrder :: Sig -> Bool
isCanonicalHalfOrder = isNothing . normalizeSig
isCanonicalHalfOrder :: Ctx -> Sig -> Bool
isCanonicalHalfOrder ctx = isNothing . normalizeSig ctx
-- | Decode signature strictly.
decodeStrictSig :: ByteString -> Maybe Sig
decodeStrictSig bs = do
g <- importSig bs
-- <http://www.secg.org/sec1-v2.pdf Section 4.1.4>
-- 4.1.4.1 (r and s can not be zero)
let compact = exportCompactSig g
let zero = BS.replicate 32 0
guard $ BS.take 32 (getCompactSig compact) /= zero
guard $ BS.take 32 (BS.drop 32 (getCompactSig compact)) /= zero
guard $ isCanonicalHalfOrder g
return g
decodeStrictSig :: Ctx -> ByteString -> Maybe Sig
decodeStrictSig ctx bs = do
g <- importSig ctx bs
-- <http://www.secg.org/sec1-v2.pdf Section 4.1.4>
-- 4.1.4.1 (r and s can not be zero)
let compact = exportCompactSig ctx g
let zero = B.replicate 32 0
guard $ B.take 32 compact.get /= zero
guard $ (B.take 32 . B.drop 32) compact.get /= zero
guard $ isCanonicalHalfOrder ctx g
return g

93
src/Haskoin/Data.hs
View File

@ -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)

20
src/Haskoin/Keys.hs
View File

@ -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

190
src/Haskoin/Keys/Common.hs
View File

@ -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

1084
src/Haskoin/Keys/Extended.hs
View File

File diff suppressed because it is too large Load Diff

83
src/Haskoin/Keys/Extended/Internal.hs
View File

@ -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

2233
src/Haskoin/Keys/Mnemonic.hs
View File

File diff suppressed because it is too large Load Diff

32
src/Haskoin/Network.hs
View File

@ -1,21 +1,25 @@
{- |
Module : Haskoin.Network
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
This module provides basic types used for the Bitcoin networking protocol
together with 'Data.Serialize' instances for efficiently serializing and
de-serializing them.
-}
module Haskoin.Network (
-- |
-- Module : Haskoin.Network
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- This module provides basic types used for the Bitcoin networking protocol
-- together with 'Data.Serialize' instances for efficiently serializing and
-- de-serializing them.
module Haskoin.Network
( module Data,
module Constants,
module Common,
module Message,
module Bloom,
) where
)
where
import Haskoin.Network.Bloom as Bloom
import Haskoin.Network.Common as Common
import Haskoin.Network.Constants as Constants
import Haskoin.Network.Data as Data
import Haskoin.Network.Message as Message

399
src/Haskoin/Network/Bloom.hs
View File

@ -1,21 +1,27 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoFieldSelectors #-}
{- |
Module : Haskoin.Network.Bloom
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
Bloom filters are used to reduce data transfer when synchronizing thin cients.
When bloom filters are used a client will obtain filtered blocks that only
contain transactions that pass the bloom filter. Transactions announced via inv
messages also pass the filter.
-}
module Haskoin.Network.Bloom (
-- * Bloom Filters
-- |
-- Module : Haskoin.Network.Bloom
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- Bloom filters are used to reduce data transfer when synchronizing thin cients.
-- When bloom filters are used a client will obtain filtered blocks that only
-- contain transactions that pass the bloom filter. Transactions announced via inv
-- messages also pass the filter.
module Haskoin.Network.Bloom
( -- * Bloom Filters
BloomFlags (..),
BloomFilter (..),
FilterLoad (..),
@ -28,27 +34,30 @@ module Haskoin.Network.Bloom (
isBloomFull,
acceptsFilters,
bloomRelevantUpdate,
) where
)
where
import Control.DeepSeq
import Control.Monad (forM_, replicateM)
import Crypto.Secp256k1 (Ctx)
import Data.Binary (Binary (..))
import Data.Bits
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.ByteString qualified as BS
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import qualified Data.Foldable as F
import Data.Foldable qualified as F
import Data.Hash.Murmur (murmur3)
import Data.List (foldl')
import qualified Data.Sequence as S
import Data.Sequence qualified as S
import Data.Serialize (Serialize (..))
import Data.Word
import GHC.Generics (Generic)
import Haskoin.Network.Common
import Haskoin.Script.Standard
import Haskoin.Transaction.Common
import Haskoin.Util.Marshal
-- | 20,000 items with fp rate < 0.1% or 10,000 items and <0.0001%
maxBloomSize :: Int
@ -66,139 +75,137 @@ ln2 = 0.6931471805599453094172321214581765680755001343602552
bitMask :: [Word8]
bitMask = [0x01, 0x02, 0x04, 0x08, 0x10, 0x20, 0x40, 0x80]
{- | The bloom flags are used to tell the remote peer how to auto-update
the provided bloom filter.
-}
-- | The bloom flags are used to tell the remote peer how to auto-update
-- the provided bloom filter.
data BloomFlags
= -- | never update
BloomUpdateNone
| -- | auto-update on all outputs
BloomUpdateAll
| -- | auto-update on pay-to-pubkey or pay-to-multisig (default)
BloomUpdateP2PubKeyOnly
deriving (Eq, Show, Read, Generic, NFData)
= -- | never update
BloomUpdateNone
| -- | auto-update on all outputs
BloomUpdateAll
| -- | auto-update on pay-to-pubkey or pay-to-multisig (default)
BloomUpdateP2PubKeyOnly
deriving (Eq, Show, Read, Generic, NFData)
instance Serial BloomFlags where
deserialize = go =<< getWord8
where
go 0 = return BloomUpdateNone
go 1 = return BloomUpdateAll
go 2 = return BloomUpdateP2PubKeyOnly
go _ = fail "BloomFlags get: Invalid bloom flag"
deserialize = go =<< getWord8
where
go 0 = return BloomUpdateNone
go 1 = return BloomUpdateAll
go 2 = return BloomUpdateP2PubKeyOnly
go _ = fail "BloomFlags get: Invalid bloom flag"
serialize f = putWord8 $ case f of
BloomUpdateNone -> 0
BloomUpdateAll -> 1
BloomUpdateP2PubKeyOnly -> 2
serialize f = putWord8 $ case f of
BloomUpdateNone -> 0
BloomUpdateAll -> 1
BloomUpdateP2PubKeyOnly -> 2
instance Binary BloomFlags where
get = deserialize
put = serialize
get = deserialize
put = serialize
instance Serialize BloomFlags where
get = deserialize
put = serialize
get = deserialize
put = serialize
{- | A bloom filter is a probabilistic data structure that SPV clients send to
other peers to filter the set of transactions received from them. Bloom
filters can have false positives but not false negatives. Some transactions
that pass the filter may not be relevant to the receiving peer. By
controlling the false positive rate, SPV nodes can trade off bandwidth
versus privacy.
-}
-- | A bloom filter is a probabilistic data structure that SPV clients send to
-- other peers to filter the set of transactions received from them. Bloom
-- filters can have false positives but not false negatives. Some transactions
-- that pass the filter may not be relevant to the receiving peer. By
-- controlling the false positive rate, SPV nodes can trade off bandwidth
-- versus privacy.
data BloomFilter = BloomFilter
{ -- | bloom filter data
bloomData :: !(S.Seq Word8)
, -- | number of hash functions for this filter
bloomHashFuncs :: !Word32
, -- | hash function random nonce
bloomTweak :: !Word32
, -- | bloom filter auto-update flags
bloomFlags :: !BloomFlags
}
deriving (Eq, Show, Read, Generic, NFData)
{ -- | bloom filter data
array :: !(S.Seq Word8),
-- | number of hash functions for this filter
functions :: !Word32,
-- | hash function random nonce
tweak :: !Word32,
-- | bloom filter auto-update flags
flags :: !BloomFlags
}
deriving (Eq, Show, Read, Generic, NFData)
instance Serial BloomFilter where
deserialize =
BloomFilter
<$> (S.fromList <$> (readDat =<< deserialize))
<*> getWord32le
<*> getWord32le
<*> deserialize
where
readDat (VarInt len) = replicateM (fromIntegral len) getWord8
deserialize =
BloomFilter
<$> (S.fromList <$> (readDat =<< deserialize))
<*> getWord32le
<*> getWord32le
<*> deserialize
where
readDat (VarInt len) = replicateM (fromIntegral len) getWord8
serialize (BloomFilter dat hashFuncs tweak flags) = do
putVarInt $ S.length dat
forM_ (F.toList dat) putWord8
putWord32le hashFuncs
putWord32le tweak
serialize flags
serialize BloomFilter {..} = do
putVarInt $ S.length array
mapM_ putWord8 (F.toList array)
putWord32le functions
putWord32le tweak
serialize flags
instance Binary BloomFilter where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance Serialize BloomFilter where
put = serialize
get = deserialize
put = serialize
get = deserialize
-- | Set a new bloom filter on the peer connection.
newtype FilterLoad = FilterLoad {filterLoadBloomFilter :: BloomFilter}
deriving (Eq, Show, Read, Generic, NFData)
newtype FilterLoad = FilterLoad {filter :: BloomFilter}
deriving (Eq, Show, Read, Generic)
deriving newtype (NFData)
instance Serial FilterLoad where
deserialize = FilterLoad <$> deserialize
serialize (FilterLoad f) = serialize f
deserialize = FilterLoad <$> deserialize
serialize (FilterLoad f) = serialize f
instance Binary FilterLoad where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance Serialize FilterLoad where
put = serialize
get = deserialize
put = serialize
get = deserialize
{- | Add the given data element to the connections current filter without
requiring a completely new one to be set.
-}
newtype FilterAdd = FilterAdd {getFilterData :: ByteString}
deriving (Eq, Show, Read, Generic, NFData)
-- | Add the given data element to the connections current filter without
-- requiring a completely new one to be set.
newtype FilterAdd = FilterAdd {get :: ByteString}
deriving (Eq, Show, Read, Generic)
deriving newtype (NFData)
instance Serial FilterAdd where
deserialize = do
(VarInt len) <- deserialize
dat <- getByteString $ fromIntegral len
return $ FilterAdd dat
deserialize = do
(VarInt len) <- deserialize
dat <- getByteString $ fromIntegral len
return $ FilterAdd dat
serialize (FilterAdd bs) = do
putVarInt $ BS.length bs
putByteString bs
serialize (FilterAdd bs) = do
putVarInt $ BS.length bs
putByteString bs
instance Binary FilterAdd where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance Serialize FilterAdd where
put = serialize
get = deserialize
put = serialize
get = deserialize
{- | Build a bloom filter that will provide the given false positive rate when
the given number of elements have been inserted.
-}
-- | Build a bloom filter that will provide the given false positive rate when
-- the given number of elements have been inserted.
bloomCreate ::
-- | number of elements
Int ->
-- | false positive rate
Double ->
-- | random nonce (tweak) for the hash function
Word32 ->
-- | bloom filter flags
BloomFlags ->
-- | bloom filter
BloomFilter
-- | number of elements
Int ->
-- | false positive rate
Double ->
-- | random nonce (tweak) for the hash function
Word32 ->
-- | bloom filter flags
BloomFlags ->
-- | bloom filter
BloomFilter
bloomCreate numElem fpRate =
BloomFilter (S.replicate bloomSize 0) numHashF
BloomFilter (S.replicate bloomSize 0) numHashF
where
-- Bloom filter size in bytes
bloomSize = truncate $ min a b / 8
@ -211,117 +218,127 @@ bloomCreate numElem fpRate =
c = fromIntegral bloomSize * 8 / fromIntegral numElem * ln2
bloomHash :: BloomFilter -> Word32 -> ByteString -> Word32
bloomHash bfilter hashNum bs =
murmur3 seed bs `mod` (fromIntegral (S.length (bloomData bfilter)) * 8)
bloomHash b hashNum bs =
murmur3 seed bs `mod` (fromIntegral (S.length (b.array)) * 8)
where
seed = hashNum * 0xfba4c795 + bloomTweak bfilter
seed = hashNum * 0xfba4c795 + b.tweak
{- | Insert arbitrary data into a bloom filter. Returns the new bloom filter
containing the new data.
-}
-- | Insert arbitrary data into a bloom filter. Returns the new bloom filter
-- containing the new data.
bloomInsert ::
-- | Original bloom filter
BloomFilter ->
-- | New data to insert
ByteString ->
-- | Bloom filter containing the new data
BloomFilter
bloomInsert bfilter bs
| isBloomFull bfilter = bfilter
| otherwise = bfilter{bloomData = newData}
-- | Original bloom filter
BloomFilter ->
-- | New data to insert
ByteString ->
-- | Bloom filter containing the new data
BloomFilter
bloomInsert b bs
| isBloomFull b = b
| otherwise = b {array = dat}
where
idxs = map (\i -> bloomHash bfilter i bs) [0 .. bloomHashFuncs bfilter - 1]
idxs = map (\i -> bloomHash b i bs) [0 .. b.functions - 1]
upd s i =
S.adjust
(.|. bitMask !! fromIntegral (7 .&. i))
(fromIntegral $ i `shiftR` 3)
s
newData = foldl upd (bloomData bfilter) idxs
S.adjust
(.|. bitMask !! fromIntegral (7 .&. i))
(fromIntegral $ i `shiftR` 3)
s
dat = foldl upd b.array idxs
{- | Tests if some arbitrary data matches the filter. This can be either because
the data was inserted into the filter or because it is a false positive.
-}
-- | Tests if some arbitrary data matches the filter. This can be either because
-- the data was inserted into the filter or because it is a false positive.
bloomContains ::
-- | Bloom filter
BloomFilter ->
-- | Data that will be checked against the given bloom filter
ByteString ->
-- | Returns True if the data matches the filter
Bool
bloomContains bfilter bs
| isBloomFull bfilter = True
| isBloomEmpty bfilter = False
| otherwise = all isSet idxs
-- | Bloom filter
BloomFilter ->
-- | Data that will be checked against the given bloom filter
ByteString ->
-- | Returns True if the data matches the filter
Bool
bloomContains b bs
| isBloomFull b = True
| isBloomEmpty b = False
| otherwise = all isSet idxs
where
s = bloomData bfilter
idxs = map (\i -> bloomHash bfilter i bs) [0 .. bloomHashFuncs bfilter - 1]
s = b.array
idxs = map (\i -> bloomHash b i bs) [0 .. b.functions - 1]
isSet i =
S.index s (fromIntegral $ i `shiftR` 3)
.&. (bitMask !! fromIntegral (7 .&. i)) /= 0
S.index s (fromIntegral $ i `shiftR` 3)
.&. (bitMask !! fromIntegral (7 .&. i))
/= 0
{- | Checks if any of the outputs of a tx is in the current bloom filter.
If it is, add the txid and vout as an outpoint (i.e. so that
a future tx that spends the output won't be missed).
-}
-- | Checks if any of the outputs of a tx is in the current bloom filter.
-- If it is, add the txid and vout as an outpoint (i.e. so that
-- a future tx that spends the output won't be missed).
bloomRelevantUpdate ::
-- | Bloom filter
BloomFilter ->
-- | Tx that may (or may not) have relevant outputs
Tx ->
-- | Returns an updated bloom filter adding relevant output
Maybe BloomFilter
bloomRelevantUpdate bfilter tx
| isBloomFull bfilter || isBloomEmpty bfilter = Nothing
| bloomFlags bfilter == BloomUpdateNone = Nothing
| not (null matchOuts) = Just $ foldl' addRelevant bfilter matchOuts
| otherwise = Nothing
Ctx ->
-- | Bloom filter
BloomFilter ->
-- | Tx that may (or may not) have relevant outputs
Tx ->
-- | Returns an updated bloom filter adding relevant output
Maybe BloomFilter
bloomRelevantUpdate ctx b tx
| isBloomFull b || isBloomEmpty b = Nothing
| b.flags == BloomUpdateNone = Nothing
| not (null matchOuts) = Just $ foldl' addRelevant b matchOuts
| otherwise = Nothing
where
-- TxHash if we end up inserting an outpoint
h = txHash tx
-- Decode the scriptOutpus and add vOuts in case we make them outpoints
decodedOutputScripts = traverse (decodeOutputBS . scriptOutput) $ txOut tx
decodedOutputScripts = traverse (unmarshal ctx . (.script)) tx.outputs
err = error "Error Decoding output script"
idxOutputScripts = either (const err) (zip [0 ..]) decodedOutputScripts
-- Check if any txOuts were contained in the bloom filter
matchFilter =
filter (\(_, op) -> bloomContains bfilter $ encodeScriptOut op)
filter (\(_, op) -> any (bloomContains b) (encodeScriptOut op))
matchOuts = matchFilter idxOutputScripts
addRelevant :: BloomFilter -> (Word32, ScriptOutput) -> BloomFilter
addRelevant bf (id', scriptOut) =
case (bloomFlags bfilter, scriptType) of
-- We filtered out BloomUpdateNone so we insert any PayPk or PayMulSig
case (b.flags, scriptType) of
-- We filtered out BloomUpdateNone so we insert any PayPk or PayMulSig
(_, True) -> bloomInsert bf outpoint
(BloomUpdateAll, _) -> bloomInsert bf outpoint
_ -> error "Error Updating Bloom Filter with relevant outpoint"
(_, True) -> bloomInsert bf outpoint
(BloomUpdateAll, _) -> bloomInsert bf outpoint
_ -> error "Error Updating Bloom Filter with relevant outpoint"
where
outpoint = runPutS $ serialize $ OutPoint{outPointHash = h, outPointIndex = id'}
outpoint = runPutS $ serialize $ OutPoint {hash = h, index = id'}
scriptType = (\s -> isPayPK s || isPayMulSig s) scriptOut
-- Encodes a scriptOutput so it can be checked agains the Bloom Filter
encodeScriptOut :: ScriptOutput -> ByteString
encodeScriptOut (PayMulSig outputMuSig _) = runPutS $ serialize outputMuSig
encodeScriptOut (PayWitnessScriptHash scriptHash) = runPutS $ serialize scriptHash
encodeScriptOut (DataCarrier getOutputDat) = runPutS $ serialize getOutputDat
encodeScriptOut outputHash = (runPutS . serialize . getOutputHash) outputHash
encodeScriptOut :: ScriptOutput -> [ByteString]
encodeScriptOut (PayPK pk) =
return $ marshal ctx pk
encodeScriptOut (PayPKHash ph) =
return . runPutS $ serialize ph
encodeScriptOut (PayMulSig outputMuSig _) =
map (marshal ctx) outputMuSig
encodeScriptOut (PayScriptHash sh) =
return . runPutS $ serialize sh
encodeScriptOut (PayWitnessPKHash ph) =
return . runPutS $ serialize ph
encodeScriptOut (PayWitnessScriptHash sh) =
return . runPutS $ serialize sh
encodeScriptOut (PayWitness _ wd) =
return wd
encodeScriptOut (DataCarrier dat) =
return dat
-- | Returns True if the filter is empty (all bytes set to 0x00)
isBloomEmpty :: BloomFilter -> Bool
isBloomEmpty bfilter = all (== 0x00) $ F.toList $ bloomData bfilter
isBloomEmpty b = all (== 0x00) $ F.toList b.array
-- | Returns True if the filter is full (all bytes set to 0xff)
isBloomFull :: BloomFilter -> Bool
isBloomFull bfilter = all (== 0xff) $ F.toList $ bloomData bfilter
isBloomFull b = all (== 0xff) $ F.toList b.array
-- | Tests if a given bloom filter is valid.
isBloomValid ::
-- | Bloom filter to test
BloomFilter ->
-- | True if the given filter is valid
Bool
isBloomValid bfilter =
S.length (bloomData bfilter) <= maxBloomSize
&& bloomHashFuncs bfilter <= maxHashFuncs
-- | Bloom filter to test
BloomFilter ->
-- | True if the given filter is valid
Bool
isBloomValid BloomFilter {..} =
S.length array <= maxBloomSize && functions <= maxHashFuncs
-- | Does the peer with these version services accept bloom filters?
acceptsFilters :: Word64 -> Bool

1005
src/Haskoin/Network/Common.hs
View File

File diff suppressed because it is too large Load Diff

582
src/Haskoin/Network/Constants.hs Normal file
View 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
View 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)

306
src/Haskoin/Network/Message.hs
View File

@ -1,30 +1,34 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE NoFieldSelectors #-}
{- |
Module : Haskoin.Network.Message
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
Peer-to-peer network message serialization.
-}
module Haskoin.Network.Message (
-- * Network Message
-- |
-- Module : Haskoin.Network.Message
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- Peer-to-peer network message serialization.
module Haskoin.Network.Message
( -- * Network Message
Message (..),
MessageHeader (..),
msgType,
putMessage,
getMessage,
) where
)
where
import Control.DeepSeq
import Control.Monad (unless)
import Data.Binary (Binary (..))
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.ByteString qualified as B
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
@ -34,80 +38,78 @@ import GHC.Generics (Generic)
import Haskoin.Block.Common
import Haskoin.Block.Merkle
import Haskoin.Crypto.Hash
import Haskoin.Data
import Haskoin.Network.Bloom
import Haskoin.Network.Common
import Haskoin.Network.Data
import Haskoin.Transaction.Common
{- | Data type representing the header of a 'Message'. All messages sent between
nodes contain a message header.
-}
-- | Data type representing the header of a 'Message'. All messages sent between
-- nodes contain a message header.
data MessageHeader = MessageHeader
{ -- | magic bytes identify network
headMagic :: !Word32
, -- | message type
headCmd :: !MessageCommand
, -- | length of payload
headPayloadSize :: !Word32
, -- | checksum of payload
headChecksum :: !CheckSum32
}
deriving (Eq, Show, Generic, NFData)
{ -- | magic bytes identify network
magic :: !Word32,
-- | message type
cmd :: !MessageCommand,
-- | length of payload
size :: !Word32,
-- | checksum of payload
checksum :: !CheckSum32
}
deriving (Eq, Show, Generic, NFData)
instance Serial MessageHeader where
deserialize =
MessageHeader
<$> getWord32be
<*> deserialize
<*> getWord32le
<*> deserialize
deserialize =
MessageHeader
<$> getWord32be
<*> deserialize
<*> getWord32le
<*> deserialize
serialize (MessageHeader m c l chk) = do
putWord32be m
serialize c
putWord32le l
serialize chk
serialize (MessageHeader m c l chk) = do
putWord32be m
serialize c
putWord32le l
serialize chk
instance Binary MessageHeader where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance Serialize MessageHeader where
put = serialize
get = deserialize
put = serialize
get = deserialize
{- | The 'Message' type is used to identify all the valid messages that can be
sent between bitcoin peers. Only values of type 'Message' will be accepted
by other bitcoin peers as bitcoin protocol messages need to be correctly
serialized with message headers. Serializing a 'Message' value will
include the 'MessageHeader' with the correct checksum value automatically.
No need to add the 'MessageHeader' separately.
-}
-- | The 'Message' type is used to identify all the valid messages that can be
-- sent between bitcoin peers. Only values of type 'Message' will be accepted
-- by other bitcoin peers as bitcoin protocol messages need to be correctly
-- serialized with message headers. Serializing a 'Message' value will
-- include the 'MessageHeader' with the correct checksum value automatically.
-- No need to add the 'MessageHeader' separately.
data Message
= MVersion !Version
| MVerAck
| MAddr !Addr
| MInv !Inv
| MGetData !GetData
| MNotFound !NotFound
| MGetBlocks !GetBlocks
| MGetHeaders !GetHeaders
| MTx !Tx
| MBlock !Block
| MMerkleBlock !MerkleBlock
| MHeaders !Headers
| MGetAddr
| MFilterLoad !FilterLoad
| MFilterAdd !FilterAdd
| MFilterClear
| MPing !Ping
| MPong !Pong
| MAlert !Alert
| MMempool
| MReject !Reject
| MSendHeaders
| MOther !ByteString !ByteString
deriving (Eq, Show, Generic, NFData)
= MVersion !Version
| MVerAck
| MAddr !Addr
| MInv !Inv
| MGetData !GetData
| MNotFound !NotFound
| MGetBlocks !GetBlocks
| MGetHeaders !GetHeaders
| MTx !Tx
| MBlock !Block
| MMerkleBlock !MerkleBlock
| MHeaders !Headers
| MGetAddr
| MFilterLoad !FilterLoad
| MFilterAdd !FilterAdd
| MFilterClear
| MPing !Ping
| MPong !Pong
| MAlert !Alert
| MMempool
| MReject !Reject
| MSendHeaders
| MOther !ByteString !ByteString
deriving (Eq, Show, Generic, NFData)
-- | Get 'MessageCommand' assocated with a message.
msgType :: Message -> MessageCommand
@ -136,85 +138,87 @@ msgType MGetAddr = MCGetAddr
msgType (MOther c _) = MCOther c
-- | Deserializer for network messages.
getMessage :: MonadGet m => Network -> m Message
getMessage :: (MonadGet m) => Network -> m Message
getMessage net = do
(MessageHeader mgc cmd len chk) <- deserialize
bs <- lookAhead $ getByteString $ fromIntegral len
unless
(mgc == getNetworkMagic net)
(fail $ "get: Invalid network magic bytes: " ++ show mgc)
unless
(checkSum32 bs == chk)
(fail $ "get: Invalid message checksum: " ++ show chk)
if len > 0
then do
bs <- ensure (fromIntegral len)
let f = case cmd of
MCVersion -> MVersion <$> deserialize
MCAddr -> MAddr <$> deserialize
MCInv -> MInv <$> deserialize
MCGetData -> MGetData <$> deserialize
MCNotFound -> MNotFound <$> deserialize
MCGetBlocks -> MGetBlocks <$> deserialize
MCGetHeaders -> MGetHeaders <$> deserialize
MCTx -> MTx <$> deserialize
MCBlock -> MBlock <$> deserialize
MCMerkleBlock -> MMerkleBlock <$> deserialize
MCHeaders -> MHeaders <$> deserialize
MCFilterLoad -> MFilterLoad <$> deserialize
MCFilterAdd -> MFilterAdd <$> deserialize
MCPing -> MPing <$> deserialize
MCPong -> MPong <$> deserialize
MCAlert -> MAlert <$> deserialize
MCReject -> MReject <$> deserialize
MCOther c -> MOther c <$> getByteString (fromIntegral len)
_ ->
fail $
"get: command " ++ show cmd
++ " should not carry a payload"
either fail return (runGetS f bs)
else case cmd of
MCGetAddr -> return MGetAddr
MCVerAck -> return MVerAck
MCFilterClear -> return MFilterClear
MCMempool -> return MMempool
MCSendHeaders -> return MSendHeaders
MCOther c -> return (MOther c BS.empty)
(MessageHeader mgc cmd len chk) <- deserialize
bs <- lookAhead $ getByteString $ fromIntegral len
unless
(mgc == net.magic)
(fail $ "get: Invalid network magic bytes: " ++ show mgc)
unless
(checkSum32 bs == chk)
(fail $ "get: Invalid message checksum: " ++ show chk)
if len > 0
then do
bs <- ensure (fromIntegral len)
let f = case cmd of
MCVersion -> MVersion <$> deserialize
MCAddr -> MAddr <$> deserialize
MCInv -> MInv <$> deserialize
MCGetData -> MGetData <$> deserialize
MCNotFound -> MNotFound <$> deserialize
MCGetBlocks -> MGetBlocks <$> deserialize
MCGetHeaders -> MGetHeaders <$> deserialize
MCTx -> MTx <$> deserialize
MCBlock -> MBlock <$> deserialize
MCMerkleBlock -> MMerkleBlock <$> deserialize
MCHeaders -> MHeaders <$> deserialize
MCFilterLoad -> MFilterLoad <$> deserialize
MCFilterAdd -> MFilterAdd <$> deserialize
MCPing -> MPing <$> deserialize
MCPong -> MPong <$> deserialize
MCAlert -> MAlert <$> deserialize
MCReject -> MReject <$> deserialize
MCOther c -> MOther c <$> getByteString (fromIntegral len)
_ ->
fail $
"get: command " ++ show cmd
++ " is expected to carry a payload"
fail $
"get: command "
++ show cmd
++ " should not carry a payload"
either fail return (runGetS f bs)
else case cmd of
MCGetAddr -> return MGetAddr
MCVerAck -> return MVerAck
MCFilterClear -> return MFilterClear
MCMempool -> return MMempool
MCSendHeaders -> return MSendHeaders
MCOther c -> return (MOther c B.empty)
_ ->
fail $
"get: command "
++ show cmd
++ " is expected to carry a payload"
-- | Serializer for network messages.
putMessage :: MonadPut m => Network -> Message -> m ()
putMessage :: (MonadPut m) => Network -> Message -> m ()
putMessage net msg = do
let (cmd, payload) =
case msg of
MVersion m -> (MCVersion, runPutS $ serialize m)
MVerAck -> (MCVerAck, BS.empty)
MAddr m -> (MCAddr, runPutS $ serialize m)
MInv m -> (MCInv, runPutS $ serialize m)
MGetData m -> (MCGetData, runPutS $ serialize m)
MNotFound m -> (MCNotFound, runPutS $ serialize m)
MGetBlocks m -> (MCGetBlocks, runPutS $ serialize m)
MGetHeaders m -> (MCGetHeaders, runPutS $ serialize m)
MTx m -> (MCTx, runPutS $ serialize m)
MBlock m -> (MCBlock, runPutS $ serialize m)
MMerkleBlock m -> (MCMerkleBlock, runPutS $ serialize m)
MHeaders m -> (MCHeaders, runPutS $ serialize m)
MGetAddr -> (MCGetAddr, BS.empty)
MFilterLoad m -> (MCFilterLoad, runPutS $ serialize m)
MFilterAdd m -> (MCFilterAdd, runPutS $ serialize m)
MFilterClear -> (MCFilterClear, BS.empty)
MPing m -> (MCPing, runPutS $ serialize m)
MPong m -> (MCPong, runPutS $ serialize m)
MAlert m -> (MCAlert, runPutS $ serialize m)
MMempool -> (MCMempool, BS.empty)
MReject m -> (MCReject, runPutS $ serialize m)
MSendHeaders -> (MCSendHeaders, BS.empty)
MOther c p -> (MCOther c, p)
chk = checkSum32 payload
len = fromIntegral $ BS.length payload
header = MessageHeader (getNetworkMagic net) cmd len chk
serialize header
putByteString payload
let (cmd, payload) =
case msg of
MVersion m -> (MCVersion, runPutS $ serialize m)
MVerAck -> (MCVerAck, B.empty)
MAddr m -> (MCAddr, runPutS $ serialize m)
MInv m -> (MCInv, runPutS $ serialize m)
MGetData m -> (MCGetData, runPutS $ serialize m)
MNotFound m -> (MCNotFound, runPutS $ serialize m)
MGetBlocks m -> (MCGetBlocks, runPutS $ serialize m)
MGetHeaders m -> (MCGetHeaders, runPutS $ serialize m)
MTx m -> (MCTx, runPutS $ serialize m)
MBlock m -> (MCBlock, runPutS $ serialize m)
MMerkleBlock m -> (MCMerkleBlock, runPutS $ serialize m)
MHeaders m -> (MCHeaders, runPutS $ serialize m)
MGetAddr -> (MCGetAddr, B.empty)
MFilterLoad m -> (MCFilterLoad, runPutS $ serialize m)
MFilterAdd m -> (MCFilterAdd, runPutS $ serialize m)
MFilterClear -> (MCFilterClear, B.empty)
MPing m -> (MCPing, runPutS $ serialize m)
MPong m -> (MCPong, runPutS $ serialize m)
MAlert m -> (MCAlert, runPutS $ serialize m)
MMempool -> (MCMempool, B.empty)
MReject m -> (MCReject, runPutS $ serialize m)
MSendHeaders -> (MCSendHeaders, B.empty)
MOther c p -> (MCOther c, p)
chk = checkSum32 payload
len = fromIntegral $ B.length payload
header = MessageHeader net.magic cmd len chk
serialize header
putByteString payload

30
src/Haskoin/Script.hs
View File

@ -1,20 +1,20 @@
{- |
Module : Haskoin.Script
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
This module provides functions for parsing and evaluating bitcoin
transaction scripts. Data types are provided for building and
deconstructing all of the standard input and output script types.
-}
module Haskoin.Script (
module Common,
-- |
-- Module : Haskoin.Script
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- This module provides functions for parsing and evaluating bitcoin
-- transaction scripts. Data types are provided for building and
-- deconstructing all of the standard input and output script types.
module Haskoin.Script
( module Common,
module Standard,
module SigHash,
) where
)
where
import Haskoin.Script.Common as Common
import Haskoin.Script.SigHash as SigHash

1031
src/Haskoin/Script/Common.hs
View File

File diff suppressed because it is too large Load Diff

404
src/Haskoin/Script/SigHash.hs
View File

@ -1,27 +1,35 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoFieldSelectors #-}
{- |
Module : Haskoin.Script.SigHash
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
Transaction signatures and related functions.
-}
module Haskoin.Script.SigHash (
-- * Script Signatures
-- |
-- Module : Haskoin.Script.SigHash
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- Transaction signatures and related functions.
module Haskoin.Script.SigHash
( -- * Script Signatures
SigHash (..),
SigHashFlag (..),
sigHashAll,
sigHashNone,
sigHashSingle,
hasAnyoneCanPayFlag,
anyoneCanPay,
hasForkIdFlag,
setAnyoneCanPayFlag,
setAnyoneCanPay,
setForkIdFlag,
isSigHashAll,
isSigHashNone,
@ -33,15 +41,19 @@ module Haskoin.Script.SigHash (
txSigHash,
txSigHashForkId,
TxSignature (..),
encodeTxSig,
decodeTxSig,
) where
encodeTxSig,
)
where
import Control.DeepSeq
import Control.Monad
import qualified Data.Aeson as J
import Crypto.Secp256k1
import Data.Aeson
import Data.Bits
import qualified Data.ByteString as BS
import Data.Bool (bool)
import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
@ -50,82 +62,69 @@ import Data.Maybe
import Data.Scientific
import Data.Word
import GHC.Generics (Generic)
import Haskoin.Crypto
import Haskoin.Crypto.Hash
import Haskoin.Data
import Haskoin.Crypto.Signature
import Haskoin.Network.Common
import Haskoin.Network.Data
import Haskoin.Script.Common
import Haskoin.Transaction.Common
import Haskoin.Util
-- | Constant representing a SIGHASH flag that controls what is being signed.
data SigHashFlag
= -- | sign all outputs
SIGHASH_ALL
| -- | sign no outputs
SIGHASH_NONE
| -- | sign the output index corresponding to the input
SIGHASH_SINGLE
| -- | replay protection for Bitcoin Cash transactions
SIGHASH_FORKID
| -- | new inputs can be added
SIGHASH_ANYONECANPAY
deriving (Eq, Ord, Show, Read, Generic)
= -- | sign all outputs
SIGHASH_ALL
| -- | sign no outputs
SIGHASH_NONE
| -- | sign the output index corresponding to the input
SIGHASH_SINGLE
| -- | replay protection for Bitcoin Cash transactions
SIGHASH_FORKID
| -- | new inputs can be added
SIGHASH_ANYONECANPAY
deriving (Eq, Ord, Show, Read, Generic)
instance NFData SigHashFlag
instance Hashable SigHashFlag
instance Enum SigHashFlag where
fromEnum SIGHASH_ALL = 0x01
fromEnum SIGHASH_NONE = 0x02
fromEnum SIGHASH_SINGLE = 0x03
fromEnum SIGHASH_FORKID = 0x40
fromEnum SIGHASH_ANYONECANPAY = 0x80
toEnum 0x01 = SIGHASH_ALL
toEnum 0x02 = SIGHASH_NONE
toEnum 0x03 = SIGHASH_SINGLE
toEnum 0x40 = SIGHASH_FORKID
toEnum 0x80 = SIGHASH_ANYONECANPAY
toEnum _ = error "Not a valid sighash flag"
fromEnum SIGHASH_ALL = 0x01
fromEnum SIGHASH_NONE = 0x02
fromEnum SIGHASH_SINGLE = 0x03
fromEnum SIGHASH_FORKID = 0x40
fromEnum SIGHASH_ANYONECANPAY = 0x80
toEnum 0x01 = SIGHASH_ALL
toEnum 0x02 = SIGHASH_NONE
toEnum 0x03 = SIGHASH_SINGLE
toEnum 0x40 = SIGHASH_FORKID
toEnum 0x80 = SIGHASH_ANYONECANPAY
toEnum _ = error "Not a valid sighash flag"
{- | Data type representing the different ways a transaction can be signed.
When producing a signature, a hash of the transaction is used as the message
to be signed. The 'SigHash' parameter controls which parts of the
transaction are used or ignored to produce the transaction hash. The idea is
that if some part of a transaction is not used to produce the transaction
hash, then you can change that part of the transaction after producing a
signature without invalidating that signature.
If the 'SIGHASH_ANYONECANPAY' flag is set (true), then only the current input
is signed. Otherwise, all of the inputs of a transaction are signed. The
default value for 'SIGHASH_ANYONECANPAY' is unset (false).
-}
-- | Data type representing the different ways a transaction can be signed.
-- When producing a signature, a hash of the transaction is used as the message
-- to be signed. The 'SigHash' parameter controls which parts of the
-- transaction are used or ignored to produce the transaction hash. The idea is
-- that if some part of a transaction is not used to produce the transaction
-- hash, then you can change that part of the transaction after producing a
-- signature without invalidating that signature.
--
-- If the 'SIGHASH_ANYONECANPAY' flag is set (true), then only the current input
-- is signed. Otherwise, all of the inputs of a transaction are signed. The
-- default value for 'SIGHASH_ANYONECANPAY' is unset (false).
newtype SigHash
= SigHash Word32
deriving
( Eq
, Ord
, Bits
, Enum
, Integral
, Num
, Real
, Show
, Read
, Generic
, Hashable
, NFData
)
= SigHash Word32
deriving (Eq, Ord, Enum, Show, Read, Generic)
deriving newtype (Bits, Integral, Num, Real, Hashable, NFData)
instance J.FromJSON SigHash where
parseJSON =
J.withScientific "sighash" $
maybe mzero (return . SigHash) . toBoundedInteger
instance FromJSON SigHash where
parseJSON =
withScientific "sighash" $
maybe mzero (return . SigHash) . toBoundedInteger
instance J.ToJSON SigHash where
toJSON = J.Number . fromIntegral
toEncoding (SigHash n) = J.toEncoding n
instance ToJSON SigHash where
toJSON = Number . fromIntegral
toEncoding (SigHash n) = toEncoding n
-- | SIGHASH_NONE as a byte.
sigHashNone :: SigHash
@ -152,16 +151,16 @@ setForkIdFlag :: SigHash -> SigHash
setForkIdFlag = (.|. sigHashForkId)
-- | Set SIGHASH_ANYONECANPAY flag.
setAnyoneCanPayFlag :: SigHash -> SigHash
setAnyoneCanPayFlag = (.|. sigHashAnyoneCanPay)
setAnyoneCanPay :: SigHash -> SigHash
setAnyoneCanPay = (.|. sigHashAnyoneCanPay)
-- | Is the SIGHASH_FORKID flag set?
hasForkIdFlag :: SigHash -> Bool
hasForkIdFlag = (/= 0) . (.&. sigHashForkId)
-- | Is the SIGHASH_ANYONECANPAY flag set?
hasAnyoneCanPayFlag :: SigHash -> Bool
hasAnyoneCanPayFlag = (/= 0) . (.&. sigHashAnyoneCanPay)
anyoneCanPay :: SigHash -> Bool
anyoneCanPay = (/= 0) . (.&. sigHashAnyoneCanPay)
-- | Returns 'True' if the 'SigHash' has the value 'SIGHASH_ALL'.
isSigHashAll :: SigHash -> Bool
@ -178,7 +177,7 @@ isSigHashSingle = (== sigHashSingle) . (.&. 0x1f)
-- | Returns 'True' if the 'SigHash' has the value 'SIGHASH_UNKNOWN'.
isSigHashUnknown :: SigHash -> Bool
isSigHashUnknown =
(`notElem` [sigHashAll, sigHashNone, sigHashSingle]) . (.&. 0x1f)
(`notElem` [sigHashAll, sigHashNone, sigHashSingle]) . (.&. 0x1f)
-- | Add a fork id to a 'SigHash'.
sigHashAddForkId :: SigHash -> Word32 -> SigHash
@ -187,7 +186,7 @@ sigHashAddForkId sh w = (fromIntegral w `shiftL` 8) .|. (sh .&. 0x000000ff)
-- | Add fork id of a particular network to a 'SigHash'.
sigHashAddNetworkId :: Network -> SigHash -> SigHash
sigHashAddNetworkId net =
(`sigHashAddForkId` fromMaybe 0 (getSigHashForkId net))
(`sigHashAddForkId` fromMaybe 0 net.sigHashForkId)
-- | Get fork id from 'SigHash'.
sigHashGetForkId :: SigHash -> Word32
@ -195,146 +194,157 @@ sigHashGetForkId (SigHash n) = fromIntegral $ n `shiftR` 8
-- | Computes the hash that will be used for signing a transaction.
txSigHash ::
Network ->
-- | transaction to sign
Tx ->
-- | script from output being spent
Script ->
-- | value of output being spent
Word64 ->
-- | index of input being signed
Int ->
-- | what to sign
SigHash ->
-- | hash to be signed
Hash256
Network ->
-- | transaction to sign
Tx ->
-- | script from output being spent
Script ->
-- | value of output being spent
Word64 ->
-- | index of input being signed
Int ->
-- | what to sign
SigHash ->
-- | hash to be signed
Hash256
txSigHash net tx out v i sh
| hasForkIdFlag sh && isJust (getSigHashForkId net) =
txSigHashForkId net tx out v i sh
| otherwise = do
let newIn = buildInputs (txIn tx) fout i sh
-- When SigSingle and input index > outputs, then sign integer 1
fromMaybe one $ do
newOut <- buildOutputs (txOut tx) i sh
let newTx = Tx (txVersion tx) newIn newOut [] (txLockTime tx)
return $
doubleSHA256 $
runPutS $ do
serialize newTx
putWord32le $ fromIntegral sh
| hasForkIdFlag sh && isJust net.sigHashForkId =
txSigHashForkId net tx out v i sh
| otherwise = do
let newIn = buildInputs tx.inputs fout i sh
-- When SigSingle and input index > outputs, then sign integer 1
fromMaybe one $ do
newOut <- buildOutputs tx.outputs i sh
let newTx = Tx tx.version newIn newOut [] tx.locktime
return . doubleSHA256 . runPutS $ do
serialize newTx
putWord32le $ fromIntegral sh
where
fout = Script $ filter (/= OP_CODESEPARATOR) $ scriptOps out
fout = Script $ filter (/= OP_CODESEPARATOR) out.ops
one = "0100000000000000000000000000000000000000000000000000000000000000"
-- | Build transaction inputs for computing sighashes.
buildInputs :: [TxIn] -> Script -> Int -> SigHash -> [TxIn]
buildInputs txins out i sh
| hasAnyoneCanPayFlag sh =
[(txins !! i){scriptInput = runPutS $ serialize out}]
| isSigHashAll sh || isSigHashUnknown sh = single
| otherwise = zipWith noSeq single [0 ..]
| anyoneCanPay sh = [serialOut (txins !! i)]
| isSigHashAll sh || isSigHashUnknown sh = single
| otherwise = zipWith noSeq single [0 ..]
where
emptyIn = map (\ti -> ti{scriptInput = BS.empty}) txins
single =
updateIndex i emptyIn $ \ti -> ti{scriptInput = runPutS $ serialize out}
noSeq ti j =
if i == j
then ti
else ti{txInSequence = 0}
serialOut TxIn {..} = TxIn {script = runPutS $ serialize out, ..}
emptyIn TxIn {..} = TxIn {script = B.empty, ..}
emptyIns = map emptyIn txins
single = updateIndex i emptyIns serialOut
noSeq TxIn {..} j = TxIn {sequence = if i == j then sequence else 0, ..}
-- | Build transaction outputs for computing sighashes.
buildOutputs :: [TxOut] -> Int -> SigHash -> Maybe [TxOut]
buildOutputs txos i sh
| isSigHashAll sh || isSigHashUnknown sh = return txos
| isSigHashNone sh = return []
| i >= length txos = Nothing
| otherwise = return $ buffer ++ [txos !! i]
| isSigHashAll sh || isSigHashUnknown sh = return txos
| isSigHashNone sh = return []
| i >= length txos = Nothing
| otherwise = return $ buffer ++ [txos !! i]
where
buffer = replicate i $ TxOut maxBound BS.empty
buffer = replicate i $ TxOut maxBound B.empty
{- | Compute the hash that will be used for signing a transaction. This
function is used when the 'SIGHASH_FORKID' flag is set.
-}
-- | Compute the hash that will be used for signing a transaction. This
-- function is used when the 'SIGHASH_FORKID' flag is set.
txSigHashForkId ::
Network ->
-- | transaction to sign
Tx ->
-- | script from output being spent
Script ->
-- | value of output being spent
Word64 ->
-- | index of input being signed
Int ->
-- | what to sign
SigHash ->
-- | hash to be signed
Hash256
Network ->
-- | transaction to sign
Tx ->
-- | script from output being spent
Script ->
-- | value of output being spent
Word64 ->
-- | index of input being signed
Int ->
-- | what to sign
SigHash ->
-- | hash to be signed
Hash256
txSigHashForkId net tx out v i sh =
doubleSHA256 . runPutS $ do
putWord32le $ txVersion tx
serialize hashPrevouts
serialize hashSequence
serialize $ prevOutput $ txIn tx !! i
putScript out
putWord64le v
putWord32le $ txInSequence $ txIn tx !! i
serialize hashOutputs
putWord32le $ txLockTime tx
putWord32le $ fromIntegral $ sigHashAddNetworkId net sh
doubleSHA256 . runPutS $ do
putWord32le tx.version
serialize hashPrevouts
serialize hashSequence
serialize (tx.inputs !! i).outpoint
putScript out
putWord64le v
putWord32le (tx.inputs !! i).sequence
serialize hashOutputs
putWord32le tx.locktime
putWord32le $ fromIntegral $ sigHashAddNetworkId net sh
where
hashPrevouts
| not $ hasAnyoneCanPayFlag sh =
doubleSHA256 $ runPutS $ mapM_ (serialize . prevOutput) $ txIn tx
| otherwise = zeros
| not (anyoneCanPay sh) =
doubleSHA256 . runPutS $ mapM_ (serialize . (.outpoint)) tx.inputs
| otherwise = zeros
hashSequence
| not (hasAnyoneCanPayFlag sh)
&& not (isSigHashSingle sh)
&& not (isSigHashNone sh) =
doubleSHA256 $ runPutS $ mapM_ (putWord32le . txInSequence) $ txIn tx
| otherwise = zeros
| not (anyoneCanPay sh || isSigHashSingle sh || isSigHashNone sh) =
doubleSHA256 . runPutS $ mapM_ (putWord32le . (.sequence)) tx.inputs
| otherwise = zeros
hashOutputs
| not (isSigHashSingle sh) && not (isSigHashNone sh) =
doubleSHA256 $ runPutS $ mapM_ serialize $ txOut tx
| isSigHashSingle sh && i < length (txOut tx) =
doubleSHA256 $ runPutS $ serialize $ txOut tx !! i
| otherwise = zeros
| not (isSigHashSingle sh || isSigHashNone sh) =
doubleSHA256 . runPutS $ mapM_ serialize tx.outputs
| isSigHashSingle sh && i < length tx.outputs =
doubleSHA256 . runPutS $ serialize $ tx.outputs !! i
| otherwise = zeros
putScript s = do
let encodedScript = runPutS $ serialize s
putVarInt $ BS.length encodedScript
putByteString encodedScript
let encodedScript = runPutS $ serialize s
putVarInt $ B.length encodedScript
putByteString encodedScript
zeros :: Hash256
zeros = "0000000000000000000000000000000000000000000000000000000000000000"
{- | Data type representing a signature together with a 'SigHash'. The 'SigHash'
is serialized as one byte at the end of an ECDSA 'Sig'. All signatures in
transaction inputs are of type 'TxSignature'.
-}
-- | Data type representing a signature together with a 'SigHash'. The 'SigHash'
-- is serialized as one byte at the end of an ECDSA 'Sig'. All signatures in
-- transaction inputs are of type 'TxSignature'.
data TxSignature
= TxSignature
{ txSignature :: !Sig
, txSignatureSigHash :: !SigHash
}
| TxSignatureEmpty
deriving (Eq, Show, Generic)
= TxSignature
{ sig :: !Sig,
hash :: !SigHash
}
| TxSignatureEmpty
deriving (Eq, Show, Read, Generic, NFData)
instance NFData TxSignature
instance Marshal (Network, Ctx) TxSignature where
marshalPut (net, ctx) TxSignatureEmpty = return ()
marshalPut (net, ctx) (TxSignature sig (SigHash n)) = do
marshalPut ctx sig
putWord8 (fromIntegral n)
-- | Serialize a 'TxSignature'.
encodeTxSig :: TxSignature -> BS.ByteString
encodeTxSig TxSignatureEmpty = error "Can not encode an empty signature"
encodeTxSig (TxSignature sig (SigHash n)) =
runPutS $ putSig sig >> putWord8 (fromIntegral n)
marshalGet (net, ctx) =
bool decode empty =<< isEmpty
where
empty = return TxSignatureEmpty
decode = do
sig <- marshalGet ctx
sh <- fromIntegral <$> getWord8
when (isSigHashUnknown sh) $
fail "Non-canonical signature: unknown hashtype byte"
when (isNothing net.sigHashForkId && hasForkIdFlag sh) $
fail "Non-canonical signature: invalid network for forkId"
return $ TxSignature sig sh
-- | Deserialize a 'TxSignature'.
decodeTxSig :: Network -> BS.ByteString -> Either String TxSignature
decodeTxSig _ bs | BS.null bs = Left "Empty signature candidate"
decodeTxSig net bs =
case decodeStrictSig $ BS.init bs of
Just sig -> do
let sh = fromIntegral $ BS.last bs
when (isSigHashUnknown sh) $
Left "Non-canonical signature: unknown hashtype byte"
when (isNothing (getSigHashForkId net) && hasForkIdFlag sh) $
Left "Non-canonical signature: invalid network for forkId"
return $ TxSignature sig sh
Nothing -> Left "Non-canonical signature: could not parse signature"
instance MarshalJSON (Network, Ctx) TxSignature where
marshalValue (net, ctx) = String . encodeHex . encodeTxSig net ctx
marshalEncoding s = hexEncoding . runPutL . marshalPut s
unmarshalValue (net, ctx) =
withText "TxSignature" $ \t ->
case decodeHex t of
Nothing -> fail "Cannot decode hex signature"
Just b -> case decodeTxSig net ctx b of
Left e -> fail e
Right s -> return s
encodeTxSig :: Network -> Ctx -> TxSignature -> ByteString
encodeTxSig net ctx = runPutS . marshalPut (net, ctx)
decodeTxSig :: Network -> Ctx -> ByteString -> Either String TxSignature
decodeTxSig net ctx =
runGetS $ do
sig <- marshalGet (net, ctx)
e <- isEmpty
unless e $
fail "Non-canonical signature: multiple hashtype bytes"
return sig

472
src/Haskoin/Script/Standard.hs
View File

@ -1,20 +1,26 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoFieldSelectors #-}
{- |
Module : Haskoin.Script.Standard
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
Standard scripts like pay-to-public-key, pay-to-public-key-hash,
pay-to-script-hash, pay-to-multisig and corresponding SegWit variants.
-}
module Haskoin.Script.Standard (
-- * Standard Script Outputs
-- |
-- Module : Haskoin.Script.Standard
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- Standard scripts like pay-to-public-key, pay-to-public-key-hash,
-- pay-to-script-hash, pay-to-multisig and corresponding SegWit variants.
module Haskoin.Script.Standard
( -- * Standard Script Outputs
ScriptOutput (..),
RedeemScript,
isPayPK,
@ -26,9 +32,7 @@ module Haskoin.Script.Standard (
isPayWitnessScriptHash,
isDataCarrier,
encodeOutput,
encodeOutputBS,
decodeOutput,
decodeOutputBS,
toP2SH,
toP2WSH,
sortMulSig,
@ -37,22 +41,23 @@ module Haskoin.Script.Standard (
ScriptInput (..),
SimpleInput (..),
encodeInput,
encodeInputBS,
decodeInput,
decodeInputBS,
isSpendPK,
isSpendPKHash,
isSpendMulSig,
isScriptHashInput,
) where
)
where
import Control.Applicative ((<|>))
import Control.DeepSeq
import Control.Monad (guard, liftM2, (<=<))
import qualified Data.Aeson as A
import qualified Data.Aeson.Encoding as A
import Crypto.Secp256k1
import Data.Aeson (ToJSON (..), Value (..), withText)
import Data.Aeson.Encoding (Encoding, text)
import Data.Aeson.Types (Parser)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.ByteString qualified as B
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
@ -62,52 +67,51 @@ import Data.List (sortBy)
import Data.Maybe (fromJust, isJust)
import Data.Word (Word8)
import GHC.Generics (Generic)
import Haskoin.Crypto
import Haskoin.Data
import Haskoin.Keys.Common
import Haskoin.Crypto.Hash
import Haskoin.Crypto.Keys.Common
import Haskoin.Network.Data
import Haskoin.Script.Common
import Haskoin.Script.SigHash
import Haskoin.Util
{- | Data type describing standard transaction output scripts. Output scripts
provide the conditions that must be fulfilled for someone to spend the funds
in a transaction output.
-}
-- | Data type describing standard transaction output scripts. Output scripts
-- provide the conditions that must be fulfilled for someone to spend the funds
-- in a transaction output.
data ScriptOutput
= -- | pay to public key
PayPK {getOutputPubKey :: !PubKeyI}
| -- | pay to public key hash
PayPKHash {getOutputHash :: !Hash160}
| -- | multisig
PayMulSig
{ getOutputMulSigKeys :: ![PubKeyI]
, getOutputMulSigRequired :: !Int
}
| -- | pay to a script hash
PayScriptHash {getOutputHash :: !Hash160}
| -- | pay to witness public key hash
PayWitnessPKHash {getOutputHash :: !Hash160}
| -- | pay to witness script hash
PayWitnessScriptHash {getScriptHash :: !Hash256}
| -- | another pay to witness address
PayWitness
{ getWitnessVersion :: !Word8
, getWitnessData :: !ByteString
}
| -- | provably unspendable data carrier
DataCarrier {getOutputData :: !ByteString}
deriving (Eq, Show, Read, Generic, Hashable, NFData)
= -- | pay to public key
PayPK {key :: !PublicKey}
| -- | pay to public key hash
PayPKHash {hash160 :: !Hash160}
| -- | multisig
PayMulSig
{ keys :: ![PublicKey],
required :: !Int
}
| -- | pay to a script hash
PayScriptHash {hash160 :: !Hash160}
| -- | pay to witness public key hash
PayWitnessPKHash {hash160 :: !Hash160}
| -- | pay to witness script hash
PayWitnessScriptHash {hash256 :: !Hash256}
| -- | another pay to witness address
PayWitness
{ version :: !Word8,
bytes :: !ByteString
}
| -- | provably unspendable data carrier
DataCarrier {bytes :: !ByteString}
deriving (Eq, Show, Read, Generic, NFData)
instance A.FromJSON ScriptOutput where
parseJSON =
A.withText "scriptoutput" $ \t ->
either fail return $
maybeToEither "scriptoutput not hex" (decodeHex t)
>>= decodeOutputBS
instance MarshalJSON Ctx ScriptOutput where
unmarshalValue ctx =
withText "ScriptOutput" $ \t ->
case decodeHex t of
Nothing -> fail "Could not decode hex script"
Just bs -> either fail return $ unmarshal ctx bs
instance A.ToJSON ScriptOutput where
toJSON = A.String . encodeHex . encodeOutputBS
toEncoding = A.text . encodeHex . encodeOutputBS
marshalValue ctx = String . encodeHex . marshal ctx
marshalEncoding ctx = hexEncoding . runPutL . marshalPut ctx
-- | Is script a pay-to-public-key output?
isPayPK :: ScriptOutput -> Bool
@ -149,35 +153,39 @@ isDataCarrier :: ScriptOutput -> Bool
isDataCarrier (DataCarrier _) = True
isDataCarrier _ = False
{- | Tries to decode a 'ScriptOutput' from a 'Script'. This can fail if the
script is not recognized as any of the standard output types.
-}
decodeOutput :: Script -> Either String ScriptOutput
decodeOutput s = case scriptOps s of
-- Pay to PubKey
[OP_PUSHDATA bs _, OP_CHECKSIG] -> PayPK <$> runGetS deserialize bs
-- Pay to PubKey Hash
[OP_DUP, OP_HASH160, OP_PUSHDATA bs _, OP_EQUALVERIFY, OP_CHECKSIG] ->
PayPKHash <$> runGetS deserialize bs
-- Pay to Script Hash
[OP_HASH160, OP_PUSHDATA bs _, OP_EQUAL] ->
PayScriptHash <$> runGetS deserialize bs
-- Pay to Witness
[OP_0, OP_PUSHDATA bs OPCODE]
| BS.length bs == 20 -> PayWitnessPKHash <$> runGetS deserialize bs
| BS.length bs == 32 -> PayWitnessScriptHash <$> runGetS deserialize bs
| BS.length bs /= 20 && BS.length bs /= 32 ->
Left "Version 0 segwit program must be 20 or 32 bytes long"
-- Other Witness
[ver, OP_PUSHDATA bs _]
| isJust (opWitnessVersion ver)
&& BS.length bs >= 2
&& BS.length bs <= 40 ->
Right $ PayWitness (fromJust (opWitnessVersion ver)) bs
-- Provably unspendable data carrier output
[OP_RETURN, OP_PUSHDATA bs _] -> Right $ DataCarrier bs
-- Pay to MultiSig Keys
_ -> matchPayMulSig s
-- | Tries to decode a 'ScriptOutput' from a 'Script'. This can fail if the
-- script is not recognized as any of the standard output types.
decodeOutput :: Ctx -> Script -> Either String ScriptOutput
decodeOutput ctx s = case s.ops of
-- Pay to PubKey
[OP_PUSHDATA bs _, OP_CHECKSIG] ->
PayPK <$> unmarshal ctx bs
-- Pay to PubKey Hash
[OP_DUP, OP_HASH160, OP_PUSHDATA bs _, OP_EQUALVERIFY, OP_CHECKSIG] ->
PayPKHash <$> runGetS deserialize bs
-- Pay to Script Hash
[OP_HASH160, OP_PUSHDATA bs _, OP_EQUAL] ->
PayScriptHash <$> runGetS deserialize bs
-- Pay to Witness
[OP_0, OP_PUSHDATA bs OPCODE]
| B.length bs == 20 ->
PayWitnessPKHash <$> runGetS deserialize bs
| B.length bs == 32 ->
PayWitnessScriptHash <$> runGetS deserialize bs
| B.length bs /= 20 && B.length bs /= 32 ->
Left
"decodeOutput: invalid version 0 segwit \
\(must be 20 or 32 bytes)"
-- Other Witness
[ver, OP_PUSHDATA bs _]
| Just wv <- opWitnessVersion ver,
B.length bs >= 2,
B.length bs <= 40 ->
Right $ PayWitness wv bs
-- Provably unspendable data carrier output
[OP_RETURN, OP_PUSHDATA bs _] -> Right $ DataCarrier bs
-- Pay to MultiSig Keys
_ -> matchPayMulSig ctx s <|> Left "decodeOutput: Non-standard output"
witnessVersionOp :: Word8 -> Maybe ScriptOp
witnessVersionOp 0 = Just OP_0
@ -219,51 +227,51 @@ opWitnessVersion OP_15 = Just 15
opWitnessVersion OP_16 = Just 16
opWitnessVersion _ = Nothing
-- | Similar to 'decodeOutput' but decodes from a 'ByteString'.
decodeOutputBS :: ByteString -> Either String ScriptOutput
decodeOutputBS = decodeOutput <=< runGetS deserialize
-- | Computes a 'Script' from a standard 'ScriptOutput'.
encodeOutput :: ScriptOutput -> Script
encodeOutput s = Script $ case s of
-- Pay to PubKey
(PayPK k) -> [opPushData $ runPutS $ serialize k, OP_CHECKSIG]
-- Pay to PubKey Hash Address
(PayPKHash h) ->
[ OP_DUP
, OP_HASH160
, opPushData $ runPutS $ serialize h
, OP_EQUALVERIFY
, OP_CHECKSIG
]
-- Pay to MultiSig Keys
(PayMulSig ps r)
| r <= length ps ->
let opM = intToScriptOp r
opN = intToScriptOp $ length ps
keys = map (opPushData . runPutS . serialize) ps
in opM : keys ++ [opN, OP_CHECKMULTISIG]
| otherwise -> error "encodeOutput: PayMulSig r must be <= than pkeys"
-- Pay to Script Hash Address
(PayScriptHash h) ->
[OP_HASH160, opPushData $ runPutS $ serialize h, OP_EQUAL]
-- Pay to Witness PubKey Hash Address
(PayWitnessPKHash h) ->
[OP_0, opPushData $ runPutS $ serialize h]
(PayWitnessScriptHash h) ->
[OP_0, opPushData $ runPutS $ serialize h]
(PayWitness v h) ->
[ case witnessVersionOp v of
Nothing -> error "encodeOutput: invalid witness version"
Just c -> c
, opPushData h
]
-- Provably unspendable output
(DataCarrier d) -> [OP_RETURN, opPushData d]
encodeOutput :: Ctx -> ScriptOutput -> Script
encodeOutput ctx s = Script $ case s of
-- Pay to PubKey
(PayPK k) -> [opPushData $ marshal ctx k, OP_CHECKSIG]
-- Pay to PubKey Hash Address
(PayPKHash h) ->
[ OP_DUP,
OP_HASH160,
opPushData $ runPutS $ serialize h,
OP_EQUALVERIFY,
OP_CHECKSIG
]
-- Pay to MultiSig Keys
(PayMulSig ps r)
| r <= length ps ->
let opM = intToScriptOp r
opN = intToScriptOp $ length ps
keys = map (opPushData . marshal ctx) ps
in opM : keys ++ [opN, OP_CHECKMULTISIG]
| otherwise -> error "encodeOutput: PayMulSig r must be <= than pkeys"
-- Pay to Script Hash Address
(PayScriptHash h) ->
[OP_HASH160, opPushData $ runPutS $ serialize h, OP_EQUAL]
-- Pay to Witness PubKey Hash Address
(PayWitnessPKHash h) ->
[OP_0, opPushData $ runPutS $ serialize h]
(PayWitnessScriptHash h) ->
[OP_0, opPushData $ runPutS $ serialize h]
(PayWitness v h) ->
[ case witnessVersionOp v of
Nothing -> error "encodeOutput: invalid witness version"
Just c -> c,
opPushData h
]
-- Provably unspendable output
(DataCarrier d) -> [OP_RETURN, opPushData d]
-- | Similar to 'encodeOutput' but encodes to a ByteString
encodeOutputBS :: ScriptOutput -> ByteString
encodeOutputBS = runPutS . serialize . encodeOutput
instance Marshal Ctx ScriptOutput where
marshalGet ctx = do
script <- deserialize
case decodeOutput ctx script of
Left e -> fail e
Right o -> return o
marshalPut ctx = serialize . encodeOutput ctx
-- | Encode script as pay-to-script-hash script
toP2SH :: Script -> ScriptOutput
@ -274,59 +282,61 @@ toP2WSH :: Script -> ScriptOutput
toP2WSH = PayWitnessScriptHash . sha256 . runPutS . serialize
-- | Match @[OP_N, PubKey1, ..., PubKeyM, OP_M, OP_CHECKMULTISIG]@
matchPayMulSig :: Script -> Either String ScriptOutput
matchPayMulSig (Script ops) = case splitAt (length ops - 2) ops of
(m : xs, [n, OP_CHECKMULTISIG]) -> do
(intM, intN) <- liftM2 (,) (scriptOpToInt m) (scriptOpToInt n)
if intM <= intN && length xs == intN
then liftM2 PayMulSig (go xs) (return intM)
else Left "matchPayMulSig: Invalid M or N parameters"
_ -> Left "matchPayMulSig: script did not match output template"
matchPayMulSig :: Ctx -> Script -> Either String ScriptOutput
matchPayMulSig ctx (Script ops) = case splitAt (length ops - 2) ops of
(m : xs, [n, OP_CHECKMULTISIG]) -> do
(intM, intN) <- liftM2 (,) (scriptOpToInt m) (scriptOpToInt n)
if intM <= intN && length xs == intN
then liftM2 PayMulSig (go xs) (return intM)
else Left "matchPayMulSig: Invalid M or N parameters"
_ -> Left "matchPayMulSig: script did not match output template"
where
go (OP_PUSHDATA bs _ : xs) = liftM2 (:) (runGetS deserialize bs) (go xs)
go [] = return []
go _ = Left "matchPayMulSig: invalid multisig opcode"
go (OP_PUSHDATA bs _ : xs) =
liftM2 (:) (unmarshal ctx bs) (go xs)
go [] =
Right []
go _ =
Left "matchPayMulSig: invalid multisig opcode"
{- | Sort the public keys of a multisig output in ascending order by comparing
their compressed serialized representations. Refer to BIP-67.
-}
sortMulSig :: ScriptOutput -> ScriptOutput
sortMulSig out = case out of
PayMulSig keys r -> PayMulSig (sortBy (compare `on` (runPutS . serialize)) keys) r
_ -> error "Can only call orderMulSig on PayMulSig scripts"
-- | Sort the public keys of a multisig output in ascending order by comparing
-- their compressed serialized representations. Refer to BIP-67.
sortMulSig :: Ctx -> ScriptOutput -> ScriptOutput
sortMulSig ctx out = case out of
PayMulSig keys r ->
PayMulSig
(sortBy (compare `on` marshal ctx) keys)
r
_ -> error "Can only call orderMulSig on PayMulSig scripts"
{- | Data type describing standard transaction input scripts. Input scripts
provide the signing data required to unlock the coins of the output they are
trying to spend, except in pay-to-witness-public-key-hash and
pay-to-script-hash transactions.
-}
-- | Data type describing standard transaction input scripts. Input scripts
-- provide the signing data required to unlock the coins of the output they are
-- trying to spend, except in pay-to-witness-public-key-hash and
-- pay-to-script-hash transactions.
data SimpleInput
= SpendPK
{ -- | transaction signature
getInputSig :: !TxSignature
}
| SpendPKHash
{ -- | embedded signature
getInputSig :: !TxSignature
, -- | public key
getInputKey :: !PubKeyI
}
| SpendMulSig
{ -- | list of signatures
getInputMulSigKeys :: ![TxSignature]
}
deriving (Eq, Show, Generic, NFData)
= SpendPK
{ -- | transaction signature
signature :: !TxSignature
}
| SpendPKHash
{ -- | embedded signature
signature :: !TxSignature,
-- | public key
key :: !PublicKey
}
| SpendMulSig
{ -- | list of signatures
signatures :: ![TxSignature]
}
deriving (Eq, Show, Read, Generic, NFData)
{- | Returns true if the input script is spending from a pay-to-public-key
output.
-}
-- | Returns true if the input script is spending from a pay-to-public-key
-- output.
isSpendPK :: ScriptInput -> Bool
isSpendPK (RegularInput (SpendPK _)) = True
isSpendPK _ = False
{- | Returns true if the input script is spending from a pay-to-public-key-hash
output.
-}
-- | Returns true if the input script is spending from a pay-to-public-key-hash
-- output.
isSpendPKHash :: ScriptInput -> Bool
isSpendPKHash (RegularInput (SpendPKHash _ _)) = True
isSpendPKHash _ = False
@ -341,91 +351,83 @@ isScriptHashInput :: ScriptInput -> Bool
isScriptHashInput (ScriptHashInput _ _) = True
isScriptHashInput _ = False
{- | A redeem script is the output script serialized into the spending input
script. It must be included in inputs that spend pay-to-script-hash outputs.
-}
-- | A redeem script is the output script serialized into the spending input
-- script. It must be included in inputs that spend pay-to-script-hash outputs.
type RedeemScript = ScriptOutput
-- | Standard input script high-level representation.
data ScriptInput
= RegularInput
{ -- | get wrapped simple input
getRegularInput :: !SimpleInput
}
| ScriptHashInput
{ -- | get simple input associated with redeem script
getScriptHashInput :: !SimpleInput
, -- | redeem script
getScriptHashRedeem :: !RedeemScript
}
deriving (Eq, Show, Generic, NFData)
= RegularInput
{ -- | get wrapped simple input
get :: !SimpleInput
}
| ScriptHashInput
{ -- | get simple input associated with redeem script
get :: !SimpleInput,
-- | redeem script
redeem :: !RedeemScript
}
deriving (Show, Read, Eq, Generic, NFData)
-- | Heuristic to decode an input script into one of the standard types.
decodeSimpleInput :: Network -> Script -> Either String SimpleInput
decodeSimpleInput net (Script ops) =
maybeToEither errMsg $ matchPK ops <|> matchPKHash ops <|> matchMulSig ops
decodeSimpleInput :: Network -> Ctx -> Script -> Either String SimpleInput
decodeSimpleInput net ctx (Script ops) =
maybeToEither errMsg $ matchPK ops <|> matchPKHash ops <|> matchMulSig ops
where
matchPK [op] = SpendPK <$> f op
matchPK _ = Nothing
matchPKHash [op, OP_PUSHDATA pub _] =
SpendPKHash <$> f op <*> eitherToMaybe (runGetS deserialize pub)
SpendPKHash <$> f op <*> eitherToMaybe (unmarshal ctx pub)
matchPKHash _ = Nothing
matchMulSig (x : xs) = do
guard $ x == OP_0
SpendMulSig <$> mapM f xs
guard $ x == OP_0
SpendMulSig <$> mapM f xs
matchMulSig _ = Nothing
f OP_0 = return TxSignatureEmpty
f (OP_PUSHDATA "" OPCODE) = f OP_0
f (OP_PUSHDATA bs _) = eitherToMaybe $ decodeTxSig net bs
f (OP_PUSHDATA bs _) = eitherToMaybe $ decodeTxSig net ctx bs
f _ = Nothing
errMsg = "decodeInput: Could not decode script input"
{- | Heuristic to decode a 'ScriptInput' from a 'Script'. This function fails if
the script can not be parsed as a standard script input.
-}
decodeInput :: Network -> Script -> Either String ScriptInput
decodeInput net s@(Script ops) =
maybeToEither errMsg $ matchSimpleInput <|> matchPayScriptHash
-- | Heuristic to decode a 'ScriptInput' from a 'Script'. This function fails if
-- the script can not be parsed as a standard script input.
decodeInput :: Network -> Ctx -> Script -> Either String ScriptInput
decodeInput net ctx s@(Script ops) =
maybeToEither errMsg $ matchSimpleInput <|> matchPayScriptHash
where
matchSimpleInput =
RegularInput <$> eitherToMaybe (decodeSimpleInput net s)
RegularInput <$> eitherToMaybe (decodeSimpleInput net ctx s)
matchPayScriptHash =
case splitAt (length (scriptOps s) - 1) ops of
(is, [OP_PUSHDATA bs _]) -> do
rdm <- eitherToMaybe $ decodeOutputBS bs
inp <- eitherToMaybe $ decodeSimpleInput net $ Script is
return $ ScriptHashInput inp rdm
_ -> Nothing
case splitAt (length s.ops - 1) ops of
(is, [OP_PUSHDATA bs _]) -> do
rdm <- eitherToMaybe $ unmarshal ctx bs
inp <- eitherToMaybe $ decodeSimpleInput net ctx $ Script is
return $ ScriptHashInput inp rdm
_ -> Nothing
errMsg = "decodeInput: Could not decode script input"
{- | Like 'decodeInput' but decodes directly from a serialized script
'ByteString'.
-}
decodeInputBS :: Network -> ByteString -> Either String ScriptInput
decodeInputBS net = decodeInput net <=< runGetS deserialize
instance Marshal (Network, Ctx) ScriptInput where
marshalGet (net, ctx) =
deserialize >>= either fail return . decodeInput net ctx
marshalPut (net, ctx) =
serialize . encodeInput net ctx
-- | Encode a standard input into a script.
encodeInput :: ScriptInput -> Script
encodeInput s = case s of
RegularInput ri -> encodeSimpleInput ri
ScriptHashInput i o ->
Script $
scriptOps (encodeSimpleInput i) ++ [opPushData $ encodeOutputBS o]
{- | Similar to 'encodeInput' but encodes directly to a serialized script
'ByteString'.
-}
encodeInputBS :: ScriptInput -> ByteString
encodeInputBS = runPutS . serialize . encodeInput
encodeInput :: Network -> Ctx -> ScriptInput -> Script
encodeInput net ctx s = case s of
RegularInput ri -> encodeSimpleInput net ctx ri
ScriptHashInput i o ->
Script $ (encodeSimpleInput net ctx i).ops ++ [opPushData $ marshal ctx o]
-- | Encode a standard 'SimpleInput' into opcodes as an input 'Script'.
encodeSimpleInput :: SimpleInput -> Script
encodeSimpleInput s =
Script $
case s of
SpendPK ts -> [f ts]
SpendPKHash ts p -> [f ts, opPushData $ runPutS $ serialize p]
SpendMulSig xs -> OP_0 : map f xs
encodeSimpleInput :: Network -> Ctx -> SimpleInput -> Script
encodeSimpleInput net ctx s =
Script $
case s of
SpendPK ts -> [f ts]
SpendPKHash ts p -> [f ts, opPushData $ marshal ctx p]
SpendMulSig xs -> OP_0 : map f xs
where
f TxSignatureEmpty = OP_0
f ts = opPushData $ encodeTxSig ts
f ts = opPushData $ encodeTxSig net ctx ts

26
src/Haskoin/Transaction.hs
View File

@ -1,21 +1,21 @@
{- |
Module : Haskoin.Transaction
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
Transactions and related code.
-}
module Haskoin.Transaction (
module Common,
-- |
-- Module : Haskoin.Transaction
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- Transactions and related code.
module Haskoin.Transaction
( module Common,
module Builder,
module Segwit,
module Taproot,
module Partial,
module Genesis,
) where
)
where
import Haskoin.Transaction.Builder as Builder
import Haskoin.Transaction.Common as Common

831
src/Haskoin/Transaction/Builder.hs
View File

@ -1,20 +1,24 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoFieldSelectors #-}
{- |
Module : Haskoin.Transaction.Builder
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
Code to simplify transaction creation, signing, fee calculation and coin
selection.
-}
module Haskoin.Transaction.Builder (
-- * Transaction Builder
-- |
-- Module : Haskoin.Transaction.Builder
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- Code to simplify transaction creation, signing, fee calculation and coin
-- selection.
module Haskoin.Transaction.Builder
( -- * Transaction Builder
buildAddrTx,
buildTx,
buildInput,
@ -43,24 +47,19 @@ module Haskoin.Transaction.Builder (
guessMSTxFee,
guessTxSize,
guessMSSize,
) where
)
where
import Control.Applicative ((<|>))
import Control.Arrow (first)
import Control.Monad (foldM, unless)
import Control.Monad.Identity (runIdentity)
import Crypto.Secp256k1
import qualified Data.ByteString as B
import Data.ByteString qualified as B
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import Data.Conduit (
ConduitT,
Void,
await,
runConduit,
(.|),
)
import Data.Conduit (ConduitT, Void, await, runConduit, (.|))
import Data.Conduit.List (sourceList)
import Data.Either (fromRight)
import Data.List (nub)
@ -70,508 +69,554 @@ import Data.Text (Text)
import Data.Word (Word64)
import Haskoin.Address
import Haskoin.Crypto.Hash (Hash256, addressHash)
import Haskoin.Crypto.Keys.Common
import Haskoin.Crypto.Signature
import Haskoin.Data
import Haskoin.Keys.Common
import Haskoin.Network.Common
import Haskoin.Network.Data
import Haskoin.Script
import Haskoin.Transaction.Builder.Sign (
SigInput (..),
buildInput,
makeSignature,
sigKeys,
)
import qualified Haskoin.Transaction.Builder.Sign as S
import Haskoin.Transaction.Builder.Sign (SigInput, buildInput, makeSignature, sigKeys)
import Haskoin.Transaction.Builder.Sign qualified as Sign
import Haskoin.Transaction.Common
import Haskoin.Transaction.Segwit (
decodeWitnessInput,
isSegwit,
viewWitnessProgram,
)
import Haskoin.Transaction.Segwit
import Haskoin.Util
{- | Any type can be used as a Coin if it can provide a value in Satoshi.
The value is used in coin selection algorithms.
-}
-- | Any type can be used as a Coin if it can provide a value in Satoshi.
-- The value is used in coin selection algorithms.
class Coin c where
coinValue :: c -> Word64
coinValue :: c -> Word64
{- | Coin selection algorithm for normal (non-multisig) transactions. This
function returns the selected coins together with the amount of change to
send back to yourself, taking the fee into account.
-}
-- | Coin selection algorithm for normal (non-multisig) transactions. This
-- function returns the selected coins together with the amount of change to
-- send back to yourself, taking the fee into account.
chooseCoins ::
Coin c =>
-- | value to send
Word64 ->
-- | fee per byte
Word64 ->
-- | number of outputs (including change)
Int ->
-- | try to find better solutions
Bool ->
-- | list of ordered coins to choose from
[c] ->
-- | coin selection and change
Either String ([c], Word64)
(Coin c) =>
-- | value to send
Word64 ->
-- | fee per byte
Word64 ->
-- | number of outputs (including change)
Int ->
-- | try to find better solutions
Bool ->
-- | list of ordered coins to choose from
[c] ->
-- | coin selection and change
Either String ([c], Word64)
chooseCoins target fee nOut continue coins =
runIdentity . runConduit $
sourceList coins .| chooseCoinsSink target fee nOut continue
runIdentity . runConduit $
sourceList coins .| chooseCoinsSink target fee nOut continue
{- | Coin selection algorithm for normal (non-multisig) transactions. This
function returns the selected coins together with the amount of change to
send back to yourself, taking the fee into account. This version uses a Sink
for conduit-based coin selection.
-}
-- | Coin selection algorithm for normal (non-multisig) transactions. This
-- function returns the selected coins together with the amount of change to
-- send back to yourself, taking the fee into account. This version uses a Sink
-- for conduit-based coin selection.
chooseCoinsSink ::
(Monad m, Coin c) =>
-- | value to send
Word64 ->
-- | fee per byte
Word64 ->
-- | number of outputs (including change)
Int ->
-- | try to find better solution
Bool ->
-- | coin selection and change
ConduitT c Void m (Either String ([c], Word64))
(Monad m, Coin c) =>
-- | value to send
Word64 ->
-- | fee per byte
Word64 ->
-- | number of outputs (including change)
Int ->
-- | try to find better solution
Bool ->
-- | coin selection and change
ConduitT c Void m (Either String ([c], Word64))
chooseCoinsSink target fee nOut continue
| target > 0 =
maybeToEither err
<$> greedyAddSink target (guessTxFee fee nOut) continue
| otherwise = return $ Left "chooseCoins: Target must be > 0"
| target > 0 =
maybeToEither err
<$> greedyAddSink target (guessTxFee fee nOut) continue
| otherwise = return $ Left "chooseCoins: Target must be > 0"
where
err = "chooseCoins: No solution found"
{- | Coin selection algorithm for multisig transactions. This function returns
the selected coins together with the amount of change to send back to
yourself, taking the fee into account. This function assumes all the coins
are script hash outputs that send funds to a multisignature address.
-}
-- | Coin selection algorithm for multisig transactions. This function returns
-- the selected coins together with the amount of change to send back to
-- yourself, taking the fee into account. This function assumes all the coins
-- are script hash outputs that send funds to a multisignature address.
chooseMSCoins ::
Coin c =>
-- | value to send
Word64 ->
-- | fee per byte
Word64 ->
-- | m of n multisig
(Int, Int) ->
-- | number of outputs (including change)
Int ->
-- | try to find better solution
Bool ->
[c] ->
-- | coin selection change amount
Either String ([c], Word64)
(Coin c) =>
-- | value to send
Word64 ->
-- | fee per byte
Word64 ->
-- | m of n multisig
(Int, Int) ->
-- | number of outputs (including change)
Int ->
-- | try to find better solution
Bool ->
[c] ->
-- | coin selection change amount
Either String ([c], Word64)
chooseMSCoins target fee ms nOut continue coins =
runIdentity . runConduit $
sourceList coins .| chooseMSCoinsSink target fee ms nOut continue
runIdentity . runConduit $
sourceList coins .| chooseMSCoinsSink target fee ms nOut continue
{- | Coin selection algorithm for multisig transactions. This function returns
the selected coins together with the amount of change to send back to
yourself, taking the fee into account. This function assumes all the coins
are script hash outputs that send funds to a multisignature address. This
version uses a Sink if you need conduit-based coin selection.
-}
-- | Coin selection algorithm for multisig transactions. This function returns
-- the selected coins together with the amount of change to send back to
-- yourself, taking the fee into account. This function assumes all the coins
-- are script hash outputs that send funds to a multisignature address. This
-- version uses a Sink if you need conduit-based coin selection.
chooseMSCoinsSink ::
(Monad m, Coin c) =>
-- | value to send
Word64 ->
-- | fee per byte
Word64 ->
-- | m of n multisig
(Int, Int) ->
-- | number of outputs (including change)
Int ->
-- | try to find better solution
Bool ->
-- | coin selection and change
ConduitT c Void m (Either String ([c], Word64))
(Monad m, Coin c) =>
-- | value to send
Word64 ->
-- | fee per byte
Word64 ->
-- | m of n multisig
(Int, Int) ->
-- | number of outputs (including change)
Int ->
-- | try to find better solution
Bool ->
-- | coin selection and change
ConduitT c Void m (Either String ([c], Word64))
chooseMSCoinsSink target fee ms nOut continue
| target > 0 =
maybeToEither err
<$> greedyAddSink target (guessMSTxFee fee ms nOut) continue
| otherwise = return $ Left "chooseMSCoins: Target must be > 0"
| target > 0 =
maybeToEither err
<$> greedyAddSink target (guessMSTxFee fee ms nOut) continue
| otherwise = return $ Left "chooseMSCoins: Target must be > 0"
where
err = "chooseMSCoins: No solution found"
{- | Select coins greedily by starting from an empty solution. If the 'continue'
flag is set, the algorithm will try to find a better solution in the stream
after a solution is found. If the next solution found is not strictly better
than the previously found solution, the algorithm stops and returns the
previous solution. If the continue flag is not set, the algorithm will return
the first solution it finds in the stream.
-}
-- | Select coins greedily by starting from an empty solution. If the 'continue'
-- flag is set, the algorithm will try to find a better solution in the stream
-- after a solution is found. If the next solution found is not strictly better
-- than the previously found solution, the algorithm stops and returns the
-- previous solution. If the continue flag is not set, the algorithm will return
-- the first solution it finds in the stream.
greedyAddSink ::
(Monad m, Coin c) =>
-- | value to send
Word64 ->
-- | coin count to fee function
(Int -> Word64) ->
-- | try to find better solutions
Bool ->
-- | coin selection and change
ConduitT c Void m (Maybe ([c], Word64))
(Monad m, Coin c) =>
-- | value to send
Word64 ->
-- | coin count to fee function
(Int -> Word64) ->
-- | try to find better solutions
Bool ->
-- | coin selection and change
ConduitT c Void m (Maybe ([c], Word64))
greedyAddSink target guessFee continue =
go [] 0 [] 0
go [] 0 [] 0
where
-- The goal is the value we must reach (including the fee) for a certain
-- amount of selected coins.
goal c = target + guessFee c
go acc aTot ps pTot =
await >>= \case
-- A coin is available in the stream
Just coin -> do
let val = coinValue coin
-- We have reached the goal using this coin
if val + aTot >= goal (length acc + 1)
then -- If we want to continue searching for better solutions
await >>= \case
-- A coin is available in the stream
Just coin -> do
let val = coinValue coin
-- We have reached the goal using this coin
if val + aTot >= goal (length acc + 1)
then -- If we want to continue searching for better solutions
if continue
then -- This solution is the first one or
-- This solution is better than the previous one
if continue
then -- This solution is the first one or
-- This solution is better than the previous one
if pTot == 0 || val + aTot < pTot
then -- Continue searching for better solutions in the stream
go [] 0 (coin : acc) (val + aTot)
else -- Otherwise, we stop here and return the previous
-- solution
return $ Just (ps, pTot - goal (length ps))
else -- Otherwise, return this solution
if pTot == 0 || val + aTot < pTot
then -- Continue searching for better solutions in the stream
go [] 0 (coin : acc) (val + aTot)
else -- Otherwise, we stop here and return the previous
-- solution
return $ Just (ps, pTot - goal (length ps))
else -- Otherwise, return this solution
return $
Just (coin : acc, val + aTot - goal (length acc + 1))
else -- We have not yet reached the goal. Add the coin to the
-- accumulator
go (coin : acc) (val + aTot) ps pTot
-- We reached the end of the stream
Nothing ->
return $
if null ps
then -- If no solution was found, return Nothing
Nothing
else -- If we have a solution, return it
Just (ps, pTot - goal (length ps))
return $
Just (coin : acc, val + aTot - goal (length acc + 1))
else -- We have not yet reached the goal. Add the coin to the
-- accumulator
go (coin : acc) (val + aTot) ps pTot
-- We reached the end of the stream
Nothing ->
return $
if null ps
then -- If no solution was found, return Nothing
Nothing
else -- If we have a solution, return it
Just (ps, pTot - goal (length ps))
-- | Estimate tranasction fee to pay based on transaction size estimation.
guessTxFee :: Word64 -> Int -> Int -> Word64
guessTxFee byteFee nOut nIn =
byteFee * fromIntegral (guessTxSize nIn [] nOut 0)
byteFee * fromIntegral (guessTxSize nIn [] nOut 0)
-- | Same as 'guessTxFee' but for multisig transactions.
guessMSTxFee :: Word64 -> (Int, Int) -> Int -> Int -> Word64
guessMSTxFee byteFee ms nOut nIn =
byteFee * fromIntegral (guessTxSize 0 (replicate nIn ms) nOut 0)
byteFee * fromIntegral (guessTxSize 0 (replicate nIn ms) nOut 0)
{- | Computes an upper bound on the size of a transaction based on some known
properties of the transaction.
-}
-- | Computes an upper bound on the size of a transaction based on some known
-- properties of the transaction.
guessTxSize ::
-- | number of regular transaction inputs
Int ->
-- | multisig m of n for each input
[(Int, Int)] ->
-- | number of P2PKH outputs
Int ->
-- | number of P2SH outputs
Int ->
-- | upper bound on transaction size
Int
-- | number of regular transaction inputs
Int ->
-- | multisig m of n for each input
[(Int, Int)] ->
-- | number of P2PKH outputs
Int ->
-- | number of P2SH outputs
Int ->
-- | upper bound on transaction size
Int
guessTxSize pki msi pkout msout =
8 + inpLen + inp + outLen + out
8 + inpLen + inp + outLen + out
where
inpLen =
B.length
. runPutS
. serialize
. VarInt
. fromIntegral
$ length msi + pki
B.length
. runPutS
. serialize
. VarInt
. fromIntegral
$ length msi + pki
outLen =
B.length
. runPutS
. serialize
. VarInt
. fromIntegral
$ pkout + msout
B.length
. runPutS
. serialize
. VarInt
. fromIntegral
$ pkout + msout
inp = pki * 148 + sum (map guessMSSize msi)
-- (20: hash160) + (5: opcodes) +
-- (1: script len) + (8: Word64)
out =
pkout * 34
+
-- (20: hash160) + (3: opcodes) +
-- (1: script len) + (8: Word64)
msout * 32
pkout * 34
+
-- (20: hash160) + (3: opcodes) +
-- (20: hash160) + (3: opcodes) +
-- (20: hash160) + (3: opcodes) +
-- (20: hash160) + (3: opcodes) +
-- (1: script len) + (8: Word64)
-- (1: script len) + (8: Word64)
-- (1: script len) + (8: Word64)
-- (1: script len) + (8: Word64)
-- (20: hash160) + (3: opcodes) +
-- (20: hash160) + (3: opcodes) +
-- (1: script len) + (8: Word64)
-- (1: script len) + (8: Word64)
-- (20: hash160) + (3: opcodes) +
-- (20: hash160) + (3: opcodes) +
-- (1: script len) + (8: Word64)
-- (1: script len) + (8: Word64)
-- (20: hash160) + (3: opcodes) +
-- (1: script len) + (8: Word64)
msout * 32
-- | Size of a multisig P2SH input.
guessMSSize :: (Int, Int) -> Int
guessMSSize (m, n) =
-- OutPoint (36) + Sequence (4) + Script
40
+ fromIntegral (B.length $ runPutS . serialize $ VarInt $ fromIntegral scp)
+ scp
-- OutPoint (36) + Sequence (4) + Script
40
+ fromIntegral (B.length $ runPutS . serialize $ VarInt $ fromIntegral scp)
+ scp
where
-- OP_M + n*PubKey + OP_N + OP_CHECKMULTISIG
rdm =
fromIntegral $
B.length $ runPutS $ serialize $ opPushData $ B.replicate (n * 34 + 3) 0
fromIntegral $
B.length $
runPutS $
serialize $
opPushData $
B.replicate (n * 34 + 3) 0
-- Redeem + m*sig + OP_0
scp = rdm + m * 73 + 1
{- Build a new Tx -}
{- | Build a transaction by providing a list of outpoints as inputs
and a list of recipient addresses and amounts as outputs.
-}
buildAddrTx :: Network -> [OutPoint] -> [(Text, Word64)] -> Either String Tx
buildAddrTx net ops rcps =
buildTx ops <$> mapM f rcps
-- | Build a transaction by providing a list of outpoints as inputs
-- and a list of recipient addresses and amounts as outputs.
buildAddrTx :: Network -> Ctx -> [OutPoint] -> [(Text, Word64)] -> Either String Tx
buildAddrTx net ctx ops rcps =
buildTx ctx ops <$> mapM f rcps
where
f (aTxt, v) =
maybeToEither ("buildAddrTx: Invalid address " <> cs aTxt) $ do
a <- textToAddr net aTxt
let o = addressToOutput a
return (o, v)
maybeToEither ("buildAddrTx: Invalid address " <> cs aTxt) $ do
a <- textToAddr net aTxt
let o = addressToOutput a
return (o, v)
{- | Build a transaction by providing a list of outpoints as inputs
and a list of 'ScriptOutput' and amounts as outputs.
-}
buildTx :: [OutPoint] -> [(ScriptOutput, Word64)] -> Tx
buildTx ops rcpts =
Tx 1 (toIn <$> ops) (toOut <$> rcpts) [] 0
-- | Build a transaction by providing a list of outpoints as inputs
-- and a list of 'ScriptOutput' and amounts as outputs.
buildTx :: Ctx -> [OutPoint] -> [(ScriptOutput, Word64)] -> Tx
buildTx ctx ops rcpts =
Tx 1 (toIn <$> ops) (toOut <$> rcpts) [] 0
where
toIn op = TxIn op B.empty maxBound
toOut (o, v) = TxOut v $ encodeOutputBS o
toOut (o, v) = TxOut v $ marshal ctx o
{- | Sign a transaction by providing the 'SigInput' signing parameters and a
list of private keys. The signature is computed deterministically as defined
in RFC-6979.
Example: P2SH-P2WKH
> sigIn = SigInput (PayWitnessPKHash h) 100000 op sigHashAll Nothing
> signedTx = signTx btc unsignedTx [sigIn] [key]
Example: P2SH-P2WSH multisig
> sigIn = SigInput (PayWitnessScriptHash h) 100000 op sigHashAll (Just $ PayMulSig [p1,p2,p3] 2)
> signedTx = signTx btc unsignedTx [sigIn] [k1,k3]
-}
-- | Sign a transaction by providing the 'SigInput' signing parameters and a
-- list of private keys. The signature is computed deterministically as defined
-- in RFC-6979.
--
-- Example: P2SH-P2WKH
--
-- > sigIn = SigInput (PayWitnessPKHash h) 100000 op sigHashAll Nothing
-- > signedTx = signTx btc unsignedTx [sigIn] [key]
--
-- Example: P2SH-P2WSH multisig
--
-- > sigIn = SigInput (PayWitnessScriptHash h) 100000 op sigHashAll (Just $ PayMulSig [p1,p2,p3] 2)
-- > signedTx = signTx btc unsignedTx [sigIn] [k1,k3]
signTx ::
Network ->
-- | transaction to sign
Tx ->
-- | signing parameters
[SigInput] ->
-- | private keys to sign with
[SecKey] ->
-- | signed transaction
Either String Tx
signTx net tx si = S.signTx net tx $ notNested <$> si
Network ->
Ctx ->
-- | transaction to sign
Tx ->
-- | signing parameters
[SigInput] ->
-- | private keys to sign with
[SecKey] ->
-- | signed transaction
Either String Tx
signTx net ctx tx si = Sign.signTx net ctx tx $ notNested <$> si
where
notNested s = (s, False)
{- | This function differs from 'signTx' by assuming all segwit inputs are
P2SH-nested. Use the same signing parameters for segwit inputs as in 'signTx'.
-}
-- | This function differs from 'signTx' by assuming all segwit inputs are
-- P2SH-nested. Use the same signing parameters for segwit inputs as in 'signTx'.
signNestedWitnessTx ::
Network ->
-- | transaction to sign
Tx ->
-- | signing parameters
[SigInput] ->
-- | private keys to sign with
[SecKey] ->
-- | signed transaction
Either String Tx
signNestedWitnessTx net tx si = S.signTx net tx $ nested <$> si
Network ->
Ctx ->
-- | transaction to sign
Tx ->
-- | signing parameters
[SigInput] ->
-- | private keys to sign with
[SecKey] ->
-- | signed transaction
Either String Tx
signNestedWitnessTx net ctx tx si = Sign.signTx net ctx tx $ nested <$> si
where
-- NOTE: the nesting flag is ignored for non-segwit inputs
nested s = (s, True)
-- | Sign a single input in a transaction deterministically (RFC-6979).
signInput :: Network -> Tx -> Int -> SigInput -> SecKeyI -> Either String Tx
signInput net tx i si = S.signInput net tx i (si, False)
signInput ::
Network -> Ctx -> Tx -> Int -> SigInput -> PrivateKey -> Either String Tx
signInput net ctx tx i si =
Sign.signInput net ctx tx i (si, False)
-- | Like 'signInput' but treat segwit inputs as nested
signNestedInput :: Network -> Tx -> Int -> SigInput -> SecKeyI -> Either String Tx
signNestedInput net tx i si = S.signInput net tx i (si, True)
signNestedInput ::
Network -> Ctx -> Tx -> Int -> SigInput -> PrivateKey -> Either String Tx
signNestedInput net ctx tx i si =
Sign.signInput net ctx tx i (si, True)
{- | Order the 'SigInput' with respect to the transaction inputs. This allows
the user to provide the 'SigInput' in any order. Users can also provide only
a partial set of 'SigInput' entries.
-}
-- | Order the 'SigInput' with respect to the transaction inputs. This allows
-- the user to provide the 'SigInput' in any order. Users can also provide only
-- a partial set of 'SigInput' entries.
findSigInput :: [SigInput] -> [TxIn] -> [(SigInput, Int)]
findSigInput = S.findInputIndex sigInputOP
findSigInput = Sign.findInputIndex (.outpoint)
{- Merge multisig transactions -}
{- | Merge partially-signed multisig transactions. This function does not
support segwit and P2SH-segwit inputs. Use PSBTs to merge transactions with
segwit inputs.
-}
-- | Merge partially-signed multisig transactions. This function does not
-- support segwit and P2SH-segwit inputs. Use PSBTs to merge transactions with
-- segwit inputs.
mergeTxs ::
Network -> [Tx] -> [(ScriptOutput, Word64, OutPoint)] -> Either String Tx
mergeTxs net txs os
| null txs = Left "Transaction list is empty"
| length (nub emptyTxs) /= 1 = Left "Transactions do not match"
| length txs == 1 = return $ head txs
| otherwise = foldM (mergeTxInput net txs) (head emptyTxs) outs
Network ->
Ctx ->
[Tx] ->
[(ScriptOutput, Word64, OutPoint)] ->
Either String Tx
mergeTxs net ctx txs os
| null txs = Left "Transaction list is empty"
| length (nub emptyTxs) /= 1 = Left "Transactions do not match"
| length txs == 1 = return $ head txs
| otherwise = foldM (mergeTxInput net ctx txs) (head emptyTxs) outs
where
zipOp = zip (matchTemplate os (txIn $ head txs) f) [0 ..]
zipOp = zip (matchTemplate os (head txs).inputs f) [0 ..]
outs =
map (first $ (\(o, v, _) -> (o, v)) . fromJust) $
filter (isJust . fst) zipOp
f (_, _, o) txin = o == prevOutput txin
map (first $ (\(o, v, _) -> (o, v)) . fromJust) $
filter (isJust . fst) zipOp
f (_, _, o) txin = o == txin.outpoint
emptyTxs = map (\tx -> foldl clearInput tx outs) txs
ins is i = updateIndex i is (\ti -> ti{scriptInput = B.empty})
ins is i = updateIndex i is (\TxIn {..} -> TxIn {script = B.empty, ..})
clearInput tx (_, i) =
Tx (txVersion tx) (ins (txIn tx) i) (txOut tx) [] (txLockTime tx)
Tx tx.version (ins tx.inputs i) tx.outputs [] tx.locktime
{- | Merge input from partially-signed multisig transactions. This function
does not support segwit and P2SH-segwit inputs.
-}
-- | Merge input from partially-signed multisig transactions. This function
-- does not support segwit and P2SH-segwit inputs.
mergeTxInput ::
Network ->
[Tx] ->
Tx ->
((ScriptOutput, Word64), Int) ->
Either String Tx
mergeTxInput net txs tx ((so, val), i) = do
-- Ignore transactions with empty inputs
let ins = map (scriptInput . (!! i) . txIn) txs
sigRes <- mapM extractSigs $ filter (not . B.null) ins
let rdm = snd $ head sigRes
unless (all ((== rdm) . snd) sigRes) $ Left "Redeem scripts do not match"
si <- encodeInputBS <$> go (nub $ concatMap fst sigRes) so rdm
let ins' = updateIndex i (txIn tx) (\ti -> ti{scriptInput = si})
return $ Tx (txVersion tx) ins' (txOut tx) [] (txLockTime tx)
Network ->
Ctx ->
[Tx] ->
Tx ->
((ScriptOutput, Word64), Int) ->
Either String Tx
mergeTxInput net ctx txs tx ((so, val), i) = do
-- Ignore transactions with empty inputs
let ins = map ((.script) . (!! i) . (.inputs)) txs
sigRes <- mapM extractSigs $ filter (not . B.null) ins
let rdm = snd $ head sigRes
unless (all ((== rdm) . snd) sigRes) $ Left "Redeem scripts do not match"
si <- marshal (net, ctx) <$> go (nub $ concatMap fst sigRes) so rdm
let ins' = updateIndex i tx.inputs (\TxIn {..} -> TxIn {script = si, ..})
return $ Tx tx.version ins' tx.outputs [] tx.locktime
where
go allSigs out rdmM =
case out of
PayMulSig msPubs r ->
let sigs =
take r $
catMaybes $ matchTemplate allSigs msPubs $ f out
in return $ RegularInput $ SpendMulSig sigs
PayScriptHash _ ->
case rdmM of
Just rdm -> do
si <- go allSigs rdm Nothing
return $ ScriptHashInput (getRegularInput si) rdm
_ -> Left "Invalid output script type"
case out of
PayMulSig msPubs r ->
let sigs =
take r $
catMaybes $
matchTemplate allSigs msPubs $
f out
in return $ RegularInput $ SpendMulSig sigs
PayScriptHash _ ->
case rdmM of
Just rdm -> do
si <- go allSigs rdm Nothing
return $ ScriptHashInput si.get rdm
_ -> Left "Invalid output script type"
_ -> Left "Invalid output script type"
extractSigs si =
case decodeInputBS net si of
Right (RegularInput (SpendMulSig sigs)) -> Right (sigs, Nothing)
Right (ScriptHashInput (SpendMulSig sigs) rdm) ->
Right (sigs, Just rdm)
_ -> Left "Invalid script input type"
case unmarshal (net, ctx) si of
Right (RegularInput (SpendMulSig sigs)) ->
Right (sigs, Nothing)
Right (ScriptHashInput (SpendMulSig sigs) rdm) ->
Right (sigs, Just rdm)
_ -> Left "Invalid script input type"
f out (TxSignature x sh) p =
verifyHashSig
(txSigHash net tx (encodeOutput out) val i sh)
x
(pubKeyPoint p)
verifyHashSig
ctx
(txSigHash net tx (encodeOutput ctx out) val i sh)
x
p.point
f _ TxSignatureEmpty _ = False
{- Tx verification -}
-- | Verify if a transaction is valid and all of its inputs are standard.
verifyStdTx :: Network -> Tx -> [(ScriptOutput, Word64, OutPoint)] -> Bool
verifyStdTx net tx xs =
not (null (txIn tx)) && all go (zip (matchTemplate xs (txIn tx) f) [0 ..])
verifyStdTx ::
Network -> Ctx -> Tx -> [(ScriptOutput, Word64, OutPoint)] -> Bool
verifyStdTx net ctx tx xs =
not (null tx.inputs) && all go (zip (matchTemplate xs tx.inputs f) [0 ..])
where
f (_, _, o) txin = o == prevOutput txin
go (Just (so, val, _), i) = verifyStdInput net tx i so val
f (_, _, o) txin = o == txin.outpoint
go (Just (so, val, _), i) = verifyStdInput net ctx tx i so val
go _ = False
-- | Verify if a transaction input is valid and standard.
verifyStdInput :: Network -> Tx -> Int -> ScriptOutput -> Word64 -> Bool
verifyStdInput net tx i so0 val
| isSegwit so0 =
fromRight False $ (inp == mempty &&) . verifySegwitInput so0 <$> wp so0
| otherwise =
fromRight False $
(verifyLegacyInput so0 <$> decodeInputBS net inp)
<|> (nestedScriptOutput >>= \so -> verifyNestedInput so0 so <$> wp so)
verifyStdInput :: Network -> Ctx -> Tx -> Int -> ScriptOutput -> Word64 -> Bool
verifyStdInput net ctx tx i so0 val
| isSegwit so0 =
fromRight False $ (inp == mempty &&) . verifySegwitInput so0 <$> wp so0
| otherwise =
fromRight False $
(verifyLegacyInput so0 <$> unmarshal (net, ctx) inp)
<|> (nestedScriptOutput >>= \so -> verifyNestedInput so0 so <$> wp so)
where
inp = scriptInput $ txIn tx !! i
theTxSigHash so = S.makeSigHash net tx i so val
inp = (tx.inputs !! i).script
theTxSigHash so = Sign.makeSigHash net ctx tx i so val
ws :: WitnessStack
ws
| length (txWitness tx) > i = txWitness tx !! i
| otherwise = []
| length tx.witness > i = tx.witness !! i
| otherwise = []
wp :: ScriptOutput -> Either String (Maybe ScriptOutput, SimpleInput)
wp so = decodeWitnessInput net =<< viewWitnessProgram net so ws
wp so = decodeWitnessInput net ctx =<< viewWitnessProgram net ctx so ws
nestedScriptOutput :: Either String ScriptOutput
nestedScriptOutput =
scriptOps <$> runGetS deserialize inp >>= \case
[OP_PUSHDATA bs _] -> decodeOutputBS bs
_ -> Left "nestedScriptOutput: not a nested output"
runGetS deserialize inp >>= dec . ops
where
ops (Script ops') = ops'
dec = \case
[OP_PUSHDATA bs _] -> unmarshal ctx bs
_ -> Left "nestedScriptOutput: not a nested output"
verifyLegacyInput :: ScriptOutput -> ScriptInput -> Bool
verifyLegacyInput so si = case (so, si) of
(PayPK pub, RegularInput (SpendPK (TxSignature sig sh))) ->
verifyHashSig (theTxSigHash so sh Nothing) sig (pubKeyPoint pub)
(PayPKHash h, RegularInput (SpendPKHash (TxSignature sig sh) pub)) ->
pubKeyAddr pub == p2pkhAddr h
&& verifyHashSig (theTxSigHash so sh Nothing) sig (pubKeyPoint pub)
(PayMulSig pubs r, RegularInput (SpendMulSig sigs)) ->
countMulSig net tx out val i (pubKeyPoint <$> pubs) sigs == r
(PayScriptHash h, ScriptHashInput si' rdm) ->
payToScriptAddress rdm == p2shAddr h && verifyLegacyInput rdm (RegularInput si')
_ -> False
(PayPK pub, RegularInput (SpendPK (TxSignature sig sh))) ->
verifyHashSig ctx (theTxSigHash so sh Nothing) sig pub.point
(PayPKHash h, RegularInput (SpendPKHash (TxSignature sig sh) pub)) ->
pubKeyAddr ctx pub == p2pkhAddr h
&& verifyHashSig ctx (theTxSigHash so sh Nothing) sig pub.point
(PayMulSig pubs r, RegularInput (SpendMulSig sigs)) ->
countMulSig net ctx tx out val i ((.point) <$> pubs) sigs == r
(PayScriptHash h, ScriptHashInput si' rdm) ->
payToScriptAddress ctx rdm == p2shAddr h && verifyLegacyInput rdm (RegularInput si')
_ -> False
where
out = encodeOutput so
out = encodeOutput ctx so
verifySegwitInput ::
ScriptOutput -> (Maybe ScriptOutput, SimpleInput) -> Bool
ScriptOutput -> (Maybe ScriptOutput, SimpleInput) -> Bool
verifySegwitInput so (rdm, si) = case (so, rdm, si) of
(PayWitnessPKHash h, Nothing, SpendPKHash (TxSignature sig sh) pub) ->
pubKeyWitnessAddr pub == p2wpkhAddr h
&& verifyHashSig (theTxSigHash so sh Nothing) sig (pubKeyPoint pub)
(PayWitnessScriptHash h, Just rdm'@(PayPK pub), SpendPK (TxSignature sig sh)) ->
payToWitnessScriptAddress rdm' == p2wshAddr h
&& verifyHashSig (theTxSigHash so sh $ Just rdm') sig (pubKeyPoint pub)
(PayWitnessScriptHash h, Just rdm'@(PayPKHash kh), SpendPKHash (TxSignature sig sh) pub) ->
payToWitnessScriptAddress rdm' == p2wshAddr h
&& addressHash (runPutS (serialize pub)) == kh
&& verifyHashSig (theTxSigHash so sh $ Just rdm') sig (pubKeyPoint pub)
(PayWitnessScriptHash h, Just rdm'@(PayMulSig pubs r), SpendMulSig sigs) ->
payToWitnessScriptAddress rdm' == p2wshAddr h
&& countMulSig' (\sh -> theTxSigHash so sh $ Just rdm') (pubKeyPoint <$> pubs) sigs == r
_ -> False
( PayWitnessPKHash h,
Nothing,
SpendPKHash (TxSignature sig sh) pub
) ->
let keytest = pubKeyWitnessAddr ctx pub == p2wpkhAddr h
sighash = theTxSigHash so sh Nothing
pkpoint = pub.point
verify = verifyHashSig ctx sighash sig pkpoint
in keytest && verify
( PayWitnessScriptHash h,
Just rdm'@(PayPK pub),
SpendPK (TxSignature sig sh)
) ->
let keytest = payToWitnessScriptAddress ctx rdm' == p2wshAddr h
sighash = theTxSigHash so sh $ Just rdm'
pkpoint = pub.point
verify = verifyHashSig ctx sighash sig pkpoint
in keytest && verify
( PayWitnessScriptHash h,
Just rdm'@(PayPKHash kh),
SpendPKHash (TxSignature sig sh) pub
) ->
let keytest = payToWitnessScriptAddress ctx rdm' == p2wshAddr h
addrtest = addressHash (marshal ctx pub) == kh
pkpoint = pub.point
sighash = theTxSigHash so sh $ Just rdm'
verify = verifyHashSig ctx sighash sig pkpoint
in keytest && addrtest && verify
( PayWitnessScriptHash h,
Just rdm'@(PayMulSig pubs r),
SpendMulSig sigs
) ->
let keytest = payToWitnessScriptAddress ctx rdm' == p2wshAddr h
pkpoints = (.point) <$> pubs
hashfun sh = theTxSigHash so sh $ Just rdm'
verify = countMulSig' ctx hashfun pkpoints sigs == r
in keytest && verify
_ -> False
verifyNestedInput ::
ScriptOutput -> ScriptOutput -> (Maybe RedeemScript, SimpleInput) -> Bool
ScriptOutput -> ScriptOutput -> (Maybe RedeemScript, SimpleInput) -> Bool
verifyNestedInput so so' x = case so of
PayScriptHash h -> payToScriptAddress so' == p2shAddr h && verifySegwitInput so' x
_ -> False
PayScriptHash h -> payToScriptAddress ctx so' == p2shAddr h && verifySegwitInput so' x
_ -> False
-- | Count the number of valid signatures for a multi-signature transaction.
countMulSig ::
Network ->
Tx ->
Script ->
Word64 ->
Int ->
[PubKey] ->
[TxSignature] ->
Int
countMulSig net tx out val i =
countMulSig' h
Network ->
Ctx ->
Tx ->
Script ->
Word64 ->
Int ->
[PubKey] ->
[TxSignature] ->
Int
countMulSig net ctx tx out val i =
countMulSig' ctx h
where
h = txSigHash net tx out val i
countMulSig' :: (SigHash -> Hash256) -> [PubKey] -> [TxSignature] -> Int
countMulSig' _ [] _ = 0
countMulSig' _ _ [] = 0
countMulSig' h (_ : pubs) (TxSignatureEmpty : sigs) = countMulSig' h pubs sigs
countMulSig' h (pub : pubs) sigs@(TxSignature sig sh : sigs')
| verifyHashSig (h sh) sig pub = 1 + countMulSig' h pubs sigs'
| otherwise = countMulSig' h pubs sigs
countMulSig' :: Ctx -> (SigHash -> Hash256) -> [PubKey] -> [TxSignature] -> Int
countMulSig' _ _ [] _ = 0
countMulSig' _ _ _ [] = 0
countMulSig' ctx h (_ : pubs) (TxSignatureEmpty : sigs) =
countMulSig' ctx h pubs sigs
countMulSig' ctx h (pub : pubs) sigs@(TxSignature sig sh : sigs')
| verifyHashSig ctx (h sh) sig pub = 1 + countMulSig' ctx h pubs sigs'
| otherwise = countMulSig' ctx h pubs sigs

513
src/Haskoin/Transaction/Builder/Sign.hs
View File

@ -1,20 +1,25 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoFieldSelectors #-}
{- |
Module : Haskoin.Transaction.Builder.Sign
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
Types and logic for signing transactions.
-}
module Haskoin.Transaction.Builder.Sign (
SigInput (..),
-- |
-- Module : Haskoin.Transaction.Builder.Sign
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- Types and logic for signing transactions.
module Haskoin.Transaction.Builder.Sign
( SigInput (..),
makeSignature,
makeSigHash,
signTx,
@ -22,298 +27,296 @@ module Haskoin.Transaction.Builder.Sign (
signInput,
buildInput,
sigKeys,
) where
)
where
import Control.DeepSeq (NFData)
import Control.Monad (foldM, when)
import Data.Aeson (
FromJSON,
ToJSON (..),
object,
pairs,
parseJSON,
withObject,
(.:),
(.:?),
(.=),
)
import Control.DeepSeq
import Control.Monad
import Crypto.Secp256k1
import Data.Aeson
import Data.Aeson.Encoding
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import Data.Either (rights)
import Data.Hashable (Hashable)
import Data.List (find, nub)
import Data.Maybe (
catMaybes,
fromMaybe,
mapMaybe,
maybeToList,
)
import Data.Word (Word64)
import GHC.Generics (Generic)
import Haskoin.Address (getAddrHash160, pubKeyAddr)
import Haskoin.Crypto (Hash256, SecKey)
import Haskoin.Crypto.Signature (signHash, verifyHashSig)
import Haskoin.Data (Network)
import Haskoin.Keys.Common (
PubKeyI (..),
SecKeyI (..),
derivePubKeyI,
wrapSecKey,
)
import Data.Either
import Data.Hashable
import Data.List
import Data.Maybe
import Data.Word
import GHC.Generics
import Haskoin.Address
import Haskoin.Crypto.Hash
import Haskoin.Crypto.Keys.Common
import Haskoin.Crypto.Signature
import Haskoin.Network.Data
import Haskoin.Script
import Haskoin.Transaction.Common
import Haskoin.Transaction.Segwit
import Haskoin.Util (matchTemplate, updateIndex)
import Haskoin.Util
{- | Data type used to specify the signing parameters of a transaction input.
To sign an input, the previous output script, outpoint and sighash are
required. When signing a pay to script hash output, an additional redeem
script is required.
-}
-- | Data type used to specify the signing parameters of a transaction input.
-- To sign an input, the previous output script, outpoint and sighash are
-- required. When signing a pay to script hash output, an additional redeem
-- script is required.
data SigInput = SigInput
{ -- | output script to spend
-- ^ output script value
sigInputScript :: !ScriptOutput
, -- | output script value
-- ^ outpoint to spend
sigInputValue :: !Word64
, -- | outpoint to spend
-- ^ signature type
sigInputOP :: !OutPoint
, -- | signature type
-- ^ redeem script
sigInputSH :: !SigHash
, -- | redeem script
sigInputRedeem :: !(Maybe RedeemScript)
}
deriving (Eq, Show, Read, Generic, Hashable, NFData)
{ -- | output script to spend
-- ^ output script value
script :: !ScriptOutput,
-- | output script value
-- ^ outpoint to spend
value :: !Word64,
-- | outpoint to spend
-- ^ signature type
outpoint :: !OutPoint,
-- | signature type
-- ^ redeem script
sighash :: !SigHash,
-- | redeem script
redeem :: !(Maybe RedeemScript)
}
deriving (Show, Read, Eq, Generic, NFData)
instance ToJSON SigInput where
toJSON (SigInput so val op sh rdm) =
object $
[ "pkscript" .= so
, "value" .= val
, "outpoint" .= op
, "sighash" .= sh
]
++ ["redeem" .= r | r <- maybeToList rdm]
toEncoding (SigInput so val op sh rdm) =
pairs $
"pkscript" .= so
<> "value" .= val
<> "outpoint" .= op
<> "sighash" .= sh
<> maybe mempty ("redeem" .=) rdm
instance MarshalJSON Ctx SigInput where
marshalValue ctx (SigInput s v o h r) =
object $
[ "pkscript" .= marshalValue ctx s,
"value" .= v,
"outpoint" .= o,
"sighash" .= h
]
++ [ "redeem" .= marshalValue ctx r
| r <- maybeToList r
]
instance FromJSON SigInput where
parseJSON =
withObject "SigInput" $ \o ->
SigInput <$> o .: "pkscript"
<*> o .: "value"
<*> o .: "outpoint"
<*> o .: "sighash"
<*> o .:? "redeem"
marshalEncoding ctx (SigInput s v o h r) =
pairs $
mconcat
[ "pkscript" `pair` marshalEncoding ctx s,
"value" `pair` word64 v,
"outpoint" `pair` toEncoding o,
"sighash" `pair` toEncoding h,
maybe mempty (pair "redeem" . marshalEncoding ctx) r
]
{- | Sign a transaction by providing the 'SigInput' signing parameters and a
list of private keys. The signature is computed deterministically as defined
in RFC-6979.
-}
unmarshalValue ctx =
withObject "SigInput" $ \o ->
SigInput
<$> (unmarshalValue ctx =<< o .: "pkscript")
<*> o .: "value"
<*> o .: "outpoint"
<*> o .: "sighash"
<*> (mapM (unmarshalValue ctx) =<< o .:? "redeem")
-- | Sign a transaction by providing the 'SigInput' signing parameters and a
-- list of private keys. The signature is computed deterministically as defined
-- in RFC-6979.
signTx ::
Network ->
-- | transaction to sign
Tx ->
-- | signing parameters, with nesting flag
[(SigInput, Bool)] ->
-- | private keys to sign with
[SecKey] ->
-- | signed transaction
Either String Tx
signTx net otx sigis allKeys
| null ti = Left "signTx: Transaction has no inputs"
| otherwise = foldM go otx $ findInputIndex (sigInputOP . fst) sigis ti
Network ->
Ctx ->
-- | transaction to sign
Tx ->
-- | signing parameters, with nesting flag
[(SigInput, Bool)] ->
-- | private keys to sign with
[SecKey] ->
-- | signed transaction
Either String Tx
signTx net ctx otx sigis allKeys
| null ti = Left "signTx: Transaction has no inputs"
| otherwise = foldM go otx $ findInputIndex ((.outpoint) . fst) sigis ti
where
ti = txIn otx
ti = otx.inputs
go tx (sigi@(SigInput so _ _ _ rdmM, _), i) = do
keys <- sigKeys so rdmM allKeys
foldM (\t k -> signInput net t i sigi k) tx keys
keys <- sigKeys ctx so rdmM allKeys
foldM (\t k -> signInput net ctx t i sigi k) tx keys
{- | Sign a single input in a transaction deterministically (RFC-6979). The
nesting flag only affects the behavior of segwit inputs.
-}
-- | Sign a single input in a transaction deterministically (RFC-6979). The
-- nesting flag only affects the behavior of segwit inputs.
signInput ::
Network ->
Tx ->
Int ->
-- | boolean flag: nest input
(SigInput, Bool) ->
SecKeyI ->
Either String Tx
signInput net tx i (sigIn@(SigInput so val _ _ rdmM), nest) key = do
let sig = makeSignature net tx i sigIn key
si <- buildInput net tx i so val rdmM sig $ derivePubKeyI key
w <- updatedWitnessData tx i so si
return
tx
{ txIn = nextTxIn so si
, txWitness = w
}
Network ->
Ctx ->
Tx ->
Int ->
-- | boolean flag: nest input
(SigInput, Bool) ->
PrivateKey ->
Either String Tx
signInput net ctx tx i (sigIn@(SigInput so val _ _ rdmM), nest) key = do
let sig = makeSignature net ctx tx i sigIn key
si <- buildInput net ctx tx i so val rdmM sig $ derivePublicKey ctx key
w <- updatedWitnessData net ctx tx i so si
return tx {inputs = nextTxIn so si, witness = w}
where
f si x = x{scriptInput = encodeInputBS si}
g so' x = x{scriptInput = runPutS . serialize . opPushData $ encodeOutputBS so'}
txis = txIn tx
f si TxIn {..} = TxIn {script = marshal (net, ctx) si, ..}
g so' TxIn {..} = TxIn {script = pkScript so', ..}
pkScript so' = runPutS . serialize . opPushData $ marshal ctx so'
nextTxIn so' si
| isSegwit so' && nest = updateIndex i txis (g so')
| isSegwit so' = txIn tx
| otherwise = updateIndex i txis (f si)
| isSegwit so' && nest = updateIndex i tx.inputs (g so')
| isSegwit so' = tx.inputs
| otherwise = updateIndex i tx.inputs (f si)
{- | Add the witness data of the transaction given segwit parameters for an input.
@since 0.11.0.0
-}
updatedWitnessData :: Tx -> Int -> ScriptOutput -> ScriptInput -> Either String WitnessData
updatedWitnessData tx i so si
| isSegwit so = updateWitness . toWitnessStack =<< calcWitnessProgram so si
| otherwise = return $ txWitness tx
-- | Add the witness data of the transaction given segwit parameters for an input.
--
-- @since 0.11.0.0
updatedWitnessData ::
Network ->
Ctx ->
Tx ->
Int ->
ScriptOutput ->
ScriptInput ->
Either String WitnessData
updatedWitnessData net ctx tx i so si
| isSegwit so =
updateWitness . toWitnessStack net ctx =<< calcWitnessProgram net ctx so si
| otherwise =
return tx.witness
where
updateWitness w
| null $ txWitness tx = return $ updateIndex i defaultStack (const w)
| length (txWitness tx) /= n = Left "Invalid number of witness stacks"
| otherwise = return $ updateIndex i (txWitness tx) (const w)
defaultStack = replicate n $ toWitnessStack EmptyWitnessProgram
n = length $ txIn tx
| null tx.witness = return $ updateIndex i defaultStack (const w)
| length tx.witness /= n = Left "Invalid number of witness stacks"
| otherwise = return $ updateIndex i tx.witness (const w)
defaultStack = replicate n $ toWitnessStack net ctx EmptyWitnessProgram
n = length tx.inputs
-- | Associate an input index to each value in a list
findInputIndex ::
-- | extract an outpoint
(a -> OutPoint) ->
-- | input list
[a] ->
-- | reference list of inputs
[TxIn] ->
[(a, Int)]
-- | extract an outpoint
(a -> OutPoint) ->
-- | input list
[a] ->
-- | reference list of inputs
[TxIn] ->
[(a, Int)]
findInputIndex getOutPoint as ti =
mapMaybe g $ zip (matchTemplate as ti f) [0 ..]
mapMaybe g $ zip (matchTemplate as ti f) [0 ..]
where
f s txin = getOutPoint s == prevOutput txin
f s txin = getOutPoint s == txin.outpoint
g (Just s, i) = Just (s, i)
g (Nothing, _) = Nothing
{- | Find from the list of provided private keys which one is required to sign
the 'ScriptOutput'.
-}
-- | Find from the list of provided private keys which one is required to sign
-- the 'ScriptOutput'.
sigKeys ::
ScriptOutput ->
Maybe RedeemScript ->
[SecKey] ->
Either String [SecKeyI]
sigKeys so rdmM keys =
case (so, rdmM) of
(PayPK p, Nothing) ->
return . map fst . maybeToList $ find ((== p) . snd) zipKeys
(PayPKHash h, Nothing) -> return $ keyByHash h
(PayMulSig ps r, Nothing) ->
return $ map fst $ take r $ filter ((`elem` ps) . snd) zipKeys
(PayScriptHash _, Just rdm) -> sigKeys rdm Nothing keys
(PayWitnessPKHash h, _) -> return $ keyByHash h
(PayWitnessScriptHash _, Just rdm) -> sigKeys rdm Nothing keys
_ -> Left "sigKeys: Could not decode output script"
Ctx ->
ScriptOutput ->
Maybe RedeemScript ->
[SecKey] ->
Either String [PrivateKey]
sigKeys ctx so rdmM keys =
case (so, rdmM) of
(PayPK p, Nothing) ->
return . map fst . maybeToList $ find ((== p) . snd) zipKeys
(PayPKHash h, Nothing) -> return $ keyByHash h
(PayMulSig ps r, Nothing) ->
return $ map fst $ take r $ filter ((`elem` ps) . snd) zipKeys
(PayScriptHash _, Just rdm) -> sigKeys ctx rdm Nothing keys
(PayWitnessPKHash h, _) -> return $ keyByHash h
(PayWitnessScriptHash _, Just rdm) -> sigKeys ctx rdm Nothing keys
_ -> Left "sigKeys: Could not decode output script"
where
zipKeys =
[ (prv, pub)
| k <- keys
, t <- [True, False]
, let prv = wrapSecKey t k
, let pub = derivePubKeyI prv
]
[ (prv, pub)
| k <- keys,
t <- [True, False],
let prv = wrapSecKey t k,
let pub = derivePublicKey ctx prv
]
keyByHash h = fmap fst . maybeToList . findKey h $ zipKeys
findKey h = find $ (== h) . getAddrHash160 . pubKeyAddr . snd
findKey h = find $ (== h) . (.hash160) . pubKeyAddr ctx . snd
{- | Construct an input for a transaction given a signature, public key and data
about the previous output.
-}
-- | Construct an input for a transaction given a signature, public key and data
-- about the previous output.
buildInput ::
Network ->
-- | transaction where input will be added
Tx ->
-- | input index where signature will go
Int ->
-- | output script being spent
ScriptOutput ->
-- | amount of previous output
Word64 ->
-- | redeem script if pay-to-script-hash
Maybe RedeemScript ->
TxSignature ->
PubKeyI ->
Either String ScriptInput
buildInput net tx i so val rdmM sig pub = do
when (i >= length (txIn tx)) $ Left "buildInput: Invalid input index"
case (so, rdmM) of
(PayScriptHash _, Just rdm) -> buildScriptHashInput rdm
(PayWitnessScriptHash _, Just rdm) -> buildScriptHashInput rdm
(PayWitnessPKHash _, Nothing) -> return . RegularInput $ SpendPKHash sig pub
(_, Nothing) -> buildRegularInput so
_ -> Left "buildInput: Invalid output/redeem script combination"
Network ->
Ctx ->
-- | transaction where input will be added
Tx ->
-- | input index where signature will go
Int ->
-- | output script being spent
ScriptOutput ->
-- | amount of previous output
Word64 ->
-- | redeem script if pay-to-script-hash
Maybe RedeemScript ->
TxSignature ->
PublicKey ->
Either String ScriptInput
buildInput net ctx tx i so val rdmM sig pub = do
when (i >= length tx.inputs) $ Left "buildInput: Invalid input index"
case (so, rdmM) of
(PayScriptHash _, Just rdm) ->
buildScriptHashInput rdm
(PayWitnessScriptHash _, Just rdm) ->
buildScriptHashInput rdm
(PayWitnessPKHash _, Nothing) ->
return . RegularInput $ SpendPKHash sig pub
(_, Nothing) ->
buildRegularInput so
_ -> Left "buildInput: Invalid output/redeem script combination"
where
buildRegularInput = \case
PayPK _ -> return $ RegularInput $ SpendPK sig
PayPKHash _ -> return $ RegularInput $ SpendPKHash sig pub
PayMulSig msPubs r -> do
let mSigs = take r $ catMaybes $ matchTemplate allSigs msPubs f
allSigs = nub $ sig : parseExistingSigs net tx so i
return $ RegularInput $ SpendMulSig mSigs
_ -> Left "buildInput: Invalid output/redeem script combination"
PayPK _ -> return $ RegularInput $ SpendPK sig
PayPKHash _ -> return $ RegularInput $ SpendPKHash sig pub
PayMulSig msPubs r -> do
let mSigs = take r $ catMaybes $ matchTemplate allSigs msPubs f
allSigs = nub $ sig : parseExistingSigs net ctx tx so i
return $ RegularInput $ SpendMulSig mSigs
_ -> Left "buildInput: Invalid output/redeem script combination"
buildScriptHashInput rdm = do
inp <- buildRegularInput rdm
return $ ScriptHashInput (getRegularInput inp) rdm
inp <- buildRegularInput rdm
return $ ScriptHashInput inp.get rdm
f (TxSignature x sh) p =
verifyHashSig (makeSigHash net tx i so val sh rdmM) x (pubKeyPoint p)
verifyHashSig
ctx
(makeSigHash net ctx tx i so val sh rdmM)
x
p.point
f TxSignatureEmpty _ = False
{- | Apply heuristics to extract the signatures for a particular input that are
embedded in the transaction.
@since 0.11.0.0
-}
parseExistingSigs :: Network -> Tx -> ScriptOutput -> Int -> [TxSignature]
parseExistingSigs net tx so i = insSigs <> witSigs
-- | Apply heuristics to extract the signatures for a particular input that are
-- embedded in the transaction.
--
-- @since 0.11.0.0
parseExistingSigs :: Network -> Ctx -> Tx -> ScriptOutput -> Int -> [TxSignature]
parseExistingSigs net ctx tx so i = insSigs <> witSigs
where
insSigs = case decodeInputBS net scp of
Right (ScriptHashInput (SpendMulSig xs) _) -> xs
Right (RegularInput (SpendMulSig xs)) -> xs
_ -> []
scp = scriptInput $ txIn tx !! i
insSigs = case unmarshal (net, ctx) scp of
Right (ScriptHashInput (SpendMulSig xs) _) -> xs
Right (RegularInput (SpendMulSig xs)) -> xs
_ -> []
scp = (tx.inputs !! i).script
witSigs
| not $ isSegwit so = []
| null $ txWitness tx = []
| otherwise = rights $ decodeTxSig net <$> (txWitness tx !! i)
| not $ isSegwit so = []
| null tx.witness = []
| otherwise = rights $ decodeTxSig net ctx <$> (tx.witness !! i)
-- | Produce a structured representation of a deterministic (RFC-6979) signature over an input.
makeSignature :: Network -> Tx -> Int -> SigInput -> SecKeyI -> TxSignature
makeSignature net tx i (SigInput so val _ sh rdmM) key =
TxSignature (signHash (secKeyData key) m) sh
makeSignature :: Network -> Ctx -> Tx -> Int -> SigInput -> PrivateKey -> TxSignature
makeSignature net ctx tx i (SigInput so val _ sh rdmM) key =
TxSignature (signHash ctx key.key m) sh
where
m = makeSigHash net tx i so val sh rdmM
m = makeSigHash net ctx tx i so val sh rdmM
{- | A function which selects the digest algorithm and parameters as appropriate
@since 0.11.0.0
-}
-- | A function which selects the digest algorithm and parameters as appropriate
--
-- @since 0.11.0.0
makeSigHash ::
Network ->
Tx ->
Int ->
ScriptOutput ->
Word64 ->
SigHash ->
Maybe RedeemScript ->
Hash256
makeSigHash net tx i so val sh rdmM = h net tx (encodeOutput so') val i sh
Network ->
Ctx ->
Tx ->
Int ->
ScriptOutput ->
Word64 ->
SigHash ->
Maybe RedeemScript ->
Hash256
makeSigHash net ctx tx i so val sh rdmM = h net tx (encodeOutput ctx so') val i sh
where
so' = case so of
PayWitnessPKHash h' -> PayPKHash h'
_ -> fromMaybe so rdmM
PayWitnessPKHash h' -> PayPKHash h'
_ -> fromMaybe so rdmM
h
| isSegwit so = txSigHashForkId
| otherwise = txSigHash
| isSegwit so = txSigHashForkId
| otherwise = txSigHash

515
src/Haskoin/Transaction/Common.hs
View File

@ -1,19 +1,25 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoFieldSelectors #-}
{- |
Module : Haskoin.Transaction.Common
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
Code related to transactions parsing and serialization.
-}
module Haskoin.Transaction.Common (
-- * Transactions
-- |
-- Module : Haskoin.Transaction.Common
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- Code related to transactions parsing and serialization.
module Haskoin.Transaction.Common
( -- * Transactions
Tx (..),
TxIn (..),
TxOut (..),
@ -27,27 +33,20 @@ module Haskoin.Transaction.Common (
txHashToHex,
nosigTxHash,
nullOutPoint,
) where
)
where
import Control.Applicative ((<|>))
import Control.DeepSeq
import Control.Monad (
forM_,
guard,
liftM2,
mzero,
replicateM,
unless,
when,
(<=<),
)
import Control.Monad (forM_, guard, liftM2, mzero, replicateM, unless, when, (<=<))
import Data.Aeson as A
import Data.Aeson.Encoding (unsafeToEncoding)
import Data.Aeson.Encoding qualified as E
import Data.Binary (Binary (..))
import Data.Bool (bool)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.ByteString qualified as B
import Data.ByteString.Builder (char7)
import qualified Data.ByteString.Lazy as BL
import Data.ByteString.Lazy qualified as BL
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
@ -61,67 +60,67 @@ import Data.Word (Word32, Word64)
import GHC.Generics (Generic)
import Haskoin.Crypto.Hash
import Haskoin.Network.Common
import Haskoin.Util
import Haskoin.Util.Helpers
import Text.Read as R
-- | Transaction id: hash of transaction excluding witness data.
newtype TxHash = TxHash {getTxHash :: Hash256}
deriving (Eq, Ord, Generic, Hashable, Serial, NFData)
newtype TxHash = TxHash {get :: Hash256}
deriving (Eq, Ord, Generic)
deriving newtype (Hashable, NFData)
instance Serial TxHash where
serialize (TxHash h) = serialize h
deserialize = TxHash <$> deserialize
instance Serialize TxHash where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance Binary TxHash where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance Show TxHash where
showsPrec _ = shows . txHashToHex
showsPrec _ = shows . txHashToHex
instance Read TxHash where
readPrec = do
R.String str <- R.lexP
maybe R.pfail return $ hexToTxHash $ cs str
readPrec = do
R.String str <- R.lexP
maybe R.pfail return $ hexToTxHash $ cs str
instance IsString TxHash where
fromString s =
let e = error "Could not read transaction hash from hex string"
in fromMaybe e $ hexToTxHash $ cs s
fromString s =
let e = error "Could not read transaction hash from hex string"
in fromMaybe e $ hexToTxHash $ cs s
instance FromJSON TxHash where
parseJSON =
withText "txid" $
maybe mzero return . hexToTxHash
parseJSON =
withText "txid" $
maybe mzero return . hexToTxHash
instance ToJSON TxHash where
toJSON = A.String . txHashToHex
toEncoding h =
unsafeToEncoding $
char7 '"'
<> hexBuilder (BL.reverse (runPutL (serialize h)))
<> char7 '"'
toJSON = A.String . txHashToHex
toEncoding = hexEncoding . BL.reverse . runPutL . serialize
-- | Transaction hash excluding signatures.
nosigTxHash :: Tx -> TxHash
nosigTxHash tx =
TxHash $
doubleSHA256 $
runPutS $
serialize tx{txIn = map clearInput $ txIn tx}
nosigTxHash Tx {..} =
TxHash . doubleSHA256 . runPutS $ serialize tx
where
clearInput ti = ti{scriptInput = B.empty}
tx = Tx {inputs = map clr inputs, ..}
clr TxIn {..} = TxIn {script = B.empty, ..}
-- | Convert transaction hash to hex form, reversing bytes.
txHashToHex :: TxHash -> Text
txHashToHex (TxHash h) = encodeHex (B.reverse (runPutS (serialize h)))
txHashToHex (TxHash h) =
encodeHex . B.reverse . runPutS $ serialize h
-- | Convert transaction hash from hex, reversing bytes.
hexToTxHash :: Text -> Maybe TxHash
hexToTxHash hex = do
bs <- B.reverse <$> decodeHex hex
h <- either (const Nothing) Just (runGetS deserialize bs)
return $ TxHash h
bs <- B.reverse <$> decodeHex hex
h <- either (const Nothing) Just (runGetS deserialize bs)
return $ TxHash h
-- | Witness stack for SegWit transactions.
type WitnessData = [WitnessStack]
@ -134,289 +133,297 @@ type WitnessStackItem = ByteString
-- | Data type representing a transaction.
data Tx = Tx
{ -- | transaction data format version
txVersion :: !Word32
, -- | list of transaction inputs
txIn :: ![TxIn]
, -- | list of transaction outputs
txOut :: ![TxOut]
, -- | witness data for the transaction
txWitness :: !WitnessData
, -- | earliest mining height or time
txLockTime :: !Word32
}
deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData)
{ -- | transaction data format version
version :: !Word32,
-- | list of transaction inputs
inputs :: ![TxIn],
-- | list of transaction outputs
outputs :: ![TxOut],
-- | witness data for the transaction
witness :: !WitnessData,
-- | earliest mining height or time
locktime :: !Word32
}
deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData)
-- | Compute transaction hash.
txHash :: Tx -> TxHash
txHash tx = TxHash . doubleSHA256 . runPutS $ serialize tx{txWitness = []}
txHash tx = TxHash . doubleSHA256 . runPutS $ serialize tx {witness = []}
instance IsString Tx where
fromString =
fromMaybe e . (eitherToMaybe . runGetS deserialize <=< decodeHex) . cs
where
e = error "Could not read transaction from hex string"
fromString =
fromMaybe e . (eitherToMaybe . runGetS deserialize <=< decodeHex) . cs
where
e = error "Could not read transaction from hex string"
instance Serial Tx where
deserialize =
isWitnessTx >>= \w -> if w then parseWitnessTx else parseLegacyTx
serialize tx
| null (txWitness tx) = putLegacyTx tx
| otherwise = putWitnessTx tx
deserialize = isWitnessTx >>= bool parseLegacyTx parseWitnessTx
serialize tx
| null tx.witness = putLegacyTx tx
| otherwise = putWitnessTx tx
instance Binary Tx where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance Serialize Tx where
put = serialize
get = deserialize
put = serialize
get = deserialize
putInOut :: MonadPut m => Tx -> m ()
putInOut :: (MonadPut m) => Tx -> m ()
putInOut tx = do
putVarInt $ length (txIn tx)
forM_ (txIn tx) serialize
putVarInt $ length (txOut tx)
forM_ (txOut tx) serialize
putVarInt $ length tx.inputs
mapM_ serialize tx.inputs
putVarInt $ length tx.outputs
mapM_ serialize tx.outputs
-- | Non-SegWit transaction serializer.
putLegacyTx :: MonadPut m => Tx -> m ()
putLegacyTx :: (MonadPut m) => Tx -> m ()
putLegacyTx tx = do
putWord32le (txVersion tx)
putInOut tx
putWord32le (txLockTime tx)
putWord32le tx.version
putInOut tx
putWord32le tx.locktime
-- | Witness transaciton serializer.
putWitnessTx :: MonadPut m => Tx -> m ()
putWitnessTx :: (MonadPut m) => Tx -> m ()
putWitnessTx tx = do
putWord32le (txVersion tx)
putWord8 0x00
putWord8 0x01
putInOut tx
putWitnessData (txWitness tx)
putWord32le (txLockTime tx)
putWord32le tx.version
putWord8 0x00
putWord8 0x01
putInOut tx
putWitnessData tx.witness
putWord32le tx.locktime
isWitnessTx :: MonadGet m => m Bool
isWitnessTx :: (MonadGet m) => m Bool
isWitnessTx = lookAhead $ do
_ <- getWord32le
m <- getWord8
f <- getWord8
return (m == 0x00 && f == 0x01)
_ <- getWord32le
m <- getWord8
f <- getWord8
return (m == 0x00 && f == 0x01)
-- | Non-SegWit transaction deseralizer.
parseLegacyTx :: MonadGet m => m Tx
parseLegacyTx :: (MonadGet m) => m Tx
parseLegacyTx = do
v <- getWord32le
is <- replicateList =<< deserialize
os <- replicateList =<< deserialize
when (length is == 0x00 && length os == 0x01) $ fail "Witness transaction"
l <- getWord32le
return
Tx
{ txVersion = v
, txIn = is
, txOut = os
, txWitness = []
, txLockTime = l
}
version <- getWord32le
inputs <- rl =<< deserialize
outputs <- rl =<< deserialize
when (length inputs == 0x00 && length outputs == 0x01) $
fail "Witness transaction"
locktime <- getWord32le
return Tx {witness = [], ..}
where
replicateList (VarInt c) = replicateM (fromIntegral c) deserialize
rl (VarInt c) = replicateM (fromIntegral c) deserialize
-- | Witness transaction deserializer.
parseWitnessTx :: MonadGet m => m Tx
parseWitnessTx :: (MonadGet m) => m Tx
parseWitnessTx = do
v <- getWord32le
m <- getWord8
f <- getWord8
unless (m == 0x00 && f == 0x01) $ fail "Not a witness transaction"
is <- replicateList =<< deserialize
os <- replicateList =<< deserialize
w <- parseWitnessData $ length is
l <- getWord32le
return
Tx{txVersion = v, txIn = is, txOut = os, txWitness = w, txLockTime = l}
version <- getWord32le
m <- getWord8
f <- getWord8
unless (m == 0x00 && f == 0x01) $ fail "Not a witness transaction"
inputs <- replicateList =<< deserialize
outputs <- replicateList =<< deserialize
witness <- parseWitnessData $ length inputs
locktime <- getWord32le
return Tx {..}
where
replicateList (VarInt c) = replicateM (fromIntegral c) deserialize
-- | Witness data deserializer. Requires count of inputs.
parseWitnessData :: MonadGet m => Int -> m WitnessData
parseWitnessData :: (MonadGet m) => Int -> m WitnessData
parseWitnessData n = replicateM n parseWitnessStack
where
parseWitnessStack = do
VarInt i <- deserialize
replicateM (fromIntegral i) parseWitnessStackItem
VarInt i <- deserialize
replicateM (fromIntegral i) parseWitnessStackItem
parseWitnessStackItem = do
VarInt i <- deserialize
getByteString $ fromIntegral i
VarInt i <- deserialize
getByteString $ fromIntegral i
-- | Witness data serializer.
putWitnessData :: MonadPut m => WitnessData -> m ()
putWitnessData :: (MonadPut m) => WitnessData -> m ()
putWitnessData = mapM_ putWitnessStack
where
putWitnessStack ws = do
putVarInt $ length ws
mapM_ putWitnessStackItem ws
putVarInt $ length ws
mapM_ putWitnessStackItem ws
putWitnessStackItem bs = do
putVarInt $ B.length bs
putByteString bs
putVarInt $ B.length bs
putByteString bs
instance FromJSON Tx where
parseJSON = withObject "Tx" $ \o ->
Tx <$> o .: "version"
<*> o .: "inputs"
<*> o .: "outputs"
<*> (mapM (mapM f) =<< o .: "witnessdata")
<*> o .: "locktime"
where
f = maybe mzero return . decodeHex
parseJSON = withObject "Tx" $ \o ->
Tx
<$> o .: "version"
<*> o .: "inputs"
<*> o .: "outputs"
<*> (mapM (mapM f) =<< o .: "witnessdata")
<*> o .: "locktime"
where
f = maybe mzero return . decodeHex
instance ToJSON Tx where
toJSON (Tx v i o w l) =
object
[ "version" .= v
, "inputs" .= i
, "outputs" .= o
, "witnessdata" .= fmap (fmap encodeHex) w
, "locktime" .= l
]
toEncoding (Tx v i o w l) =
pairs
( "version" .= v
<> "inputs" .= i
<> "outputs" .= o
<> "witnessdata" .= fmap (fmap encodeHex) w
<> "locktime" .= l
)
toJSON (Tx v i o w l) =
object
[ "version" .= v,
"inputs" .= i,
"outputs" .= o,
"witnessdata" .= fmap (fmap encodeHex) w,
"locktime" .= l
]
toEncoding (Tx v i o w l) =
pairs $
mconcat
[ "version" `E.pair` E.word32 v,
"inputs" `E.pair` E.list toEncoding i,
"outputs" `E.pair` E.list toEncoding o,
"witnessdata" `E.pair` E.list (E.list f) w,
"locktime" `E.pair` E.word32 l
]
where
f = hexEncoding . BL.fromStrict
-- | Data type representing a transaction input.
data TxIn = TxIn
{ -- | output being spent
prevOutput :: !OutPoint
, -- | signatures and redeem script
scriptInput :: !ByteString
, -- | lock-time using sequence numbers (BIP-68)
txInSequence :: !Word32
}
deriving (Eq, Show, Read, Ord, Generic, Hashable, NFData)
{ -- | output being spent
outpoint :: !OutPoint,
-- | signatures and redeem script
script :: !ByteString,
-- | lock-time using sequence numbers (BIP-68)
sequence :: !Word32
}
deriving (Eq, Show, Read, Ord, Generic, Hashable, NFData)
instance Serial TxIn where
deserialize =
TxIn <$> deserialize <*> (readBS =<< deserialize) <*> getWord32le
where
readBS (VarInt len) = getByteString $ fromIntegral len
deserialize =
TxIn <$> deserialize <*> (readBS =<< deserialize) <*> getWord32le
where
readBS (VarInt len) = getByteString $ fromIntegral len
serialize (TxIn o s q) = do
serialize o
putVarInt $ B.length s
putByteString s
putWord32le q
serialize (TxIn o s q) = do
serialize o
putVarInt $ B.length s
putByteString s
putWord32le q
instance Binary TxIn where
get = deserialize
put = serialize
get = deserialize
put = serialize
instance Serialize TxIn where
get = deserialize
put = serialize
get = deserialize
put = serialize
instance FromJSON TxIn where
parseJSON =
withObject "TxIn" $ \o ->
TxIn <$> o .: "prevoutput"
<*> (maybe mzero return . decodeHex =<< o .: "inputscript")
<*> o .: "sequence"
parseJSON =
withObject "TxIn" $ \o ->
TxIn
<$> o .: "prevoutput"
<*> (maybe mzero return . decodeHex =<< o .: "inputscript")
<*> o .: "sequence"
instance ToJSON TxIn where
toJSON (TxIn o s q) =
object
[ "prevoutput" .= o
, "inputscript" .= encodeHex s
, "sequence" .= q
]
toEncoding (TxIn o s q) =
pairs
( "prevoutput" .= o
<> "inputscript" .= encodeHex s
<> "sequence" .= q
)
toJSON (TxIn o s q) =
object
[ "prevoutput" .= o,
"inputscript" .= encodeHex s,
"sequence" .= q
]
toEncoding (TxIn o s q) =
pairs $
mconcat
[ "prevoutput" `E.pair` toEncoding o,
"inputscript" `E.pair` hexEncoding (BL.fromStrict s),
"sequence" `E.pair` E.word32 q
]
-- | Data type representing a transaction output.
data TxOut = TxOut
{ -- | value of output is satoshi
outValue :: !Word64
, -- | pubkey script
scriptOutput :: !ByteString
}
deriving (Eq, Show, Read, Ord, Generic, Hashable, NFData)
{ -- | value of output is satoshi
value :: !Word64,
-- | pubkey script
script :: !ByteString
}
deriving (Eq, Show, Read, Ord, Generic, Hashable, NFData)
instance Serial TxOut where
deserialize = do
val <- getWord64le
VarInt len <- deserialize
TxOut val <$> getByteString (fromIntegral len)
deserialize = do
val <- getWord64le
VarInt len <- deserialize
TxOut val <$> getByteString (fromIntegral len)
serialize (TxOut o s) = do
putWord64le o
putVarInt $ B.length s
putByteString s
serialize (TxOut o s) = do
putWord64le o
putVarInt $ B.length s
putByteString s
instance Binary TxOut where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance Serialize TxOut where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance FromJSON TxOut where
parseJSON =
withObject "TxOut" $ \o ->
TxOut <$> o .: "value"
<*> (maybe mzero return . decodeHex =<< o .: "outputscript")
parseJSON =
withObject "TxOut" $ \o -> do
value <- o .: "value"
t <- o .: "outputscript"
script <- maybe mzero return (decodeHex t)
return TxOut {..}
instance ToJSON TxOut where
toJSON (TxOut o s) =
object ["value" .= o, "outputscript" .= encodeHex s]
toEncoding (TxOut o s) =
pairs ("value" .= o <> "outputscript" .= encodeHex s)
toJSON (TxOut o s) =
object ["value" .= o, "outputscript" .= encodeHex s]
toEncoding (TxOut o s) =
pairs $
mconcat
[ "value" `E.pair` E.word64 o,
"outputscript" `E.pair` hexEncoding (BL.fromStrict s)
]
-- | The 'OutPoint' refers to a transaction output being spent.
data OutPoint = OutPoint
{ -- | hash of previous transaction
outPointHash :: !TxHash
, -- | position of output in previous transaction
outPointIndex :: !Word32
}
deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData)
{ -- | hash of previous transaction
hash :: !TxHash,
-- | position of output in previous transaction
index :: !Word32
}
deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData)
instance Serial OutPoint where
deserialize = do
(h, i) <- liftM2 (,) deserialize getWord32le
return $ OutPoint h i
serialize (OutPoint h i) = serialize h >> putWord32le i
deserialize = do
(h, i) <- liftM2 (,) deserialize getWord32le
return $ OutPoint h i
serialize (OutPoint h i) = serialize h >> putWord32le i
instance Binary OutPoint where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance Serialize OutPoint where
put = serialize
get = deserialize
put = serialize
get = deserialize
instance FromJSON OutPoint where
parseJSON =
withObject "OutPoint" $ \o ->
OutPoint <$> o .: "txid" <*> o .: "index"
parseJSON =
withObject "OutPoint" $ \o ->
OutPoint <$> o .: "txid" <*> o .: "index"
instance ToJSON OutPoint where
toJSON (OutPoint h i) = object ["txid" .= h, "index" .= i]
toEncoding (OutPoint h i) = pairs ("txid" .= h <> "index" .= i)
toJSON (OutPoint h i) = object ["txid" .= h, "index" .= i]
toEncoding (OutPoint h i) =
pairs $
mconcat
[ "txid" `E.pair` toEncoding h,
"index" `E.pair` E.word32 i
]
-- | Outpoint used in coinbase transactions.
nullOutPoint :: OutPoint
nullOutPoint =
OutPoint
{ outPointHash =
"0000000000000000000000000000000000000000000000000000000000000000"
, outPointIndex = maxBound
}
OutPoint
{ hash = "0000000000000000000000000000000000000000000000000000000000000000",
index = maxBound
}

56
src/Haskoin/Transaction/Genesis.hs
View File

@ -1,42 +1,42 @@
{-# LANGUAGE OverloadedStrings #-}
{- |
Module : Haskoin.Transaction.Genesis
Copyright : No rights reserved
License : UNLICENSE
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
-- |
-- Module : Haskoin.Transaction.Genesis
-- Copyright : No rights reserved
-- License : UNLICENSE
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- Code related to transactions parsing and serialization.
module Haskoin.Transaction.Genesis (genesisTx) where
Code related to transactions parsing and serialization.
-}
module Haskoin.Transaction.Genesis (
genesisTx,
) where
import Data.String (fromString)
import Crypto.Secp256k1 (Ctx, importPubKey)
import Data.Bytes.Get (runGetS)
import Haskoin.Crypto.Keys.Common
import Haskoin.Script.Standard
import Haskoin.Transaction.Common
import Haskoin.Util
-- | Transaction from Genesis block.
genesisTx :: Tx
genesisTx =
Tx 1 [txin] [txout] [] locktime
genesisTx :: Ctx -> Tx
genesisTx ctx =
Tx 1 [txin] [txout] [] locktime
where
txin = TxIn outpoint inputBS maxBound
txout = TxOut 5000000000 (encodeOutputBS output)
txout = TxOut 5000000000 (marshal ctx output)
locktime = 0
outpoint = OutPoint z maxBound
Just inputBS =
decodeHex $
fromString $
"04ffff001d0104455468652054696d65732030332f4a616e2f323030392043686"
++ "16e63656c6c6f72206f6e206272696e6b206f66207365636f6e64206261696c6f"
++ "757420666f722062616e6b73"
output =
PayPK $
fromString $
"04678afdb0fe5548271967f1a67130b7105cd6a828e03909a67962e0ea1f61deb"
++ "649f6bc3f4cef38c4f35504e51ec112de5c384df7ba0b8d578a4c702b6bf11d5f"
decodeHex
"04ffff001d0104455468652054696d65732030332f4a616e2f323030392043686\
\16e63656c6c6f72206f6e206272696e6b206f66207365636f6e64206261696c6f\
\757420666f722062616e6b73"
Just pubKeyBS =
decodeHex
"04678afdb0fe5548271967f1a67130b7105cd6a828e03909a67962e0ea1f61deb\
\649f6bc3f4cef38c4f35504e51ec112de5c384df7ba0b8d578a4c702b6bf11d5f"
Right pubKey =
unmarshal ctx pubKeyBS
output = PayPK pubKey
z = "0000000000000000000000000000000000000000000000000000000000000000"

1451
src/Haskoin/Transaction/Partial.hs
View File

File diff suppressed because it is too large Load Diff

261
src/Haskoin/Transaction/Segwit.hs
View File

@ -1,22 +1,23 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoFieldSelectors #-}
{- |
Module : Haskoin.Transaction.Segwit
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
Types to represent segregated witness data and auxilliary functions to
manipulate it. See [BIP 141](https://github.com/bitcoin/bips/blob/master/bip-0141.mediawiki)
and [BIP 143](https://github.com/bitcoin/bips/blob/master/bip-0143.mediawiki) for
details.
-}
module Haskoin.Transaction.Segwit (
-- * Segwit
-- |
-- Module : Haskoin.Transaction.Segwit
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- Types to represent segregated witness data and auxilliary functions to
-- manipulate it. See [BIP 141](https://github.com/bitcoin/bips/blob/master/bip-0141.mediawiki)
-- and [BIP 143](https://github.com/bitcoin/bips/blob/master/bip-0143.mediawiki) for
-- details.
module Haskoin.Transaction.Segwit
( -- * Segwit
WitnessProgram (..),
WitnessProgramPKH (..),
WitnessProgramSH (..),
@ -26,131 +27,149 @@ module Haskoin.Transaction.Segwit (
calcWitnessProgram,
simpleInputStack,
toWitnessStack,
) where
)
where
import Crypto.Secp256k1
import Data.ByteString (ByteString)
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import Haskoin.Data
import Haskoin.Keys.Common
import Haskoin.Script
import Data.Bytes.Get (runGetS)
import Data.Bytes.Put (runPutS)
import Data.Bytes.Serial (Serial (deserialize, serialize))
import Haskoin.Crypto.Keys.Common
import Haskoin.Network.Data
import Haskoin.Script.Common
import Haskoin.Script.SigHash
import Haskoin.Script.Standard
import Haskoin.Transaction.Common
import Haskoin.Util.Marshal
{- | Test if a 'ScriptOutput' is P2WPKH or P2WSH
@since 0.11.0.0
-}
-- | Test if a 'ScriptOutput' is P2WPKH or P2WSH
--
-- @since 0.11.0.0
isSegwit :: ScriptOutput -> Bool
isSegwit = \case
PayWitnessPKHash{} -> True
PayWitnessScriptHash{} -> True
_ -> False
PayWitnessPKHash {} -> True
PayWitnessScriptHash {} -> True
_ -> False
{- | High level represenation of a (v0) witness program
@since 0.11.0.0
-}
-- | High level represenation of a (v0) witness program
--
-- @since 0.11.0.0
data WitnessProgram
= P2WPKH WitnessProgramPKH
| P2WSH WitnessProgramSH
| EmptyWitnessProgram
deriving (Eq, Show)
= P2WPKH WitnessProgramPKH
| P2WSH WitnessProgramSH
| EmptyWitnessProgram
deriving (Eq)
{- | Encode a witness program
-- | Encode a witness program
--
-- @since 0.11.0.0
toWitnessStack :: Network -> Ctx -> WitnessProgram -> WitnessStack
toWitnessStack net ctx = \case
P2WPKH (WitnessProgramPKH sig key) ->
[encodeTxSig net ctx sig, marshal ctx key]
P2WSH (WitnessProgramSH stack scr) ->
stack <> [runPutS (serialize scr)]
EmptyWitnessProgram ->
mempty
@since 0.11.0.0
-}
toWitnessStack :: WitnessProgram -> WitnessStack
toWitnessStack = \case
P2WPKH (WitnessProgramPKH sig key) -> [encodeTxSig sig, runPutS (serialize key)]
P2WSH (WitnessProgramSH stack scr) -> stack <> [runPutS (serialize scr)]
EmptyWitnessProgram -> mempty
{- | High level representation of a P2WPKH witness
@since 0.11.0.0
-}
-- | High level representation of a P2WPKH witness
--
-- @since 0.11.0.0
data WitnessProgramPKH = WitnessProgramPKH
{ witnessSignature :: !TxSignature
, witnessPubKey :: !PubKeyI
}
deriving (Eq, Show)
{ signature :: !TxSignature,
key :: !PublicKey
}
deriving (Eq)
{- | High-level representation of a P2WSH witness
@since 0.11.0.0
-}
-- | High-level representation of a P2WSH witness
--
-- @since 0.11.0.0
data WitnessProgramSH = WitnessProgramSH
{ witnessScriptHashStack :: ![ByteString]
, witnessScriptHashScript :: !Script
}
deriving (Eq, Show)
{ stack :: ![ByteString],
script :: !Script
}
deriving (Eq, Show)
{- | Calculate the witness program from the transaction data
@since 0.11.0.0
-}
-- | Calculate the witness program from the transaction data
--
-- @since 0.11.0.0
viewWitnessProgram ::
Network -> ScriptOutput -> WitnessStack -> Either String WitnessProgram
viewWitnessProgram net so witness = case so of
PayWitnessPKHash _ | length witness == 2 -> do
sig <- decodeTxSig net $ head witness
pubkey <- runGetS deserialize $ witness !! 1
return . P2WPKH $ WitnessProgramPKH sig pubkey
PayWitnessScriptHash _ | not (null witness) -> do
redeemScript <- runGetS deserialize $ last witness
return . P2WSH $ WitnessProgramSH (init witness) redeemScript
_
| null witness -> return EmptyWitnessProgram
| otherwise -> Left "viewWitnessProgram: Invalid witness program"
Network ->
Ctx ->
ScriptOutput ->
WitnessStack ->
Either String WitnessProgram
viewWitnessProgram net ctx so witness = case so of
PayWitnessPKHash _ | length witness == 2 -> do
sig <- decodeTxSig net ctx (head witness)
pubkey <- unmarshal ctx $ witness !! 1
return . P2WPKH $ WitnessProgramPKH sig pubkey
PayWitnessScriptHash _ | not (null witness) -> do
redeemScript <- runGetS deserialize $ last witness
return . P2WSH $ WitnessProgramSH (init witness) redeemScript
_
| null witness -> return EmptyWitnessProgram
| otherwise -> Left "viewWitnessProgram: Invalid witness program"
{- | Analyze the witness, trying to match it with standard input structures
@since 0.11.0.0
-}
-- | Analyze the witness, trying to match it with standard input structures
--
-- @since 0.11.0.0
decodeWitnessInput ::
Network ->
WitnessProgram ->
Either String (Maybe ScriptOutput, SimpleInput)
decodeWitnessInput net = \case
P2WPKH (WitnessProgramPKH sig key) -> return (Nothing, SpendPKHash sig key)
P2WSH (WitnessProgramSH st scr) -> do
so <- decodeOutput scr
fmap (Just so,) $ case (so, st) of
(PayPK _, [sigBS]) ->
SpendPK <$> decodeTxSig net sigBS
(PayPKHash _, [sigBS, keyBS]) ->
SpendPKHash <$> decodeTxSig net sigBS <*> runGetS deserialize keyBS
(PayMulSig _ _, "" : sigsBS) ->
SpendMulSig <$> traverse (decodeTxSig net) sigsBS
_ -> Left "decodeWitnessInput: Non-standard script output"
EmptyWitnessProgram -> Left "decodeWitnessInput: Empty witness program"
Network ->
Ctx ->
WitnessProgram ->
Either String (Maybe ScriptOutput, SimpleInput)
decodeWitnessInput net ctx = \case
P2WPKH (WitnessProgramPKH sig key) -> return (Nothing, SpendPKHash sig key)
P2WSH (WitnessProgramSH st scr) -> do
so <- decodeOutput ctx scr
fmap (Just so,) $ case (so, st) of
(PayPK _, [sigBS]) ->
SpendPK <$> decodeTxSig net ctx sigBS
(PayPKHash _, [sigBS, keyBS]) ->
SpendPKHash
<$> decodeTxSig net ctx sigBS
<*> unmarshal ctx keyBS
(PayMulSig _ _, "" : sigsBS) ->
SpendMulSig
<$> traverse (decodeTxSig net ctx) sigsBS
_ -> Left "decodeWitnessInput: Non-standard script output"
EmptyWitnessProgram -> Left "decodeWitnessInput: Empty witness program"
{- | Create the witness program for a standard input
@since 0.11.0.0
-}
calcWitnessProgram :: ScriptOutput -> ScriptInput -> Either String WitnessProgram
calcWitnessProgram so si = case (so, si) of
(PayWitnessPKHash{}, RegularInput (SpendPKHash sig pk)) -> p2wpkh sig pk
(PayScriptHash{}, RegularInput (SpendPKHash sig pk)) -> p2wpkh sig pk
(PayWitnessScriptHash{}, ScriptHashInput i o) -> p2wsh i o
(PayScriptHash{}, ScriptHashInput i o) -> p2wsh i o
_ -> Left "calcWitnessProgram: Invalid segwit SigInput"
-- | Create the witness program for a standard input
--
-- @since 0.11.0.0
calcWitnessProgram ::
Network ->
Ctx ->
ScriptOutput ->
ScriptInput ->
Either String WitnessProgram
calcWitnessProgram net ctx so si = case (so, si) of
(PayWitnessPKHash {}, RegularInput (SpendPKHash sig pk)) ->
Right $ p2wpkh sig pk
(PayScriptHash {}, RegularInput (SpendPKHash sig pk)) ->
Right $ p2wpkh sig pk
(PayWitnessScriptHash {}, ScriptHashInput i o) ->
Right $ p2wsh i o
(PayScriptHash {}, ScriptHashInput i o) ->
Right $ p2wsh i o
_ -> Left "calcWitnessProgram: Invalid segwit SigInput"
where
p2wpkh sig = return . P2WPKH . WitnessProgramPKH sig
p2wsh i o = return . P2WSH $ WitnessProgramSH (simpleInputStack i) (encodeOutput o)
p2wpkh sig =
P2WPKH . WitnessProgramPKH sig
p2wsh i =
P2WSH . WitnessProgramSH (simpleInputStack net ctx i) . encodeOutput ctx
{- | Create the witness stack required to spend a standard P2WSH input
@since 0.11.0.0
-}
simpleInputStack :: SimpleInput -> [ByteString]
simpleInputStack = \case
SpendPK sig -> [f sig]
SpendPKHash sig k -> [f sig, runPutS (serialize k)]
SpendMulSig sigs -> "" : fmap f sigs
-- | Create the witness stack required to spend a standard P2WSH input
--
-- @since 0.11.0.0
simpleInputStack :: Network -> Ctx -> SimpleInput -> [ByteString]
simpleInputStack net ctx = \case
SpendPK sig -> [f sig]
SpendPKHash sig k -> [f sig, marshal ctx k]
SpendMulSig sigs -> "" : fmap f sigs
where
f TxSignatureEmpty = ""
f sig = encodeTxSig sig
f sig = encodeTxSig net ctx sig

439
src/Haskoin/Transaction/Taproot.hs
View File

@ -1,21 +1,26 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoFieldSelectors #-}
{- |
Module : Haskoin.Transaction.Taproot
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
This module provides support for reperesenting full taproot outputs and parsing
taproot witnesses. For reference see BIPS 340, 341, and 342.
-}
module Haskoin.Transaction.Taproot (
XOnlyPubKey (..),
-- |
-- Module : Haskoin.Transaction.Taproot
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- This module provides support for reperesenting full taproot outputs and parsing
-- taproot witnesses. For reference see BIPS 340, 341, and 342.
module Haskoin.Transaction.Taproot
( XOnlyPubKey (..),
TapLeafVersion,
MAST (..),
mastCommitment,
@ -28,283 +33,283 @@ module Haskoin.Transaction.Taproot (
viewTaprootWitness,
encodeTaprootWitness,
verifyScriptPathData,
) where
)
where
import Control.Applicative (many)
import Control.Monad ((<=<))
import Crypto.Hash (
Digest,
import Crypto.Hash
( Digest,
SHA256,
digestFromByteString,
hashFinalize,
hashUpdate,
hashUpdates,
)
import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), withText)
)
import Crypto.Secp256k1
import Data.Aeson
( FromJSON (parseJSON),
ToJSON (toJSON),
Value (String),
withText,
)
import Data.Aeson.Types (Parser, Value)
import Data.Binary (Binary (..))
import Data.Bits ((.&.), (.|.))
import Data.Bool (bool)
import qualified Data.ByteArray as BA
import Data.ByteArray qualified as BA
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Bytes.Get (getBytes, runGetS)
import Data.Bytes.Put (putByteString, runPutS)
import Data.ByteString qualified as BS
import Data.Bytes.Get (MonadGet, getBytes, runGetS)
import Data.Bytes.Put (MonadPut, putByteString, runPutL, runPutS)
import Data.Bytes.Serial (Serial (..), deserialize, serialize)
import Data.Bytes.VarInt (VarInt (VarInt))
import Data.Foldable (foldl')
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Serialize (Serialize, get, getByteString, getWord8, put)
import Data.Word (Word8)
import Haskoin.Crypto (PubKey, initTaggedHash, tweak, tweakAddPubKey)
import Haskoin.Keys.Common (PubKeyI (PubKeyI), pubKeyPoint)
import Haskoin.Script.Common (Script)
import Haskoin.Script.Standard (ScriptOutput (PayWitness))
import Haskoin.Transaction.Common (WitnessStack)
import Haskoin.Util (decodeHex, eitherToMaybe, encodeHex)
import Haskoin.Crypto.Hash
import Haskoin.Crypto.Keys.Common
import Haskoin.Crypto.Keys.Extended
import Haskoin.Script.Common
import Haskoin.Script.Standard
import Haskoin.Transaction.Common
import Haskoin.Util
{- | An x-only pubkey corresponds to the keys @(x,y)@ and @(x, -y)@. The
equality test only checks the x-coordinate. An x-only pubkey serializes to 32
bytes.
@since 0.21.0
-}
newtype XOnlyPubKey = XOnlyPubKey {xOnlyPubKey :: PubKey}
deriving (Show)
-- | An x-only pubkey corresponds to the keys @(x,y)@ and @(x, -y)@. The
-- equality test only checks the x-coordinate. An x-only pubkey serializes to 32
-- bytes.
--
-- @since 0.21.0
newtype XOnlyPubKey = XOnlyPubKey {point :: PubKey}
deriving (Read, Show)
instance Eq XOnlyPubKey where
k1 == k2 = runPutS (serialize k1) == runPutS (serialize k2)
XOnlyPubKey k1 == XOnlyPubKey k2 = f k1 == f k2
where
f = BS.take 32 . (.get)
instance Serial XOnlyPubKey where
serialize (XOnlyPubKey pk) =
putByteString
. BS.drop 1
. runPutS
. serialize
$ PubKeyI pk True
deserialize =
either fail (pure . XOnlyPubKey . pubKeyPoint)
. runGetS deserialize
. BS.cons 0x02
=<< getBytes 32
instance Marshal Ctx XOnlyPubKey where
marshalPut ctx (XOnlyPubKey pk) =
putByteString
. BS.drop 1
. marshal ctx
$ PublicKey pk True
instance Serialize XOnlyPubKey where
put = serialize
get = deserialize
marshalGet ctx =
either fail (pure . XOnlyPubKey . (\PublicKey {point} -> point))
. unmarshal ctx
. BS.cons 0x02
=<< getBytes 32
instance Binary XOnlyPubKey where
put = serialize
get = deserialize
instance MarshalJSON Ctx XOnlyPubKey where
unmarshalValue ctx =
withText "XOnlyPubKey" $ either fail pure . (des <=< hex)
where
hex = maybe (Left "Unable to decode hex") Right . decodeHex
des = runGetS $ marshalGet ctx
-- | Hex encoding
instance FromJSON XOnlyPubKey where
parseJSON =
withText "XOnlyPubKey" $
either fail pure
. (runGetS deserialize <=< maybe (Left "Unable to decode hex") Right . decodeHex)
marshalValue ctx =
String . encodeHex . marshal ctx
-- | Hex encoding
instance ToJSON XOnlyPubKey where
toJSON = toJSON . encodeHex . runPutS . serialize
marshalEncoding ctx =
hexEncoding . runPutL . marshalPut ctx
-- | @since 0.21.0
type TapLeafVersion = Word8
{- | Merklized Abstract Syntax Tree. This type can represent trees where only a
subset of the leaves are known. Note that the tree is invariant under swapping
branches at an internal node.
@since 0.21.0
-}
-- | Merklized Abstract Syntax Tree. This type can represent trees where only a
-- subset of the leaves are known. Note that the tree is invariant under swapping
-- branches at an internal node.
--
-- @since 0.21.0
data MAST
= MASTBranch MAST MAST
| MASTLeaf TapLeafVersion Script
| MASTCommitment (Digest SHA256)
deriving (Show)
= MASTBranch MAST MAST
| MASTLeaf TapLeafVersion Script
| MASTCommitment (Digest SHA256)
deriving (Show)
{- | Get the inclusion proofs for the leaves in the tree. The proof is ordered
leaf-to-root.
@since 0.21.0
-}
-- | Get the inclusion proofs for the leaves in the tree. The proof is ordered
-- leaf-to-root.
--
-- @since 0.21.0
getMerkleProofs :: MAST -> [(TapLeafVersion, Script, [Digest SHA256])]
getMerkleProofs = getProofs mempty
where
getProofs proof = \case
MASTBranch branchL branchR ->
(updateProof proof (mastCommitment branchR) <$> getMerkleProofs branchL)
<> (updateProof proof (mastCommitment branchL) <$> getMerkleProofs branchR)
MASTLeaf v s -> [(v, s, proof)]
MASTCommitment{} -> mempty
MASTBranch branchL branchR ->
(updateProof proof (mastCommitment branchR) <$> getMerkleProofs branchL)
<> (updateProof proof (mastCommitment branchL) <$> getMerkleProofs branchR)
MASTLeaf v s -> [(v, s, proof)]
MASTCommitment {} -> mempty
updateProof proofInit branchCommitment (v, s, proofTail) =
(v, s, reverse $ proofInit <> (branchCommitment : proofTail))
(v, s, reverse $ proofInit <> (branchCommitment : proofTail))
{- | Calculate the root hash for this tree.
@since 0.21.0
-}
-- | Calculate the root hash for this tree.
--
-- @since 0.21.0
mastCommitment :: MAST -> Digest SHA256
mastCommitment = \case
MASTBranch leftBranch rightBranch ->
hashBranch (mastCommitment leftBranch) (mastCommitment rightBranch)
MASTLeaf leafVersion leafScript -> leafHash leafVersion leafScript
MASTCommitment theCommitment -> theCommitment
MASTBranch leftBranch rightBranch ->
hashBranch (mastCommitment leftBranch) (mastCommitment rightBranch)
MASTLeaf leafVersion leafScript -> leafHash leafVersion leafScript
MASTCommitment theCommitment -> theCommitment
hashBranch :: Digest SHA256 -> Digest SHA256 -> Digest SHA256
hashBranch hashA hashB =
hashFinalize $
hashUpdates
(initTaggedHash "TapBranch")
[ min hashA hashB
, max hashA hashB
]
hashFinalize $
hashUpdates
(initTaggedHash "TapBranch")
[ min hashA hashB,
max hashA hashB
]
leafHash :: TapLeafVersion -> Script -> Digest SHA256
leafHash leafVersion leafScript =
hashFinalize
. hashUpdate (initTaggedHash "TapLeaf")
. runPutS
$ do
serialize leafVersion
serialize $ VarInt (BS.length scriptBytes)
putByteString scriptBytes
hashFinalize
. hashUpdate (initTaggedHash "TapLeaf")
. runPutS
$ do
serialize leafVersion
serialize $ VarInt (BS.length scriptBytes)
putByteString scriptBytes
where
scriptBytes = runPutS $ serialize leafScript
{- | Representation of a full taproot output.
@since 0.21.0
-}
-- | Representation of a full taproot output.
--
-- @since 0.21.0
data TaprootOutput = TaprootOutput
{ taprootInternalKey :: PubKey
, taprootMAST :: Maybe MAST
}
deriving (Show)
{ internalKey :: PubKey,
mast :: Maybe MAST
}
-- | @since 0.21.0
taprootOutputKey :: TaprootOutput -> PubKey
taprootOutputKey TaprootOutput{taprootInternalKey, taprootMAST} =
fromMaybe keyFail $ tweak commitment >>= tweakAddPubKey taprootInternalKey
taprootOutputKey :: Ctx -> TaprootOutput -> PubKey
taprootOutputKey ctx TaprootOutput {..} =
fromMaybe keyFail $
tweak commitment >>= tweakAddPubKey ctx internalKey
where
commitment = taprootCommitment taprootInternalKey $ mastCommitment <$> taprootMAST
commitment =
taprootCommitment ctx internalKey $
mastCommitment <$> mast
keyFail = error "haskoin-core taprootOutputKey: key derivation failed"
taprootCommitment :: PubKey -> Maybe (Digest SHA256) -> ByteString
taprootCommitment internalKey merkleRoot =
BA.convert . hashFinalize
. maybe id (flip hashUpdate) merkleRoot
. (`hashUpdate` keyBytes)
$ initTaggedHash "TapTweak"
taprootCommitment :: Ctx -> PubKey -> Maybe (Digest SHA256) -> ByteString
taprootCommitment ctx internalKey merkleRoot =
BA.convert
. hashFinalize
. maybe id (flip hashUpdate) merkleRoot
. (`hashUpdate` keyBytes)
$ initTaggedHash "TapTweak"
where
keyBytes = runPutS . serialize $ XOnlyPubKey internalKey
keyBytes = runPutS . marshalPut ctx $ XOnlyPubKey internalKey
{- | Generate the output script for a taproot output
-- | Generate the output script for a taproot output
--
-- @since 0.21.0
taprootScriptOutput :: Ctx -> TaprootOutput -> ScriptOutput
taprootScriptOutput ctx =
PayWitness 0x01
. runPutS
. marshalPut ctx
. XOnlyPubKey
. taprootOutputKey ctx
@since 0.21.0
-}
taprootScriptOutput :: TaprootOutput -> ScriptOutput
taprootScriptOutput = PayWitness 0x01 . runPutS . serialize . XOnlyPubKey . taprootOutputKey
{- | Comprehension of taproot witness data
@since 0.21.0
-}
-- | Comprehension of taproot witness data
--
-- @since 0.21.0
data TaprootWitness
= -- | Signature
KeyPathSpend ByteString
| ScriptPathSpend ScriptPathData
deriving (Eq, Show)
= -- | Signature
KeyPathSpend ByteString
| ScriptPathSpend ScriptPathData
deriving (Eq)
-- | @since 0.21.0
data ScriptPathData = ScriptPathData
{ scriptPathAnnex :: Maybe ByteString
, scriptPathStack :: [ByteString]
, scriptPathScript :: Script
, scriptPathExternalIsOdd :: Bool
, -- | This value is masked by 0xFE
scriptPathLeafVersion :: Word8
, scriptPathInternalKey :: PubKey
, scriptPathControl :: [ByteString]
}
deriving (Eq, Show)
{ annex :: Maybe ByteString,
stack :: [ByteString],
script :: Script,
extIsOdd :: Bool,
-- | This value is masked by 0xFE
leafVersion :: Word8,
internalKey :: PubKey,
control :: [ByteString]
}
deriving (Eq)
{- | Try to interpret a 'WitnessStack' as taproot witness data.
@since 0.21.0
-}
viewTaprootWitness :: WitnessStack -> Maybe TaprootWitness
viewTaprootWitness witnessStack = case reverse witnessStack of
[sig] -> Just $ KeyPathSpend sig
annexA : remainingStack
| 0x50 : _ <- BS.unpack annexA ->
parseSpendPathData (Just annexA) remainingStack
remainingStack -> parseSpendPathData Nothing remainingStack
-- | Try to interpret a 'WitnessStack' as taproot witness data.
--
-- @since 0.21.0
viewTaprootWitness :: Ctx -> WitnessStack -> Maybe TaprootWitness
viewTaprootWitness ctx witnessStack = case reverse witnessStack of
[sig] -> Just $ KeyPathSpend sig
annexA : remainingStack
| 0x50 : _ <- BS.unpack annexA ->
parseSpendPathData (Just annexA) remainingStack
remainingStack -> parseSpendPathData Nothing remainingStack
where
parseSpendPathData scriptPathAnnex = \case
scriptBytes : controlBytes : scriptPathStack -> do
scriptPathScript <- eitherToMaybe $ runGetS deserialize scriptBytes
(v, scriptPathInternalKey, scriptPathControl) <- deconstructControl controlBytes
pure . ScriptPathSpend $
ScriptPathData
{ scriptPathAnnex
, scriptPathStack
, scriptPathScript
, scriptPathExternalIsOdd = odd v
, scriptPathLeafVersion = v .&. 0xFE
, scriptPathInternalKey
, scriptPathControl
}
_ -> Nothing
parseSpendPathData annex = \case
scriptBytes : controlBytes : stack -> do
script <- eitherToMaybe $ runGetS deserialize scriptBytes
(v, internalKey, control) <- deconstructControl controlBytes
let extIsOdd = odd v
leafVersion = v .&. 0xFE
pure $ ScriptPathSpend ScriptPathData {..}
_ -> Nothing
deconstructControl = eitherToMaybe . runGetS deserializeControl
deserializeControl = do
v <- getWord8
k <- xOnlyPubKey <$> deserialize
proof <- many $ getByteString 32
pure (v, k, proof)
v <- getWord8
XOnlyPubKey k <- marshalGet ctx
proof <- many $ getByteString 32
pure (v, k, proof)
{- | Transform the high-level representation of taproot witness data into a witness stack
@since 0.21.0
-}
encodeTaprootWitness :: TaprootWitness -> WitnessStack
encodeTaprootWitness = \case
KeyPathSpend signature -> pure signature
ScriptPathSpend scriptPathData ->
scriptPathStack scriptPathData
<> [ runPutS . serialize $ scriptPathScript scriptPathData
, mconcat
[ BS.pack [scriptPathLeafVersion scriptPathData .|. parity scriptPathData]
, runPutS . serialize . XOnlyPubKey $ scriptPathInternalKey scriptPathData
, mconcat $ scriptPathControl scriptPathData
]
, fromMaybe mempty $ scriptPathAnnex scriptPathData
]
-- | Transform the high-level representation of taproot witness data into a witness stack
--
-- @since 0.21.0
encodeTaprootWitness :: Ctx -> TaprootWitness -> WitnessStack
encodeTaprootWitness ctx = \case
KeyPathSpend signature -> pure signature
ScriptPathSpend scriptPathData -> wit scriptPathData
where
parity = bool 0 1 . scriptPathExternalIsOdd
wit d = (.stack) d <> [script d, keys d, annex d]
keys d = mconcat [verpar d, xonlyk d, ctrl d]
script = runPutS . serialize . (.script)
verpar d = BS.pack [(.leafVersion) d .|. parity d]
xonlyk = runPutS . marshalPut ctx . XOnlyPubKey . (.internalKey)
annex = fromMaybe mempty . (.annex)
ctrl = mconcat . (.control)
parity = bool 0 1 . (.extIsOdd)
{- | Verify that the script path spend is valid, except for script execution.
@since 0.21.0
-}
-- | Verify that the script path spend is valid, except for script execution.
--
-- @since 0.21.0
verifyScriptPathData ::
-- | Output key
PubKey ->
ScriptPathData ->
Bool
verifyScriptPathData outputKey scriptPathData = fromMaybe False $ do
tweak commitment >>= fmap onComputedKey . tweakAddPubKey (scriptPathInternalKey scriptPathData)
Ctx ->
-- | Output key
PubKey ->
ScriptPathData ->
Bool
verifyScriptPathData ctx outkey spd = fromMaybe False $ do
tweak commitment
>>= fmap onComputedKey
. tweakAddPubKey ctx spd.internalKey
where
onComputedKey computedKey =
XOnlyPubKey outputKey == XOnlyPubKey computedKey
&& expectedParity == keyParity computedKey
commitment = taprootCommitment (scriptPathInternalKey scriptPathData) (Just merkleRoot)
XOnlyPubKey outkey == XOnlyPubKey computedKey
&& expectedParity == keyParity ctx computedKey
commitment =
taprootCommitment ctx spd.internalKey (Just merkleRoot)
merkleRoot =
foldl' hashBranch theLeafHash
. mapMaybe (digestFromByteString @SHA256)
$ scriptPathControl scriptPathData
theLeafHash = (leafHash <$> (.&. 0xFE) . scriptPathLeafVersion <*> scriptPathScript) scriptPathData
expectedParity = bool 0 1 $ scriptPathExternalIsOdd scriptPathData
foldl' hashBranch theLeafHash $
mapMaybe (digestFromByteString @SHA256) spd.control
theLeafHash =
(leafHash <$> (.&. 0xFE) . (.leafVersion) <*> (.script))
spd
expectedParity = bool 0 1 spd.extIsOdd
keyParity :: PubKey -> Word8
keyParity key = case BS.unpack . runPutS . serialize $ PubKeyI key True of
keyParity :: Ctx -> PubKey -> Word8
keyParity ctx key =
case BS.unpack . marshal ctx $ PublicKey key True of
0x02 : _ -> 0x00
_ -> 0x01

379
src/Haskoin/Util.hs
View File

@ -1,8 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ImportQualifiedPost #-}
-- |
-- Module : Haskoin.Util
-- Copyright : No rights reserved
@ -11,376 +6,12 @@
-- Stability : experimental
-- Portability : POSIX
--
-- This module defines various utility functions used across the library.
-- Marshalling and helper functions.
module Haskoin.Util
( -- * ByteString Helpers
bsToInteger,
integerToBS,
hexBuilder,
encodeHex,
encodeHexLazy,
decodeHex,
decodeHexLazy,
getBits,
-- * Maybe & Either Helpers
eitherToMaybe,
maybeToEither,
liftEither,
liftMaybe,
-- * Other Helpers
updateIndex,
matchTemplate,
convertBits,
-- * Triples
fst3,
snd3,
lst3,
-- * JSON Utilities
dropFieldLabel,
dropSumLabels,
-- * Serialization Helpers
putList,
getList,
putMaybe,
getMaybe,
putLengthBytes,
getLengthBytes,
putInteger,
getInteger,
putInt32be,
getInt32be,
putInt64be,
getInt64be,
getIntMap,
putIntMap,
getTwo,
putTwo,
( module Marshal,
module Helpers,
)
where
import Control.Monad
import Control.Monad.Except (ExceptT (..), liftEither)
import Data.Aeson.Types
( Options (..),
SumEncoding (..),
defaultOptions,
defaultTaggedObject,
)
import Data.Base16.Types (assertBase16, extractBase16)
import Data.Bits
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Base16 qualified as B16
import Data.ByteString.Builder
import Data.ByteString.Lazy qualified as BL
import Data.ByteString.Lazy.Base16 qualified as BL16
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import Data.Char (toLower)
import Data.Int
import Data.IntMap (IntMap)
import Data.IntMap qualified as IntMap
import Data.List
import Data.Text (Text)
import Data.Text.Encoding qualified as E
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.Encoding qualified as EL
import Data.Word
-- ByteString helpers
-- | Decode a big endian 'Integer' from a 'ByteString'.
bsToInteger :: ByteString -> Integer
bsToInteger = BS.foldr f 0 . BS.reverse
where
f w n = toInteger w .|. shiftL n 8
-- | Encode an 'Integer' to a 'ByteString' as big endian.
integerToBS :: Integer -> ByteString
integerToBS 0 = BS.pack [0]
integerToBS i
| i > 0 = BS.reverse $ BS.unfoldr f i
| otherwise = error "integerToBS not defined for negative values"
where
f 0 = Nothing
f x = Just (fromInteger x :: Word8, x `shiftR` 8)
hexBuilder :: BL.ByteString -> Builder
hexBuilder = lazyByteStringHex
encodeHex :: ByteString -> Text
encodeHex = extractBase16 . B16.encodeBase16
-- | Encode as string of human-readable hex characters.
encodeHexLazy :: BL.ByteString -> TL.Text
encodeHexLazy = extractBase16 . BL16.encodeBase16
decodeHex :: Text -> Maybe ByteString
decodeHex t =
if B16.isBase16 u8
then Just . B16.decodeBase16 $ assertBase16 u8
else Nothing
where
u8 = E.encodeUtf8 t
-- | Decode string of human-readable hex characters.
decodeHexLazy :: TL.Text -> Maybe BL.ByteString
decodeHexLazy t =
if BL16.isBase16 u8
then Just . BL16.decodeBase16 $ assertBase16 u8
else Nothing
where
u8 = EL.encodeUtf8 t
-- | Obtain 'Int' bits from beginning of 'ByteString'. Resulting 'ByteString'
-- will be smallest required to hold that many bits, padded with zeroes to the
-- right.
getBits :: Int -> ByteString -> ByteString
getBits b bs
| r == 0 = BS.take q bs
| otherwise = i `BS.snoc` l
where
(q, r) = b `quotRem` 8
s = BS.take (q + 1) bs
i = BS.init s
l = BS.last s .&. (0xff `shiftL` (8 - r)) -- zero unneeded bits
-- Maybe and Either monad helpers
-- | Transform an 'Either' value into a 'Maybe' value. 'Right' is mapped to
-- 'Just' and 'Left' is mapped to 'Nothing'. The value inside 'Left' is lost.
eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe (Right b) = Just b
eitherToMaybe _ = Nothing
-- | Transform a 'Maybe' value into an 'Either' value. 'Just' is mapped to
-- 'Right' and 'Nothing' is mapped to 'Left'. Default 'Left' required.
maybeToEither :: b -> Maybe a -> Either b a
maybeToEither err = maybe (Left err) Right
-- | Lift a 'Maybe' computation into the 'ExceptT' monad.
liftMaybe :: (Monad m) => b -> Maybe a -> ExceptT b m a
liftMaybe err = liftEither . maybeToEither err
-- Various helpers
-- | Applies a function to only one element of a list defined by its index. If
-- the index is out of the bounds of the list, the original list is returned.
updateIndex ::
-- | index of the element to change
Int ->
-- | list of elements
[a] ->
-- | function to apply
(a -> a) ->
-- | result with one element changed
[a]
updateIndex i xs f
| i < 0 || i >= length xs = xs
| otherwise = l ++ (f h : r)
where
(l, h : r) = splitAt i xs
-- | Use the list @[b]@ as a template and try to match the elements of @[a]@
-- against it. For each element of @[b]@ return the (first) matching element of
-- @[a]@, or 'Nothing'. Output list has same size as @[b]@ and contains results
-- in same order. Elements of @[a]@ can only appear once.
matchTemplate ::
-- | input list
[a] ->
-- | list to serve as a template
[b] ->
-- | comparison function
(a -> b -> Bool) ->
[Maybe a]
matchTemplate [] bs _ = replicate (length bs) Nothing
matchTemplate _ [] _ = []
matchTemplate as (b : bs) f = case break (`f` b) as of
(l, r : rs) -> Just r : matchTemplate (l ++ rs) bs f
_ -> Nothing : matchTemplate as bs f
-- | Returns the first value of a triple.
fst3 :: (a, b, c) -> a
fst3 (a, _, _) = a
-- | Returns the second value of a triple.
snd3 :: (a, b, c) -> b
snd3 (_, b, _) = b
-- | Returns the last value of a triple.
lst3 :: (a, b, c) -> c
lst3 (_, _, c) = c
-- | Field label goes lowercase and first @n@ characters get removed.
dropFieldLabel :: Int -> Options
dropFieldLabel n =
defaultOptions
{ fieldLabelModifier = map toLower . drop n
}
-- | Transformation from 'dropFieldLabel' is applied with argument @f@, plus
-- constructor tags are lowercased and first @c@ characters removed. @tag@ is
-- used as the name of the object field name that will hold the transformed
-- constructor tag as its value.
dropSumLabels :: Int -> Int -> String -> Options
dropSumLabels c f tag =
(dropFieldLabel f)
{ constructorTagModifier = map toLower . drop c,
sumEncoding = defaultTaggedObject {tagFieldName = tag}
}
-- | Convert from one power-of-two base to another, as long as it fits in a
-- 'Word'.
convertBits :: Bool -> Int -> Int -> [Word] -> ([Word], Bool)
convertBits pad frombits tobits i = (reverse yout, rem')
where
(xacc, xbits, xout) = foldl' outer (0, 0, []) i
(yout, rem')
| pad && xbits /= 0 =
let xout' = (xacc `shiftL` (tobits - xbits)) .&. maxv : xout
in (xout', False)
| pad = (xout, False)
| xbits /= 0 = (xout, True)
| otherwise = (xout, False)
maxv = 1 `shiftL` tobits - 1
max_acc = 1 `shiftL` (frombits + tobits - 1) - 1
outer (acc, bits, out) it =
let acc' = ((acc `shiftL` frombits) .|. it) .&. max_acc
bits' = bits + frombits
(out', bits'') = inner acc' out bits'
in (acc', bits'', out')
inner acc out bits
| bits >= tobits =
let bits' = bits - tobits
out' = ((acc `shiftR` bits') .&. maxv) : out
in inner acc out' bits'
| otherwise = (out, bits)
--
-- Serialization helpers
--
putInt32be :: (MonadPut m) => Int32 -> m ()
putInt32be n
| n < 0 = putWord32be (complement (fromIntegral (abs n)) + 1)
| otherwise = putWord32be (fromIntegral (abs n))
getInt32be :: (MonadGet m) => m Int32
getInt32be = do
n <- getWord32be
if testBit n 31
then return (negate (complement (fromIntegral n) + 1))
else return (fromIntegral n)
putInt64be :: (MonadPut m) => Int64 -> m ()
putInt64be n
| n < 0 = putWord64be (complement (fromIntegral (abs n)) + 1)
| otherwise = putWord64be (fromIntegral (abs n))
getInt64be :: (MonadGet m) => m Int64
getInt64be = do
n <- getWord64be
if testBit n 63
then return (negate (complement (fromIntegral n) + 1))
else return (fromIntegral n)
putInteger :: (MonadPut m) => Integer -> m ()
putInteger n
| n >= lo && n <= hi = do
putWord8 0x00
putInt32be (fromIntegral n)
| otherwise = do
putWord8 0x01
putWord8 (fromIntegral (signum n))
let len = (nrBits (abs n) + 7) `div` 8
putWord64be (fromIntegral len)
mapM_ putWord8 (unroll (abs n))
where
lo = fromIntegral (minBound :: Int32)
hi = fromIntegral (maxBound :: Int32)
getInteger :: (MonadGet m) => m Integer
getInteger =
getWord8 >>= \case
0 -> fromIntegral <$> getInt32be
_ -> do
sign <- getWord8
bytes <- getList getWord8
let v = roll bytes
return $! if sign == 0x01 then v else -v
putMaybe :: (MonadPut m) => (a -> m ()) -> Maybe a -> m ()
putMaybe f Nothing = putWord8 0x00
putMaybe f (Just x) = putWord8 0x01 >> f x
getMaybe :: (MonadGet m) => m a -> m (Maybe a)
getMaybe f =
getWord8 >>= \case
0x00 -> return Nothing
0x01 -> Just <$> f
_ -> fail "Not a Maybe"
putLengthBytes :: (MonadPut m) => ByteString -> m ()
putLengthBytes bs = do
putWord64be (fromIntegral (BS.length bs))
putByteString bs
getLengthBytes :: (MonadGet m) => m ByteString
getLengthBytes = do
len <- fromIntegral <$> getWord64be
getByteString len
--
-- Fold and unfold an Integer to and from a list of its bytes
--
unroll :: (Integral a, Bits a) => a -> [Word8]
unroll = unfoldr step
where
step 0 = Nothing
step i = Just (fromIntegral i, i `shiftR` 8)
roll :: (Integral a, Bits a) => [Word8] -> a
roll = foldr unstep 0
where
unstep b a = a `shiftL` 8 .|. fromIntegral b
nrBits :: (Ord a, Integral a) => a -> Int
nrBits k =
let expMax = until (\e -> 2 ^ e > k) (* 2) 1
findNr :: Int -> Int -> Int
findNr lo hi
| mid == lo = hi
| 2 ^ mid <= k = findNr mid hi
| 2 ^ mid > k = findNr lo mid
where
mid = (lo + hi) `div` 2
in findNr (expMax `div` 2) expMax
-- | Read as a list of pairs of int and element.
getIntMap :: (MonadGet m) => m Int -> m a -> m (IntMap a)
getIntMap i m = IntMap.fromList <$> getList (getTwo i m)
putIntMap :: (MonadPut m) => (Int -> m ()) -> (a -> m ()) -> IntMap a -> m ()
putIntMap f g = putList (putTwo f g) . IntMap.toAscList
putTwo :: (MonadPut m) => (a -> m ()) -> (b -> m ()) -> (a, b) -> m ()
putTwo f g (x, y) = f x >> g y
getTwo :: (MonadGet m) => m a -> m b -> m (a, b)
getTwo f g = (,) <$> f <*> g
putList :: (MonadPut m) => (a -> m ()) -> [a] -> m ()
putList f ls = do
putWord64be (fromIntegral (length ls))
mapM_ f ls
getList :: (MonadGet m) => m a -> m [a]
getList f = do
l <- fromIntegral <$> getWord64be
replicateM l f
import Haskoin.Util.Helpers as Helpers
import Haskoin.Util.Marshal as Marshal

26
src/Haskoin/Util/Arbitrary.hs
View File

@ -1,16 +1,16 @@
{- |
Module : Haskoin.Test
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
Arbitrary instances for testing.
-}
module Haskoin.Util.Arbitrary (
module X,
) where
-- |
-- Module : Haskoin.Test
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
--
-- Arbitrary instances for testing.
module Haskoin.Util.Arbitrary
( module X,
)
where
import Haskoin.Util.Arbitrary.Address as X
import Haskoin.Util.Arbitrary.Block as X

51
src/Haskoin/Util/Arbitrary/Address.hs
View File

@ -1,19 +1,18 @@
{-# LANGUAGE TupleSections #-}
{- |
Module : Haskoin.Test.Address
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
-}
-- |
-- Module : Haskoin.Test.Address
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
module Haskoin.Util.Arbitrary.Address where
import qualified Data.ByteString as B
import Haskoin.Address
import Haskoin.Constants
import Haskoin.Data
import Haskoin.Network.Constants
import Haskoin.Network.Data
import Haskoin.Util.Arbitrary.Crypto
import Haskoin.Util.Arbitrary.Util
import Test.QuickCheck
@ -25,21 +24,21 @@ arbitraryAddress = oneof [arbitraryPubKeyAddress, arbitraryScriptAddress]
-- | Arbitrary address including pay-to-witness
arbitraryAddressAll :: Gen Address
arbitraryAddressAll =
oneof
[ arbitraryPubKeyAddress
, arbitraryScriptAddress
, arbitraryWitnessPubKeyAddress
, arbitraryWitnessScriptAddress
, arbitraryWitnessAddress
]
oneof
[ arbitraryPubKeyAddress,
arbitraryScriptAddress,
arbitraryWitnessPubKeyAddress,
arbitraryWitnessScriptAddress,
arbitraryWitnessAddress
]
-- | Arbitrary valid combination of (Network, Address)
arbitraryNetAddress :: Gen (Network, Address)
arbitraryNetAddress = do
net <- arbitraryNetwork
if net `elem` [bch, bchTest, bchTest4, bchRegTest]
then (net,) <$> arbitraryAddress
else (net,) <$> arbitraryAddressAll
net <- arbitraryNetwork
if net `elem` [bch, bchTest, bchTest4, bchRegTest]
then (net,) <$> arbitraryAddress
else (net,) <$> arbitraryAddressAll
-- | Arbitrary pay-to-public-key-hash address.
arbitraryPubKeyAddress :: Gen Address
@ -59,8 +58,8 @@ arbitraryWitnessScriptAddress = WitnessPubKeyAddress <$> arbitraryHash160
arbitraryWitnessAddress :: Gen Address
arbitraryWitnessAddress = do
ver <- choose (1, 16)
len <- choose (2, 40)
ws <- vectorOf len arbitrary
let bs = B.pack ws
return $ WitnessAddress ver bs
ver <- choose (1, 16)
len <- choose (2, 40)
ws <- vectorOf len arbitrary
let bs = B.pack ws
return $ WitnessAddress ver bs

87
src/Haskoin/Util/Arbitrary/Block.hs
View File

@ -1,16 +1,16 @@
{- |
Module : Haskoin.Test.Block
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
-}
-- |
-- Module : Haskoin.Test.Block
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
module Haskoin.Util.Arbitrary.Block where
import qualified Data.HashMap.Strict as HashMap
import Haskoin.Block
import Haskoin.Data
import Haskoin.Crypto (Ctx)
import Haskoin.Network.Data
import Haskoin.Util.Arbitrary.Crypto
import Haskoin.Util.Arbitrary.Network
import Haskoin.Util.Arbitrary.Transaction
@ -18,22 +18,23 @@ import Haskoin.Util.Arbitrary.Util
import Test.QuickCheck
-- | Block full or arbitrary transactions.
arbitraryBlock :: Network -> Gen Block
arbitraryBlock net = do
h <- arbitraryBlockHeader
c <- choose (0, 10)
txs <- vectorOf c (arbitraryTx net)
return $ Block h txs
arbitraryBlock :: Network -> Ctx -> Gen Block
arbitraryBlock net ctx = do
h <- arbitraryBlockHeader
c <- choose (0, 10)
txs <- vectorOf c (arbitraryTx net ctx)
return $ Block h txs
-- | Block header with random hash.
arbitraryBlockHeader :: Gen BlockHeader
arbitraryBlockHeader =
BlockHeader <$> arbitrary
<*> arbitraryBlockHash
<*> arbitraryHash256
<*> arbitrary
<*> arbitrary
<*> arbitrary
BlockHeader
<$> arbitrary
<*> arbitraryBlockHash
<*> arbitraryHash256
<*> arbitrary
<*> arbitrary
<*> arbitrary
-- | Arbitrary block hash.
arbitraryBlockHash :: Gen BlockHash
@ -42,45 +43,45 @@ arbitraryBlockHash = BlockHash <$> arbitraryHash256
-- | Arbitrary 'GetBlocks' object with at least one block hash.
arbitraryGetBlocks :: Gen GetBlocks
arbitraryGetBlocks =
GetBlocks <$> arbitrary
<*> listOf1 arbitraryBlockHash
<*> arbitraryBlockHash
GetBlocks
<$> arbitrary
<*> listOf1 arbitraryBlockHash
<*> arbitraryBlockHash
-- | Arbitrary 'GetHeaders' object with at least one block header.
arbitraryGetHeaders :: Gen GetHeaders
arbitraryGetHeaders =
GetHeaders <$> arbitrary
<*> listOf1 arbitraryBlockHash
<*> arbitraryBlockHash
GetHeaders
<$> arbitrary
<*> listOf1 arbitraryBlockHash
<*> arbitraryBlockHash
-- | Arbitrary 'Headers' object with at least one block header.
arbitraryHeaders :: Gen Headers
arbitraryHeaders =
Headers <$> listOf1 ((,) <$> arbitraryBlockHeader <*> arbitraryVarInt)
Headers <$> listOf1 ((,) <$> arbitraryBlockHeader <*> arbitraryVarInt)
-- | Arbitrary 'MerkleBlock' with at least one hash.
arbitraryMerkleBlock :: Gen MerkleBlock
arbitraryMerkleBlock = do
bh <- arbitraryBlockHeader
ntx <- arbitrary
hashes <- listOf1 arbitraryHash256
c <- choose (1, 10)
flags <- vectorOf (c * 8) arbitrary
return $ MerkleBlock bh ntx hashes flags
bh <- arbitraryBlockHeader
ntx <- arbitrary
hashes <- listOf1 arbitraryHash256
c <- choose (1, 10)
flags <- vectorOf (c * 8) arbitrary
return $ MerkleBlock bh ntx hashes flags
-- | Arbitrary 'BlockNode'
arbitraryBlockNode :: Gen BlockNode
arbitraryBlockNode =
oneof
[ BlockNode
<$> arbitraryBlockHeader
<*> choose (0, maxBound)
<*> arbitrarySizedNatural
<*> arbitraryBlockHash
]
BlockNode
<$> arbitraryBlockHeader
<*> choose (0, maxBound)
<*> arbitrarySizedNatural
<*> arbitraryBlockHash
-- | Arbitrary 'HeaderMemory'
arbitraryHeaderMemory :: Gen HeaderMemory
arbitraryHeaderMemory = do
ls <- listOf $ (,) <$> arbitrary <*> arbitraryBSS
HeaderMemory (HashMap.fromList ls) <$> arbitraryBlockNode
ls <- listOf $ (,) <$> arbitrary <*> arbitraryBSS
HeaderMemory (HashMap.fromList ls) <$> arbitraryBlockNode

23
src/Haskoin/Util/Arbitrary/Crypto.hs
View File

@ -1,11 +1,10 @@
{- |
Module : Haskoin.Test.Crypto
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
-}
-- |
-- Module : Haskoin.Test.Crypto
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
module Haskoin.Util.Arbitrary.Crypto where
import Haskoin.Crypto.Hash
@ -15,19 +14,19 @@ import Test.QuickCheck
-- | Arbitrary 160-bit hash.
arbitraryHash160 :: Gen Hash160
arbitraryHash160 =
ripemd160 <$> arbitraryBSn 20
ripemd160 <$> arbitraryBSn 20
-- | Arbitrary 256-bit hash.
arbitraryHash256 :: Gen Hash256
arbitraryHash256 =
sha256 <$> arbitraryBSn 32
sha256 <$> arbitraryBSn 32
-- | Arbitrary 512-bit hash.
arbitraryHash512 :: Gen Hash512
arbitraryHash512 =
sha512 <$> arbitraryBSn 64
sha512 <$> arbitraryBSn 64
-- | Arbitrary 32-bit checksum.
arbitraryCheckSum32 :: Gen CheckSum32
arbitraryCheckSum32 =
checkSum32 <$> arbitraryBSn 4
checkSum32 <$> arbitraryBSn 4

94
src/Haskoin/Util/Arbitrary/Keys.hs
View File

@ -1,33 +1,34 @@
{- |
Module : Haskoin.Test.Keys
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
-}
-- |
-- Module : Haskoin.Test.Keys
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
module Haskoin.Util.Arbitrary.Keys where
import Crypto.Secp256k1
import Data.Bits (clearBit)
import Data.Coerce (coerce)
import Data.List (foldl')
import Data.Word (Word32)
import Haskoin.Crypto
import Haskoin.Keys.Common
import Haskoin.Keys.Extended
import Haskoin.Keys.Extended.Internal (Fingerprint (..))
import Haskoin.Crypto.Hash
import Haskoin.Crypto.Keys.Common
import Haskoin.Crypto.Keys.Extended
import Haskoin.Crypto.Keys.Extended.Internal (Fingerprint (..))
import Haskoin.Crypto.Signature
import Haskoin.Util.Arbitrary.Crypto
import Test.QuickCheck
-- | Arbitrary private key with arbitrary compressed flag.
arbitrarySecKeyI :: Gen SecKeyI
arbitrarySecKeyI = wrapSecKey <$> arbitrary <*> arbitrary
arbitraryPrivateKey :: Gen PrivateKey
arbitraryPrivateKey = wrapSecKey <$> arbitrary <*> arbitrary
-- | Arbitrary keypair, both either compressed or not.
arbitraryKeyPair :: Gen (SecKeyI, PubKeyI)
arbitraryKeyPair = do
k <- arbitrarySecKeyI
return (k, derivePubKeyI k)
arbitraryKeyPair :: Ctx -> Gen (PrivateKey, PublicKey)
arbitraryKeyPair ctx = do
k <- arbitraryPrivateKey
return (k, derivePublicKey ctx k)
arbitraryFingerprint :: Gen Fingerprint
arbitraryFingerprint = Fingerprint <$> arbitrary
@ -35,15 +36,16 @@ arbitraryFingerprint = Fingerprint <$> arbitrary
-- | Arbitrary extended private key.
arbitraryXPrvKey :: Gen XPrvKey
arbitraryXPrvKey =
XPrvKey <$> arbitrary
<*> arbitraryFingerprint
<*> arbitrary
<*> arbitraryHash256
<*> arbitrary
XPrvKey
<$> arbitrary
<*> arbitraryFingerprint
<*> arbitrary
<*> arbitraryHash256
<*> arbitrary
-- | Arbitrary extended public key with its corresponding private key.
arbitraryXPubKey :: Gen (XPrvKey, XPubKey)
arbitraryXPubKey = (\k -> (k, deriveXPubKey k)) <$> arbitraryXPrvKey
arbitraryXPubKey :: Ctx -> Gen (XPrvKey, XPubKey)
arbitraryXPubKey ctx = (\k -> (k, deriveXPubKey ctx k)) <$> arbitraryXPrvKey
{- Custom derivations -}
@ -54,10 +56,10 @@ genIndex = (`clearBit` 31) <$> arbitrary
-- | Arbitrary BIP-32 path index. Can be hardened or not.
arbitraryBip32PathIndex :: Gen Bip32PathIndex
arbitraryBip32PathIndex =
oneof
[ Bip32SoftIndex <$> genIndex
, Bip32HardIndex <$> genIndex
]
oneof
[ Bip32SoftIndex <$> genIndex,
Bip32HardIndex <$> genIndex
]
-- | Arbitrary BIP-32 derivation path composed of only hardened derivations.
arbitraryHardPath :: Gen HardPath
@ -71,24 +73,22 @@ arbitrarySoftPath = foldl' (:/) Deriv <$> listOf genIndex
arbitraryDerivPath :: Gen DerivPath
arbitraryDerivPath = concatBip32Segments <$> listOf arbitraryBip32PathIndex
{- | Arbitrary parsed derivation path. Can contain 'ParsedPrv', 'ParsedPub' or
'ParsedEmpty' elements.
-}
-- | Arbitrary parsed derivation path. Can contain 'ParsedPrv', 'ParsedPub' or
-- 'ParsedEmpty' elements.
arbitraryParsedPath :: Gen ParsedPath
arbitraryParsedPath =
oneof
[ ParsedPrv <$> arbitraryDerivPath
, ParsedPub <$> arbitraryDerivPath
, ParsedEmpty <$> arbitraryDerivPath
]
oneof
[ ParsedPrv <$> arbitraryDerivPath,
ParsedPub <$> arbitraryDerivPath,
ParsedEmpty <$> arbitraryDerivPath
]
{- | Arbitrary message hash, private key, nonce and corresponding signature. The
signature is generated with a random message, random private key and a random
nonce.
-}
arbitrarySignature :: Gen (Hash256, SecKey, Sig)
arbitrarySignature = do
m <- arbitraryHash256
key <- arbitrary
let sig = signHash key m
return (m, key, sig)
-- | Arbitrary message hash, private key, nonce and corresponding signature. The
-- signature is generated with a random message, random private key and a random
-- nonce.
arbitrarySignature :: Ctx -> Gen (Hash256, SecKey, Sig)
arbitrarySignature ctx = do
m <- arbitraryHash256
key <- arbitrary
let sig = signHash ctx key m
return (m, key, sig)

77
src/Haskoin/Util/Arbitrary/Message.hs
View File

@ -1,14 +1,14 @@
{- |
Module : Haskoin.Test.Message
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
-}
-- |
-- Module : Haskoin.Test.Message
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
module Haskoin.Util.Arbitrary.Message where
import Haskoin.Data
import Haskoin.Crypto (Ctx)
import Haskoin.Network.Data
import Haskoin.Network.Message
import Haskoin.Util.Arbitrary.Block
import Haskoin.Util.Arbitrary.Crypto
@ -19,34 +19,35 @@ import Test.QuickCheck
-- | Arbitrary 'MessageHeader'.
arbitraryMessageHeader :: Gen MessageHeader
arbitraryMessageHeader =
MessageHeader <$> arbitrary
<*> arbitraryMessageCommand
<*> arbitrary
<*> arbitraryCheckSum32
MessageHeader
<$> arbitrary
<*> arbitraryMessageCommand
<*> arbitrary
<*> arbitraryCheckSum32
-- | Arbitrary 'Message'.
arbitraryMessage :: Network -> Gen Message
arbitraryMessage net =
oneof
[ MVersion <$> arbitraryVersion
, return MVerAck
, MAddr <$> arbitraryAddr1
, MInv <$> arbitraryInv1
, MGetData <$> arbitraryGetData
, MNotFound <$> arbitraryNotFound
, MGetBlocks <$> arbitraryGetBlocks
, MGetHeaders <$> arbitraryGetHeaders
, MTx <$> arbitraryTx net
, MBlock <$> arbitraryBlock net
, MMerkleBlock <$> arbitraryMerkleBlock
, MHeaders <$> arbitraryHeaders
, return MGetAddr
, MFilterLoad <$> arbitraryFilterLoad
, MFilterAdd <$> arbitraryFilterAdd
, return MFilterClear
, MPing <$> arbitraryPing
, MPong <$> arbitraryPong
, MAlert <$> arbitraryAlert
, MReject <$> arbitraryReject
, return MSendHeaders
]
arbitraryMessage :: Network -> Ctx -> Gen Message
arbitraryMessage net ctx =
oneof
[ MVersion <$> arbitraryVersion,
return MVerAck,
MAddr <$> arbitraryAddr1,
MInv <$> arbitraryInv1,
MGetData <$> arbitraryGetData,
MNotFound <$> arbitraryNotFound,
MGetBlocks <$> arbitraryGetBlocks,
MGetHeaders <$> arbitraryGetHeaders,
MTx <$> arbitraryTx net ctx,
MBlock <$> arbitraryBlock net ctx,
MMerkleBlock <$> arbitraryMerkleBlock,
MHeaders <$> arbitraryHeaders,
return MGetAddr,
MFilterLoad <$> arbitraryFilterLoad,
MFilterAdd <$> arbitraryFilterAdd,
return MFilterClear,
MPing <$> arbitraryPing,
MPong <$> arbitraryPong,
MAlert <$> arbitraryAlert,
MReject <$> arbitraryReject,
return MSendHeaders
]

180
src/Haskoin/Util/Arbitrary/Network.hs
View File

@ -1,11 +1,10 @@
{- |
Module : Haskoin.Test.Network
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
-}
-- |
-- Module : Haskoin.Test.Network
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
module Haskoin.Util.Arbitrary.Network where
import qualified Data.ByteString as BS (empty, pack)
@ -28,20 +27,20 @@ arbitraryVarString = VarString <$> arbitraryBS
-- | Arbitrary 'NetworkAddress'.
arbitraryNetworkAddress :: Gen NetworkAddress
arbitraryNetworkAddress = do
s <- arbitrary
a <- arbitrary
p <- arbitrary
d <-
oneof
[ do
b <- arbitrary
c <- arbitrary
d <- arbitrary
return $ SockAddrInet6 (fromIntegral p) 0 (a, b, c, d) 0
, return $ SockAddrInet (fromIntegral (p :: Word16)) a
]
let n = sockToHostAddress d
return $ NetworkAddress s n
s <- arbitrary
a <- arbitrary
p <- arbitrary
d <-
oneof
[ do
b <- arbitrary
c <- arbitrary
d <- arbitrary
return $ SockAddrInet6 (fromIntegral p) 0 (a, b, c, d) 0,
return $ SockAddrInet (fromIntegral (p :: Word16)) a
]
let n = sockToHostAddress d
return $ NetworkAddress s n
-- | Arbitrary 'NetworkAddressTime'.
arbitraryNetworkAddressTime :: Gen (Word32, NetworkAddress)
@ -62,52 +61,52 @@ arbitraryInv1 = Inv <$> listOf1 arbitraryInvVector
-- | Arbitrary 'Version'.
arbitraryVersion :: Gen Version
arbitraryVersion =
Version <$> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitraryNetworkAddress
<*> arbitraryNetworkAddress
<*> arbitrary
<*> arbitraryVarString
<*> arbitrary
<*> arbitrary
Version
<$> arbitrary
<*> arbitrary
<*> arbitrary
<*> arbitraryNetworkAddress
<*> arbitraryNetworkAddress
<*> arbitrary
<*> arbitraryVarString
<*> arbitrary
<*> arbitrary
-- | Arbitrary non-empty 'Addr'.
arbitraryAddr1 :: Gen Addr
arbitraryAddr1 = Addr <$> listOf1 arbitraryNetworkAddressTime
{- | Arbitrary 'Alert' with random payload and signature. Signature is not
valid.
-}
-- | Arbitrary 'Alert' with random payload and signature. Signature is not
-- valid.
arbitraryAlert :: Gen Alert
arbitraryAlert = Alert <$> arbitraryVarString <*> arbitraryVarString
-- | Arbitrary 'Reject'.
arbitraryReject :: Gen Reject
arbitraryReject = do
m <- arbitraryMessageCommand
c <- arbitraryRejectCode
s <- arbitraryVarString
d <-
oneof
[ return BS.empty
, BS.pack <$> vectorOf 32 arbitrary
]
return $ Reject m c s d
m <- arbitraryMessageCommand
c <- arbitraryRejectCode
s <- arbitraryVarString
d <-
oneof
[ return BS.empty,
BS.pack <$> vectorOf 32 arbitrary
]
return $ Reject m c s d
-- | Arbitrary 'RejectCode'.
arbitraryRejectCode :: Gen RejectCode
arbitraryRejectCode =
elements
[ RejectMalformed
, RejectInvalid
, RejectInvalid
, RejectDuplicate
, RejectNonStandard
, RejectDust
, RejectInsufficientFee
, RejectCheckpoint
]
elements
[ RejectMalformed,
RejectInvalid,
RejectInvalid,
RejectDuplicate,
RejectNonStandard,
RejectDust,
RejectInsufficientFee,
RejectCheckpoint
]
-- | Arbitrary non-empty 'GetData'.
arbitraryGetData :: Gen GetData
@ -128,28 +127,27 @@ arbitraryPong = Pong <$> arbitrary
-- | Arbitrary bloom filter flags.
arbitraryBloomFlags :: Gen BloomFlags
arbitraryBloomFlags =
elements
[ BloomUpdateNone
, BloomUpdateAll
, BloomUpdateP2PubKeyOnly
]
elements
[ BloomUpdateNone,
BloomUpdateAll,
BloomUpdateP2PubKeyOnly
]
{- | Arbitrary bloom filter with its corresponding number of elements
and false positive rate.
-}
-- | Arbitrary bloom filter with its corresponding number of elements
-- and false positive rate.
arbitraryBloomFilter :: Gen (Int, Double, BloomFilter)
arbitraryBloomFilter = do
n <- choose (0, 100000)
fp <- choose (1e-8, 1)
tweak <- arbitrary
fl <- arbitraryBloomFlags
return (n, fp, bloomCreate n fp tweak fl)
n <- choose (0, 100000)
fp <- choose (1e-8, 1)
tweak <- arbitrary
fl <- arbitraryBloomFlags
return (n, fp, bloomCreate n fp tweak fl)
-- | Arbitrary 'FilterLoad'.
arbitraryFilterLoad :: Gen FilterLoad
arbitraryFilterLoad = do
(_, _, bf) <- arbitraryBloomFilter
return $ FilterLoad bf
(_, _, bf) <- arbitraryBloomFilter
return $ FilterLoad bf
-- | Arbitrary 'FilterAdd'.
arbitraryFilterAdd :: Gen FilterAdd
@ -158,26 +156,26 @@ arbitraryFilterAdd = FilterAdd <$> arbitraryBS
-- | Arbitrary 'MessageCommand'.
arbitraryMessageCommand :: Gen MessageCommand
arbitraryMessageCommand = do
ASCIIString str <- arbitrary
elements
[ MCVersion
, MCVerAck
, MCAddr
, MCInv
, MCGetData
, MCNotFound
, MCGetBlocks
, MCGetHeaders
, MCTx
, MCBlock
, MCMerkleBlock
, MCHeaders
, MCGetAddr
, MCFilterLoad
, MCFilterAdd
, MCFilterClear
, MCPing
, MCPong
, MCAlert
, MCOther (C8.take 12 (C8.pack (filter (/= '\NUL') str)))
]
ASCIIString str <- arbitrary
elements
[ MCVersion,
MCVerAck,
MCAddr,
MCInv,
MCGetData,
MCNotFound,
MCGetBlocks,
MCGetHeaders,
MCTx,
MCBlock,
MCMerkleBlock,
MCHeaders,
MCGetAddr,
MCFilterLoad,
MCFilterAdd,
MCFilterClear,
MCPing,
MCPong,
MCAlert,
MCOther (C8.take 12 (C8.pack (filter (/= '\NUL') str)))
]

635
src/Haskoin/Util/Arbitrary/Script.hs
View File

@ -1,23 +1,25 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{- |
Module : Haskoin.Test.Script
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
-}
-- |
-- Module : Haskoin.Test.Script
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
module Haskoin.Util.Arbitrary.Script where
import Crypto.Secp256k1
import qualified Data.ByteString as B
import Data.ByteString qualified as B
import Data.Maybe
import Data.Word
import Haskoin.Address
import Haskoin.Constants
import Haskoin.Data
import Haskoin.Keys.Common
import Haskoin.Crypto.Keys.Common
import Haskoin.Network.Constants
import Haskoin.Network.Data
import Haskoin.Script
import Haskoin.Transaction.Common
import Haskoin.Util
@ -34,156 +36,156 @@ arbitraryScript = Script <$> listOf arbitraryScriptOp
-- | Arbitrary 'ScriptOp' (push operations have random data).
arbitraryScriptOp :: Gen ScriptOp
arbitraryScriptOp =
oneof
-- Pushing Data
[ opPushData <$> arbitraryBS1
, return OP_0
, return OP_1NEGATE
, return OP_RESERVED
, return OP_1
, return OP_2
, return OP_3
, return OP_4
, return OP_5
, return OP_6
, return OP_7
, return OP_8
, return OP_9
, return OP_10
, return OP_11
, return OP_12
, return OP_13
, return OP_14
, return OP_15
, return OP_16
, -- Flow control
return OP_NOP
, return OP_VER
, return OP_IF
, return OP_NOTIF
, return OP_VERIF
, return OP_VERNOTIF
, return OP_ELSE
, return OP_ENDIF
, return OP_VERIFY
, return OP_RETURN
, -- Stack operations
return OP_TOALTSTACK
, return OP_FROMALTSTACK
, return OP_IFDUP
, return OP_DEPTH
, return OP_DROP
, return OP_DUP
, return OP_NIP
, return OP_OVER
, return OP_PICK
, return OP_ROLL
, return OP_ROT
, return OP_SWAP
, return OP_TUCK
, return OP_2DROP
, return OP_2DUP
, return OP_3DUP
, return OP_2OVER
, return OP_2ROT
, return OP_2SWAP
, -- Splice
return OP_CAT
, return OP_SUBSTR
, return OP_LEFT
, return OP_RIGHT
, return OP_SIZE
, -- Bitwise logic
return OP_INVERT
, return OP_AND
, return OP_OR
, return OP_XOR
, return OP_EQUAL
, return OP_EQUALVERIFY
, return OP_RESERVED1
, return OP_RESERVED2
, -- Arithmetic
return OP_1ADD
, return OP_1SUB
, return OP_2MUL
, return OP_2DIV
, return OP_NEGATE
, return OP_ABS
, return OP_NOT
, return OP_0NOTEQUAL
, return OP_ADD
, return OP_SUB
, return OP_MUL
, return OP_DIV
, return OP_MOD
, return OP_LSHIFT
, return OP_RSHIFT
, return OP_BOOLAND
, return OP_BOOLOR
, return OP_NUMEQUAL
, return OP_NUMEQUALVERIFY
, return OP_NUMNOTEQUAL
, return OP_LESSTHAN
, return OP_GREATERTHAN
, return OP_LESSTHANOREQUAL
, return OP_GREATERTHANOREQUAL
, return OP_MIN
, return OP_MAX
, return OP_WITHIN
, -- Crypto
return OP_RIPEMD160
, return OP_SHA1
, return OP_SHA256
, return OP_HASH160
, return OP_HASH256
, return OP_CODESEPARATOR
, return OP_CHECKSIG
, return OP_CHECKSIGVERIFY
, return OP_CHECKMULTISIG
, return OP_CHECKMULTISIGVERIFY
, -- Expansion
return OP_NOP1
, return OP_CHECKLOCKTIMEVERIFY
, return OP_CHECKSEQUENCEVERIFY
, return OP_NOP4
, return OP_NOP5
, return OP_NOP6
, return OP_NOP7
, return OP_NOP8
, return OP_NOP9
, return OP_NOP10
, -- Bitcoin Cash Nov 2018 hard fork
return OP_CHECKDATASIG
, return OP_CHECKDATASIGVERIFY
, -- Bitcoin Cash May 2020 hard fork
return OP_REVERSEBYTES
, -- Other
return OP_PUBKEYHASH
, return OP_PUBKEY
, return $ OP_INVALIDOPCODE 0xff
]
oneof
-- Pushing Data
[ opPushData <$> arbitraryBS1,
return OP_0,
return OP_1NEGATE,
return OP_RESERVED,
return OP_1,
return OP_2,
return OP_3,
return OP_4,
return OP_5,
return OP_6,
return OP_7,
return OP_8,
return OP_9,
return OP_10,
return OP_11,
return OP_12,
return OP_13,
return OP_14,
return OP_15,
return OP_16,
-- Flow control
return OP_NOP,
return OP_VER,
return OP_IF,
return OP_NOTIF,
return OP_VERIF,
return OP_VERNOTIF,
return OP_ELSE,
return OP_ENDIF,
return OP_VERIFY,
return OP_RETURN,
-- Stack operations
return OP_TOALTSTACK,
return OP_FROMALTSTACK,
return OP_IFDUP,
return OP_DEPTH,
return OP_DROP,
return OP_DUP,
return OP_NIP,
return OP_OVER,
return OP_PICK,
return OP_ROLL,
return OP_ROT,
return OP_SWAP,
return OP_TUCK,
return OP_2DROP,
return OP_2DUP,
return OP_3DUP,
return OP_2OVER,
return OP_2ROT,
return OP_2SWAP,
-- Splice
return OP_CAT,
return OP_SUBSTR,
return OP_LEFT,
return OP_RIGHT,
return OP_SIZE,
-- Bitwise logic
return OP_INVERT,
return OP_AND,
return OP_OR,
return OP_XOR,
return OP_EQUAL,
return OP_EQUALVERIFY,
return OP_RESERVED1,
return OP_RESERVED2,
-- Arithmetic
return OP_1ADD,
return OP_1SUB,
return OP_2MUL,
return OP_2DIV,
return OP_NEGATE,
return OP_ABS,
return OP_NOT,
return OP_0NOTEQUAL,
return OP_ADD,
return OP_SUB,
return OP_MUL,
return OP_DIV,
return OP_MOD,
return OP_LSHIFT,
return OP_RSHIFT,
return OP_BOOLAND,
return OP_BOOLOR,
return OP_NUMEQUAL,
return OP_NUMEQUALVERIFY,
return OP_NUMNOTEQUAL,
return OP_LESSTHAN,
return OP_GREATERTHAN,
return OP_LESSTHANOREQUAL,
return OP_GREATERTHANOREQUAL,
return OP_MIN,
return OP_MAX,
return OP_WITHIN,
-- Crypto
return OP_RIPEMD160,
return OP_SHA1,
return OP_SHA256,
return OP_HASH160,
return OP_HASH256,
return OP_CODESEPARATOR,
return OP_CHECKSIG,
return OP_CHECKSIGVERIFY,
return OP_CHECKMULTISIG,
return OP_CHECKMULTISIGVERIFY,
-- Expansion
return OP_NOP1,
return OP_CHECKLOCKTIMEVERIFY,
return OP_CHECKSEQUENCEVERIFY,
return OP_NOP4,
return OP_NOP5,
return OP_NOP6,
return OP_NOP7,
return OP_NOP8,
return OP_NOP9,
return OP_NOP10,
-- Bitcoin Cash Nov 2018 hard fork
return OP_CHECKDATASIG,
return OP_CHECKDATASIGVERIFY,
-- Bitcoin Cash May 2020 hard fork
return OP_REVERSEBYTES,
-- Other
return OP_PUBKEYHASH,
return OP_PUBKEY,
return $ OP_INVALIDOPCODE 0xff
]
-- | Arbtirary 'ScriptOp' with a value in @[OP_1 .. OP_16]@.
arbitraryIntScriptOp :: Gen ScriptOp
arbitraryIntScriptOp =
elements
[ OP_1
, OP_2
, OP_3
, OP_4
, OP_5
, OP_6
, OP_7
, OP_8
, OP_9
, OP_10
, OP_11
, OP_12
, OP_13
, OP_14
, OP_15
, OP_16
]
elements
[ OP_1,
OP_2,
OP_3,
OP_4,
OP_5,
OP_6,
OP_7,
OP_8,
OP_9,
OP_10,
OP_11,
OP_12,
OP_13,
OP_14,
OP_15,
OP_16
]
-- | Arbitrary 'PushDataType'.
arbitraryPushDataType :: Gen PushDataType
@ -196,88 +198,86 @@ arbitrarySigHash = fromIntegral <$> (arbitrary :: Gen Word32)
-- | Arbitrary valid 'SigHash'.
arbitraryValidSigHash :: Network -> Gen SigHash
arbitraryValidSigHash net = do
sh <- elements [sigHashAll, sigHashNone, sigHashSingle]
f1 <-
elements $
if isJust (getSigHashForkId net)
then [id, setForkIdFlag]
else [id]
f2 <- elements [id, setAnyoneCanPayFlag]
return $ f1 $ f2 sh
sh <- elements [sigHashAll, sigHashNone, sigHashSingle]
f1 <-
elements $
if isJust net.sigHashForkId
then [id, setForkIdFlag]
else [id]
f2 <- elements [id, setAnyoneCanPay]
return $ f1 $ f2 sh
arbitrarySigHashFlag :: Gen SigHashFlag
arbitrarySigHashFlag =
elements
[ SIGHASH_ALL
, SIGHASH_NONE
, SIGHASH_SINGLE
, SIGHASH_FORKID
, SIGHASH_ANYONECANPAY
]
elements
[ SIGHASH_ALL,
SIGHASH_NONE,
SIGHASH_SINGLE,
SIGHASH_FORKID,
SIGHASH_ANYONECANPAY
]
{- | Arbitrary message hash, private key and corresponding 'TxSignature'. The
signature is generated deterministically using a random message and a random
private key.
-}
arbitraryTxSignature :: Network -> Gen (TxHash, SecKey, TxSignature)
arbitraryTxSignature net = do
(m, key, sig) <- arbitrarySignature
sh <- (fromIntegral <$> (arbitrary :: Gen Word8)) `suchThat` filterBad
let txsig = TxSignature sig sh
return (TxHash m, key, txsig)
-- | Arbitrary message hash, private key and corresponding 'TxSignature'. The
-- signature is generated deterministically using a random message and a random
-- private key.
arbitraryTxSignature :: Network -> Ctx -> Gen (TxHash, SecKey, TxSignature)
arbitraryTxSignature net ctx = do
(m, key, sig) <- arbitrarySignature ctx
sh <- (fromIntegral <$> (arbitrary :: Gen Word8)) `suchThat` filterBad
let txsig = TxSignature sig sh
return (TxHash m, key, txsig)
where
filterBad sh =
not $
isSigHashUnknown sh
|| isNothing (getSigHashForkId net) && hasForkIdFlag sh
not $
isSigHashUnknown sh
|| isNothing net.sigHashForkId && hasForkIdFlag sh
-- | Arbitrary transaction signature that could also be empty.
arbitraryTxSignatureEmpty :: Network -> Gen TxSignature
arbitraryTxSignatureEmpty net =
frequency
[ (1, return TxSignatureEmpty)
, (10, lst3 <$> arbitraryTxSignature net)
]
arbitraryTxSignatureEmpty :: Network -> Ctx -> Gen TxSignature
arbitraryTxSignatureEmpty net ctx =
frequency
[ (1, return TxSignatureEmpty),
(10, lst3 <$> arbitraryTxSignature net ctx)
]
-- | Arbitrary m of n parameters.
arbitraryMSParam :: Gen (Int, Int)
arbitraryMSParam = do
m <- choose (1, 16)
n <- choose (m, 16)
return (m, n)
m <- choose (1, 16)
n <- choose (m, 16)
return (m, n)
-- | Arbitrary 'ScriptOutput' (Can by any valid type).
arbitraryScriptOutput :: Network -> Gen ScriptOutput
arbitraryScriptOutput net =
oneof $
[ arbitraryPKOutput
, arbitraryPKHashOutput
, arbitraryMSOutput
, arbitrarySHOutput
, arbitraryDCOutput
]
++ if getSegWit net
then
[ arbitraryWPKHashOutput
, arbitraryWSHOutput
, arbitraryWitOutput
]
else []
arbitraryScriptOutput :: Network -> Ctx -> Gen ScriptOutput
arbitraryScriptOutput net ctx =
oneof $
[ arbitraryPKOutput ctx,
arbitraryPKHashOutput,
arbitraryMSOutput ctx,
arbitrarySHOutput,
arbitraryDCOutput
]
++ if net.segWit
then
[ arbitraryWPKHashOutput,
arbitraryWSHOutput,
arbitraryWitOutput
]
else []
{- | Arbitrary 'ScriptOutput' of type 'PayPK', 'PayPKHash' or 'PayMS'
(Not 'PayScriptHash', 'DataCarrier', or SegWit)
-}
arbitrarySimpleOutput :: Gen ScriptOutput
arbitrarySimpleOutput =
oneof
[ arbitraryPKOutput
, arbitraryPKHashOutput
, arbitraryMSOutput
]
-- | Arbitrary 'ScriptOutput' of type 'PayPK', 'PayPKHash' or 'PayMS'
-- (Not 'PayScriptHash', 'DataCarrier', or SegWit)
arbitrarySimpleOutput :: Ctx -> Gen ScriptOutput
arbitrarySimpleOutput ctx =
oneof
[ arbitraryPKOutput ctx,
arbitraryPKHashOutput,
arbitraryMSOutput ctx
]
-- | Arbitrary 'ScriptOutput' of type 'PayPK'
arbitraryPKOutput :: Gen ScriptOutput
arbitraryPKOutput = PayPK . snd <$> arbitraryKeyPair
arbitraryPKOutput :: Ctx -> Gen ScriptOutput
arbitraryPKOutput ctx = PayPK . snd <$> arbitraryKeyPair ctx
-- | Arbitrary 'ScriptOutput' of type 'PayPKHash'
arbitraryPKHashOutput :: Gen ScriptOutput
@ -293,131 +293,128 @@ arbitraryWSHOutput = PayWitnessScriptHash <$> arbitraryHash256
arbitraryWitOutput :: Gen ScriptOutput
arbitraryWitOutput = do
ver <- choose (1, 16)
len <- choose (2, 40)
ws <- vectorOf len arbitrary
let bs = B.pack ws
return $ PayWitness ver bs
ver <- choose (1, 16)
len <- choose (2, 40)
ws <- vectorOf len arbitrary
let bs = B.pack ws
return $ PayWitness ver bs
-- | Arbitrary 'ScriptOutput' of type 'PayMS'.
arbitraryMSOutput :: Gen ScriptOutput
arbitraryMSOutput = do
(m, n) <- arbitraryMSParam
keys <- map snd <$> vectorOf n arbitraryKeyPair
return $ PayMulSig keys m
arbitraryMSOutput :: Ctx -> Gen ScriptOutput
arbitraryMSOutput ctx = do
(m, n) <- arbitraryMSParam
keys <- map snd <$> vectorOf n (arbitraryKeyPair ctx)
return $ PayMulSig keys m
-- | Arbitrary 'ScriptOutput' of type 'PayMS', only using compressed keys.
arbitraryMSOutputC :: Gen ScriptOutput
arbitraryMSOutputC = do
(m, n) <- arbitraryMSParam
keys <-
map snd
<$> vectorOf n (arbitraryKeyPair `suchThat` (pubKeyCompressed . snd))
return $ PayMulSig keys m
arbitraryMSOutputC :: Ctx -> Gen ScriptOutput
arbitraryMSOutputC ctx = do
(m, n) <- arbitraryMSParam
keys <-
map snd
<$> vectorOf n (arbitraryKeyPair ctx `suchThat` ((.compress) . snd))
return $ PayMulSig keys m
-- | Arbitrary 'ScriptOutput' of type 'PayScriptHash'.
arbitrarySHOutput :: Gen ScriptOutput
arbitrarySHOutput = PayScriptHash . getAddrHash160 <$> arbitraryScriptAddress
arbitrarySHOutput = PayScriptHash . (.hash160) <$> arbitraryScriptAddress
-- | Arbitrary 'ScriptOutput' of type 'DataCarrier'.
arbitraryDCOutput :: Gen ScriptOutput
arbitraryDCOutput = DataCarrier <$> arbitraryBS1
-- | Arbitrary 'ScriptInput'.
arbitraryScriptInput :: Network -> Gen ScriptInput
arbitraryScriptInput net =
oneof
[ arbitraryPKInput net
, arbitraryPKHashInput net
, arbitraryMSInput net
, arbitrarySHInput net
]
arbitraryScriptInput :: Network -> Ctx -> Gen ScriptInput
arbitraryScriptInput net ctx =
oneof
[ arbitraryPKInput net ctx,
arbitraryPKHashInput net ctx,
arbitraryMSInput net ctx,
arbitrarySHInput net ctx
]
{- | Arbitrary 'ScriptInput' of type 'SpendPK', 'SpendPKHash' or 'SpendMulSig'
(not 'ScriptHashInput')
-}
arbitrarySimpleInput :: Network -> Gen ScriptInput
arbitrarySimpleInput net =
oneof
[ arbitraryPKInput net
, arbitraryPKHashInput net
, arbitraryMSInput net
]
-- | Arbitrary 'ScriptInput' of type 'SpendPK', 'SpendPKHash' or 'SpendMulSig'
-- (not 'ScriptHashInput')
arbitrarySimpleInput :: Network -> Ctx -> Gen ScriptInput
arbitrarySimpleInput net ctx =
oneof
[ arbitraryPKInput net ctx,
arbitraryPKHashInput net ctx,
arbitraryMSInput net ctx
]
-- | Arbitrary 'ScriptInput' of type 'SpendPK'.
arbitraryPKInput :: Network -> Gen ScriptInput
arbitraryPKInput net = RegularInput . SpendPK <$> arbitraryTxSignatureEmpty net
arbitraryPKInput :: Network -> Ctx -> Gen ScriptInput
arbitraryPKInput net ctx = RegularInput . SpendPK <$> arbitraryTxSignatureEmpty net ctx
-- | Arbitrary 'ScriptInput' of type 'SpendPK'.
arbitraryPKHashInput :: Network -> Gen ScriptInput
arbitraryPKHashInput net = do
sig <- arbitraryTxSignatureEmpty net
key <- snd <$> arbitraryKeyPair
return $ RegularInput $ SpendPKHash sig key
arbitraryPKHashInput :: Network -> Ctx -> Gen ScriptInput
arbitraryPKHashInput net ctx = do
sig <- arbitraryTxSignatureEmpty net ctx
key <- snd <$> arbitraryKeyPair ctx
return $ RegularInput $ SpendPKHash sig key
-- | Like 'arbitraryPKHashInput' without empty signatures.
arbitraryPKHashInputFull :: Network -> Gen ScriptInput
arbitraryPKHashInputFull net = do
sig <- lst3 <$> arbitraryTxSignature net
key <- snd <$> arbitraryKeyPair
return $ RegularInput $ SpendPKHash sig key
arbitraryPKHashInputFull :: Network -> Ctx -> Gen ScriptInput
arbitraryPKHashInputFull net ctx = do
sig <- lst3 <$> arbitraryTxSignature net ctx
key <- snd <$> arbitraryKeyPair ctx
return $ RegularInput $ SpendPKHash sig key
-- | Like above but only compressed.
arbitraryPKHashInputFullC :: Network -> Gen ScriptInput
arbitraryPKHashInputFullC net = do
sig <- lst3 <$> arbitraryTxSignature net
key <- fmap snd $ arbitraryKeyPair `suchThat` (pubKeyCompressed . snd)
return $ RegularInput $ SpendPKHash sig key
arbitraryPKHashInputFullC :: Network -> Ctx -> Gen ScriptInput
arbitraryPKHashInputFullC net ctx = do
sig <- lst3 <$> arbitraryTxSignature net ctx
key <- fmap snd $ arbitraryKeyPair ctx `suchThat` ((.compress) . snd)
return $ RegularInput $ SpendPKHash sig key
-- | Arbitrary 'ScriptInput' of type 'SpendMulSig'.
arbitraryMSInput :: Network -> Gen ScriptInput
arbitraryMSInput net = do
m <- fst <$> arbitraryMSParam
sigs <- vectorOf m (arbitraryTxSignatureEmpty net)
return $ RegularInput $ SpendMulSig sigs
arbitraryMSInput :: Network -> Ctx -> Gen ScriptInput
arbitraryMSInput net ctx = do
m <- fst <$> arbitraryMSParam
sigs <- vectorOf m (arbitraryTxSignatureEmpty net ctx)
return $ RegularInput $ SpendMulSig sigs
-- | Arbitrary 'ScriptInput' of type 'ScriptHashInput'.
arbitrarySHInput :: Network -> Gen ScriptInput
arbitrarySHInput net = do
i <- arbitrarySimpleInput net
ScriptHashInput (getRegularInput i) <$> arbitrarySimpleOutput
arbitrarySHInput :: Network -> Ctx -> Gen ScriptInput
arbitrarySHInput net ctx = do
i <- arbitrarySimpleInput net ctx
ScriptHashInput i.get <$> arbitrarySimpleOutput ctx
{- | Arbitrary 'ScriptInput' of type 'ScriptHashInput' containing a
'RedeemScript' of type 'PayMulSig' and an input of type 'SpendMulSig'.
-}
arbitraryMulSigSHInput :: Network -> Gen ScriptInput
arbitraryMulSigSHInput net =
arbitraryMSOutput >>= \case
rdm@(PayMulSig _ m) -> do
sigs <- vectorOf m (arbitraryTxSignatureEmpty net)
return $ ScriptHashInput (SpendMulSig sigs) rdm
_ -> undefined
-- | Arbitrary 'ScriptInput' of type 'ScriptHashInput' containing a
-- 'RedeemScript' of type 'PayMulSig' and an input of type 'SpendMulSig'.
arbitraryMulSigSHInput :: Network -> Ctx -> Gen ScriptInput
arbitraryMulSigSHInput net ctx =
arbitraryMSOutput ctx >>= \case
rdm@(PayMulSig _ m) -> do
sigs <- vectorOf m (arbitraryTxSignatureEmpty net ctx)
return $ ScriptHashInput (SpendMulSig sigs) rdm
_ -> undefined
{- | Arbitrary 'ScriptInput' of type 'ScriptHashInput' containing a
'RedeemScript' of type 'PayMulSig' and an input of type 'SpendMulSig'.
-}
arbitraryMulSigSHInputC :: Network -> Gen ScriptInput
arbitraryMulSigSHInputC net =
arbitraryMSOutputC >>= \case
rdm@(PayMulSig _ m) -> do
sigs <- vectorOf m (arbitraryTxSignatureEmpty net)
return $ ScriptHashInput (SpendMulSig sigs) rdm
_ -> undefined
-- | Arbitrary 'ScriptInput' of type 'ScriptHashInput' containing a
-- 'RedeemScript' of type 'PayMulSig' and an input of type 'SpendMulSig'.
arbitraryMulSigSHInputC :: Network -> Ctx -> Gen ScriptInput
arbitraryMulSigSHInputC net ctx =
arbitraryMSOutputC ctx >>= \case
rdm@(PayMulSig _ m) -> do
sigs <- vectorOf m (arbitraryTxSignatureEmpty net ctx)
return $ ScriptHashInput (SpendMulSig sigs) rdm
_ -> undefined
-- | Like 'arbitraryMulSigSHCInput' with no empty signatures.
arbitraryMulSigSHInputFull :: Network -> Gen ScriptInput
arbitraryMulSigSHInputFull net =
arbitraryMSOutput >>= \case
rdm@(PayMulSig _ m) -> do
sigs <- map lst3 <$> vectorOf m (arbitraryTxSignature net)
return $ ScriptHashInput (SpendMulSig sigs) rdm
_ -> undefined
arbitraryMulSigSHInputFull :: Network -> Ctx -> Gen ScriptInput
arbitraryMulSigSHInputFull net ctx =
arbitraryMSOutput ctx >>= \case
rdm@(PayMulSig _ m) -> do
sigs <- map lst3 <$> vectorOf m (arbitraryTxSignature net ctx)
return $ ScriptHashInput (SpendMulSig sigs) rdm
_ -> undefined
-- | Like 'arbitraryMulSigSHCInput' with no empty signatures.
arbitraryMulSigSHInputFullC :: Network -> Gen ScriptInput
arbitraryMulSigSHInputFullC net =
arbitraryMSOutputC >>= \case
rdm@(PayMulSig _ m) -> do
sigs <- map lst3 <$> vectorOf m (arbitraryTxSignature net)
return $ ScriptHashInput (SpendMulSig sigs) rdm
_ -> undefined
arbitraryMulSigSHInputFullC :: Network -> Ctx -> Gen ScriptInput
arbitraryMulSigSHInputFullC net ctx =
arbitraryMSOutputC ctx >>= \case
rdm@(PayMulSig _ m) -> do
sigs <- map lst3 <$> vectorOf m (arbitraryTxSignature net ctx)
return $ ScriptHashInput (SpendMulSig sigs) rdm
_ -> undefined

410
src/Haskoin/Util/Arbitrary/Transaction.hs
View File

@ -1,24 +1,29 @@
{- |
Module : Haskoin.Test.Transaction
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedRecordDot #-}
-- |
-- Module : Haskoin.Test.Transaction
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
module Haskoin.Util.Arbitrary.Transaction where
import Control.Monad
import qualified Data.ByteString as BS
import Data.ByteString qualified as BS
import Data.Either (fromRight)
import Data.List (nub, nubBy, permutations)
import Data.Word (Word64)
import Haskoin.Address
import Haskoin.Constants
import Haskoin.Data
import Haskoin.Keys.Common
import Haskoin.Crypto (Ctx)
import Haskoin.Crypto.Keys.Common
import Haskoin.Network.Constants
import Haskoin.Network.Data
import Haskoin.Script
import Haskoin.Transaction
import Haskoin.Util
import Haskoin.Util.Arbitrary.Crypto
import Haskoin.Util.Arbitrary.Keys
import Haskoin.Util.Arbitrary.Script
@ -27,10 +32,10 @@ import Test.QuickCheck
-- | Wrapped coin value for testing.
newtype TestCoin = TestCoin {getTestCoin :: Word64}
deriving (Eq, Show)
deriving (Eq, Show)
instance Coin TestCoin where
coinValue = getTestCoin
coinValue = getTestCoin
-- | Arbitrary transaction hash (for non-existent transaction).
arbitraryTxHash :: Gen TxHash
@ -38,244 +43,241 @@ arbitraryTxHash = TxHash <$> arbitraryHash256
-- | Arbitrary amount of Satoshi as 'Word64' (Between 1 and 21e14)
arbitrarySatoshi :: Network -> Gen TestCoin
arbitrarySatoshi net = TestCoin <$> choose (1, getMaxSatoshi net)
arbitrarySatoshi net = TestCoin <$> choose (1, net.maxSatoshi)
-- | Arbitrary 'OutPoint'.
arbitraryOutPoint :: Gen OutPoint
arbitraryOutPoint = OutPoint <$> arbitraryTxHash <*> arbitrary
-- | Arbitrary 'TxOut'.
arbitraryTxOut :: Network -> Gen TxOut
arbitraryTxOut net =
TxOut <$> (getTestCoin <$> arbitrarySatoshi net)
<*> (encodeOutputBS <$> arbitraryScriptOutput net)
arbitraryTxOut :: Network -> Ctx -> Gen TxOut
arbitraryTxOut net ctx =
TxOut
<$> (getTestCoin <$> arbitrarySatoshi net)
<*> (marshal ctx <$> arbitraryScriptOutput net ctx)
-- | Arbitrary 'TxIn'.
arbitraryTxIn :: Network -> Gen TxIn
arbitraryTxIn net =
TxIn <$> arbitraryOutPoint
<*> (encodeInputBS <$> arbitraryScriptInput net)
<*> arbitrary
arbitraryTxIn :: Network -> Ctx -> Gen TxIn
arbitraryTxIn net ctx =
TxIn
<$> arbitraryOutPoint
<*> (marshal (net, ctx) <$> arbitraryScriptInput net ctx)
<*> arbitrary
-- | Arbitrary transaction. Can be regular or with witnesses.
arbitraryTx :: Network -> Gen Tx
arbitraryTx net = oneof [arbitraryLegacyTx net, arbitraryWitnessTx net]
arbitraryTx :: Network -> Ctx -> Gen Tx
arbitraryTx net ctx =
oneof [arbitraryLegacyTx net ctx, arbitraryWitnessTx net ctx]
-- | Arbitrary regular transaction.
arbitraryLegacyTx :: Network -> Gen Tx
arbitraryLegacyTx net = arbitraryWLTx net False
arbitraryLegacyTx :: Network -> Ctx -> Gen Tx
arbitraryLegacyTx net ctx = arbitraryWLTx net ctx False
-- | Arbitrary witness transaction (witness data is fake).
arbitraryWitnessTx :: Network -> Gen Tx
arbitraryWitnessTx net = arbitraryWLTx net True
arbitraryWitnessTx :: Network -> Ctx -> Gen Tx
arbitraryWitnessTx net ctx = arbitraryWLTx net ctx True
-- | Arbitrary witness or legacy transaction.
arbitraryWLTx :: Network -> Bool -> Gen Tx
arbitraryWLTx net wit = do
ni <- choose (1, 5)
no <- choose (1, 5)
inps <- vectorOf ni (arbitraryTxIn net)
outs <- vectorOf no (arbitraryTxOut net)
let uniqueInps = nubBy (\a b -> prevOutput a == prevOutput b) inps
w <-
if wit
then vectorOf (length uniqueInps) (listOf arbitraryBS)
else return []
Tx <$> arbitrary <*> pure uniqueInps <*> pure outs <*> pure w <*> arbitrary
arbitraryWLTx :: Network -> Ctx -> Bool -> Gen Tx
arbitraryWLTx net ctx wit = do
ni <- choose (1, 5)
no <- choose (1, 5)
inps <- vectorOf ni (arbitraryTxIn net ctx)
outs <- vectorOf no (arbitraryTxOut net ctx)
let uniqueInps = nubBy (\a b -> a.outpoint == b.outpoint) inps
w <-
if wit
then vectorOf (length uniqueInps) (listOf arbitraryBS)
else return []
Tx <$> arbitrary <*> pure uniqueInps <*> pure outs <*> pure w <*> arbitrary
{- | Arbitrary transaction containing only inputs of type 'SpendPKHash',
'SpendScriptHash' (multisig) and outputs of type 'PayPKHash' and 'PaySH'.
Only compressed public keys are used.
-}
arbitraryAddrOnlyTx :: Network -> Gen Tx
arbitraryAddrOnlyTx net = do
ni <- choose (1, 5)
no <- choose (1, 5)
inps <- vectorOf ni (arbitraryAddrOnlyTxIn net)
outs <- vectorOf no (arbitraryAddrOnlyTxOut net)
Tx <$> arbitrary <*> pure inps <*> pure outs <*> pure [] <*> arbitrary
-- | Arbitrary transaction containing only inputs of type 'SpendPKHash',
-- 'SpendScriptHash' (multisig) and outputs of type 'PayPKHash' and 'PaySH'.
-- Only compressed public keys are used.
arbitraryAddrOnlyTx :: Network -> Ctx -> Gen Tx
arbitraryAddrOnlyTx net ctx = do
ni <- choose (1, 5)
no <- choose (1, 5)
inps <- vectorOf ni (arbitraryAddrOnlyTxIn net ctx)
outs <- vectorOf no (arbitraryAddrOnlyTxOut net ctx)
Tx <$> arbitrary <*> pure inps <*> pure outs <*> pure [] <*> arbitrary
-- | Like 'arbitraryAddrOnlyTx' without empty signatures in the inputs.
arbitraryAddrOnlyTxFull :: Network -> Gen Tx
arbitraryAddrOnlyTxFull net = do
ni <- choose (1, 5)
no <- choose (1, 5)
inps <- vectorOf ni (arbitraryAddrOnlyTxInFull net)
outs <- vectorOf no (arbitraryAddrOnlyTxOut net)
Tx <$> arbitrary <*> pure inps <*> pure outs <*> pure [] <*> arbitrary
arbitraryAddrOnlyTxFull :: Network -> Ctx -> Gen Tx
arbitraryAddrOnlyTxFull net ctx = do
ni <- choose (1, 5)
no <- choose (1, 5)
inps <- vectorOf ni (arbitraryAddrOnlyTxInFull net ctx)
outs <- vectorOf no (arbitraryAddrOnlyTxOut net ctx)
Tx <$> arbitrary <*> pure inps <*> pure outs <*> pure [] <*> arbitrary
{- | Arbitrary TxIn that can only be of type 'SpendPKHash' or 'SpendScriptHash'
(multisig). Only compressed public keys are used.
-}
arbitraryAddrOnlyTxIn :: Network -> Gen TxIn
arbitraryAddrOnlyTxIn net = do
inp <- oneof [arbitraryPKHashInput net, arbitraryMulSigSHInput net]
TxIn <$> arbitraryOutPoint <*> pure (encodeInputBS inp) <*> arbitrary
-- | Arbitrary TxIn that can only be of type 'SpendPKHash' or 'SpendScriptHash'
-- (multisig). Only compressed public keys are used.
arbitraryAddrOnlyTxIn :: Network -> Ctx -> Gen TxIn
arbitraryAddrOnlyTxIn net ctx = do
inp <- oneof [arbitraryPKHashInput net ctx, arbitraryMulSigSHInput net ctx]
TxIn <$> arbitraryOutPoint <*> pure (marshal (net, ctx) inp) <*> arbitrary
-- | like 'arbitraryAddrOnlyTxIn' with no empty signatures.
arbitraryAddrOnlyTxInFull :: Network -> Gen TxIn
arbitraryAddrOnlyTxInFull net = do
inp <-
oneof [arbitraryPKHashInputFullC net, arbitraryMulSigSHInputFullC net]
TxIn <$> arbitraryOutPoint <*> pure (encodeInputBS inp) <*> arbitrary
arbitraryAddrOnlyTxInFull :: Network -> Ctx -> Gen TxIn
arbitraryAddrOnlyTxInFull net ctx = do
inp <-
oneof [arbitraryPKHashInputFullC net ctx, arbitraryMulSigSHInputFullC net ctx]
TxIn <$> arbitraryOutPoint <*> pure (marshal (net, ctx) inp) <*> arbitrary
-- | Arbitrary 'TxOut' that can only be of type 'PayPKHash' or 'PaySH'.
arbitraryAddrOnlyTxOut :: Network -> Gen TxOut
arbitraryAddrOnlyTxOut net = do
v <- getTestCoin <$> arbitrarySatoshi net
out <- oneof [arbitraryPKHashOutput, arbitrarySHOutput]
return $ TxOut v $ encodeOutputBS out
arbitraryAddrOnlyTxOut :: Network -> Ctx -> Gen TxOut
arbitraryAddrOnlyTxOut net ctx = do
v <- getTestCoin <$> arbitrarySatoshi net
out <- oneof [arbitraryPKHashOutput, arbitrarySHOutput]
return $ TxOut v $ marshal ctx out
{- | Arbitrary 'SigInput' with the corresponding private keys used
to generate the 'ScriptOutput' or 'RedeemScript'.
-}
arbitrarySigInput :: Network -> Gen (SigInput, [SecKeyI])
arbitrarySigInput net =
oneof
[ wrapKey <$> arbitraryPKSigInput net
, wrapKey <$> arbitraryPKHashSigInput net
, arbitraryMSSigInput net
, arbitrarySHSigInput net
, wrapKey <$> arbitraryWPKHSigInput net
, arbitraryWSHSigInput net
]
-- | Arbitrary 'SigInput' with the corresponding private keys used
-- to generate the 'ScriptOutput' or 'RedeemScript'.
arbitrarySigInput :: Network -> Ctx -> Gen (SigInput, [PrivateKey])
arbitrarySigInput net ctx =
oneof
[ wrapKey <$> arbitraryPKSigInput net ctx,
wrapKey <$> arbitraryPKHashSigInput net ctx,
arbitraryMSSigInput net ctx,
arbitrarySHSigInput net ctx,
wrapKey <$> arbitraryWPKHSigInput net ctx,
arbitraryWSHSigInput net ctx
]
-- | Arbitrary 'SigInput' with a 'ScriptOutput' of type 'PayPK'.
arbitraryPKSigInput :: Network -> Gen (SigInput, SecKeyI)
arbitraryPKSigInput net = arbitraryAnyInput net False
arbitraryPKSigInput :: Network -> Ctx -> Gen (SigInput, PrivateKey)
arbitraryPKSigInput net ctx = arbitraryAnyInput net ctx False
-- | Arbitrary 'SigInput' with a 'ScriptOutput' of type 'PayPKHash'.
arbitraryPKHashSigInput :: Network -> Gen (SigInput, SecKeyI)
arbitraryPKHashSigInput net = arbitraryAnyInput net True
arbitraryPKHashSigInput :: Network -> Ctx -> Gen (SigInput, PrivateKey)
arbitraryPKHashSigInput net ctx = arbitraryAnyInput net ctx True
-- | Arbitrary 'SigInput'.
arbitraryAnyInput :: Network -> Bool -> Gen (SigInput, SecKeyI)
arbitraryAnyInput net pkh = do
(k, p) <- arbitraryKeyPair
let out
| pkh = PayPKHash $ getAddrHash160 $ pubKeyAddr p
| otherwise = PayPK p
(val, op, sh) <- arbitraryInputStuff net
return (SigInput out val op sh Nothing, k)
arbitraryAnyInput :: Network -> Ctx -> Bool -> Gen (SigInput, PrivateKey)
arbitraryAnyInput net ctx pkh = do
(k, p) <- arbitraryKeyPair ctx
let out
| pkh = PayPKHash (pubKeyAddr ctx p).hash160
| otherwise = PayPK p
(val, op, sh) <- arbitraryInputStuff net
return (SigInput out val op sh Nothing, k)
-- | Arbitrary value, out point and sighash for an input.
arbitraryInputStuff :: Network -> Gen (Word64, OutPoint, SigHash)
arbitraryInputStuff net = do
val <- getTestCoin <$> arbitrarySatoshi net
op <- arbitraryOutPoint
sh <- arbitraryValidSigHash net
return (val, op, sh)
val <- getTestCoin <$> arbitrarySatoshi net
op <- arbitraryOutPoint
sh <- arbitraryValidSigHash net
return (val, op, sh)
-- | Arbitrary 'SigInput' with a 'ScriptOutput' of type 'PayMulSig'.
arbitraryMSSigInput :: Network -> Gen (SigInput, [SecKeyI])
arbitraryMSSigInput net = do
(m, n) <- arbitraryMSParam
ks <- vectorOf n arbitraryKeyPair
let out = PayMulSig (map snd ks) m
(val, op, sh) <- arbitraryInputStuff net
perm <- choose (0, n - 1)
let ksPerm = map fst $ take m $ permutations ks !! perm
return (SigInput out val op sh Nothing, ksPerm)
arbitraryMSSigInput :: Network -> Ctx -> Gen (SigInput, [PrivateKey])
arbitraryMSSigInput net ctx = do
(m, n) <- arbitraryMSParam
ks <- vectorOf n (arbitraryKeyPair ctx)
let out = PayMulSig (map snd ks) m
(val, op, sh) <- arbitraryInputStuff net
perm <- choose (0, n - 1)
let ksPerm = map fst $ take m $ permutations ks !! perm
return (SigInput out val op sh Nothing, ksPerm)
{- | Arbitrary 'SigInput' with 'ScriptOutput' of type 'PaySH' and a
'RedeemScript'.
-}
arbitrarySHSigInput :: Network -> Gen (SigInput, [SecKeyI])
arbitrarySHSigInput net = do
(SigInput rdm val op sh _, ks) <-
oneof
[ wrapKey <$> arbitraryPKSigInput net
, wrapKey <$> arbitraryPKHashSigInput net
, arbitraryMSSigInput net
]
let out = PayScriptHash $ getAddrHash160 $ payToScriptAddress rdm
return (SigInput out val op sh $ Just rdm, ks)
-- | Arbitrary 'SigInput' with 'ScriptOutput' of type 'PaySH' and a
-- 'RedeemScript'.
arbitrarySHSigInput :: Network -> Ctx -> Gen (SigInput, [PrivateKey])
arbitrarySHSigInput net ctx = do
(SigInput rdm val op sh _, ks) <-
oneof
[ wrapKey <$> arbitraryPKSigInput net ctx,
wrapKey <$> arbitraryPKHashSigInput net ctx,
arbitraryMSSigInput net ctx
]
let out = PayScriptHash (payToScriptAddress ctx rdm).hash160
return (SigInput out val op sh $ Just rdm, ks)
arbitraryWPKHSigInput :: Network -> Gen (SigInput, SecKeyI)
arbitraryWPKHSigInput net = do
(k, p) <- arbitraryKeyPair
(val, op, sh) <- arbitraryInputStuff net
let out = PayWitnessPKHash . getAddrHash160 $ pubKeyAddr p
return (SigInput out val op sh Nothing, k)
arbitraryWPKHSigInput :: Network -> Ctx -> Gen (SigInput, PrivateKey)
arbitraryWPKHSigInput net ctx = do
(k, p) <- arbitraryKeyPair ctx
(val, op, sh) <- arbitraryInputStuff net
let out = PayWitnessPKHash (pubKeyAddr ctx p).hash160
return (SigInput out val op sh Nothing, k)
arbitraryWSHSigInput :: Network -> Gen (SigInput, [SecKeyI])
arbitraryWSHSigInput net = do
(SigInput rdm val op sh _, ks) <-
oneof
[ wrapKey <$> arbitraryPKSigInput net
, wrapKey <$> arbitraryPKHashSigInput net
, arbitraryMSSigInput net
]
let out = PayWitnessScriptHash . getAddrHash256 $ payToWitnessScriptAddress rdm
return (SigInput out val op sh $ Just rdm, ks)
arbitraryWSHSigInput :: Network -> Ctx -> Gen (SigInput, [PrivateKey])
arbitraryWSHSigInput net ctx = do
(SigInput rdm val op sh _, ks) <-
oneof
[ wrapKey <$> arbitraryPKSigInput net ctx,
wrapKey <$> arbitraryPKHashSigInput net ctx,
arbitraryMSSigInput net ctx
]
let out = PayWitnessScriptHash (payToWitnessScriptAddress ctx rdm).hash256
return (SigInput out val op sh $ Just rdm, ks)
{- | Arbitrary 'Tx' (empty 'TxIn'), 'SigInputs' and private keys that can be
passed to 'signTx' or 'detSignTx' to fully sign the 'Tx'.
-}
arbitrarySigningData :: Network -> Gen (Tx, [SigInput], [SecKeyI])
arbitrarySigningData net = do
v <- arbitrary
ni <- choose (1, 5)
no <- choose (1, 5)
sigis <- vectorOf ni (arbitrarySigInput net)
let uSigis = nubBy (\(a, _) (b, _) -> sigInputOP a == sigInputOP b) sigis
inps <- forM uSigis $ \(s, _) -> TxIn (sigInputOP s) BS.empty <$> arbitrary
outs <- vectorOf no (arbitraryTxOut net)
l <- arbitrary
perm <- choose (0, length inps - 1)
let tx = Tx v (permutations inps !! perm) outs [] l
keys = concatMap snd uSigis
return (tx, map fst uSigis, keys)
-- | Arbitrary 'Tx' (empty 'TxIn'), 'SigInputs' and private keys that can be
-- passed to 'signTx' or 'detSignTx' to fully sign the 'Tx'.
arbitrarySigningData :: Network -> Ctx -> Gen (Tx, [SigInput], [PrivateKey])
arbitrarySigningData net ctx = do
v <- arbitrary
ni <- choose (1, 5)
no <- choose (1, 5)
sigis <- vectorOf ni (arbitrarySigInput net ctx)
let uSigis = nubBy (\(a, _) (b, _) -> a.outpoint == b.outpoint) sigis
inps <- forM uSigis $ \(s, _) -> TxIn s.outpoint BS.empty <$> arbitrary
outs <- vectorOf no (arbitraryTxOut net ctx)
l <- arbitrary
perm <- choose (0, length inps - 1)
let tx = Tx v (permutations inps !! perm) outs [] l
keys = concatMap snd uSigis
return (tx, map fst uSigis, keys)
-- | Arbitrary transaction with empty inputs.
arbitraryEmptyTx :: Network -> Gen Tx
arbitraryEmptyTx net = do
v <- arbitrary
no <- choose (1, 5)
ni <- choose (1, 5)
outs <- vectorOf no (arbitraryTxOut net)
ops <- vectorOf ni arbitraryOutPoint
t <- arbitrary
s <- arbitrary
return $ Tx v (map (\op -> TxIn op BS.empty s) (nub ops)) outs [] t
arbitraryEmptyTx :: Network -> Ctx -> Gen Tx
arbitraryEmptyTx net ctx = do
v <- arbitrary
no <- choose (1, 5)
ni <- choose (1, 5)
outs <- vectorOf no (arbitraryTxOut net ctx)
ops <- vectorOf ni arbitraryOutPoint
t <- arbitrary
s <- arbitrary
return $ Tx v (map (\op -> TxIn op BS.empty s) (nub ops)) outs [] t
-- | Arbitrary partially-signed transactions.
arbitraryPartialTxs ::
Network -> Gen ([Tx], [(ScriptOutput, Word64, OutPoint, Int, Int)])
arbitraryPartialTxs net = do
tx <- arbitraryEmptyTx net
res <-
forM (map prevOutput $ txIn tx) $ \op -> do
(so, val, rdmM, prvs, m, n) <- arbitraryData
txs <- mapM (singleSig so val rdmM tx op . secKeyData) prvs
return (txs, (so, val, op, m, n))
return (concatMap fst res, map snd res)
Network -> Ctx -> Gen ([Tx], [(ScriptOutput, Word64, OutPoint, Int, Int)])
arbitraryPartialTxs net ctx = do
tx <- arbitraryEmptyTx net ctx
res <-
forM (map (.outpoint) tx.inputs) $ \op -> do
(so, val, rdmM, prvs, m, n) <- arbitraryData
txs <- mapM (singleSig so val rdmM tx op . (.key)) prvs
return (txs, (so, val, op, m, n))
return (concatMap fst res, map snd res)
where
singleSig so val rdmM tx op prv = do
sh <- arbitraryValidSigHash net
let sigi = SigInput so val op sh rdmM
return . fromRight (error "Could not decode transaction") $
signTx net tx [sigi] [prv]
sh <- arbitraryValidSigHash net
let sigi = SigInput so val op sh rdmM
return . fromRight (error "Could not decode transaction") $
signTx net ctx tx [sigi] [prv]
arbitraryData = do
(m, n) <- arbitraryMSParam
val <- getTestCoin <$> arbitrarySatoshi net
nPrv <- choose (m, n)
keys <- vectorOf n arbitraryKeyPair
perm <- choose (0, length keys - 1)
let pubKeys = map snd keys
prvKeys = take nPrv $ permutations (map fst keys) !! perm
let so = PayMulSig pubKeys m
elements
[ (so, val, Nothing, prvKeys, m, n)
,
( PayScriptHash $ getAddrHash160 $ payToScriptAddress so
, val
, Just so
, prvKeys
, m
, n
)
]
(m, n) <- arbitraryMSParam
val <- getTestCoin <$> arbitrarySatoshi net
nPrv <- choose (m, n)
keys <- vectorOf n (arbitraryKeyPair ctx)
perm <- choose (0, length keys - 1)
let pubKeys = map snd keys
prvKeys = take nPrv $ permutations (map fst keys) !! perm
let so = PayMulSig pubKeys m
elements
[ (so, val, Nothing, prvKeys, m, n),
( PayScriptHash (payToScriptAddress ctx so).hash160,
val,
Just so,
prvKeys,
m,
n
)
]
wrapKey :: (SigInput, SecKeyI) -> (SigInput, [SecKeyI])
wrapKey :: (SigInput, PrivateKey) -> (SigInput, [PrivateKey])
wrapKey (s, k) = (s, [k])

165
src/Haskoin/Util/Arbitrary/Util.hs
View File

@ -1,16 +1,15 @@
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
Module : Haskoin.Test.Util
Copyright : No rights reserved
License : MIT
Maintainer : jprupp@protonmail.ch
Stability : experimental
Portability : POSIX
-}
module Haskoin.Util.Arbitrary.Util (
arbitraryBS,
-- |
-- Module : Haskoin.Test.Util
-- Copyright : No rights reserved
-- License : MIT
-- Maintainer : jprupp@protonmail.ch
-- Stability : experimental
-- Portability : POSIX
module Haskoin.Util.Arbitrary.Util
( arbitraryBS,
arbitraryBS1,
arbitraryBSn,
arbitraryBSS,
@ -30,15 +29,16 @@ module Haskoin.Util.Arbitrary.Util (
testNetJson,
arbitraryNetData,
genNetData,
) where
)
where
import Control.Monad (forM_, (<=<))
import qualified Data.Aeson as A
import qualified Data.Aeson.Encoding as A
import qualified Data.Aeson.Types as A
import Data.ByteString (ByteString, pack)
import qualified Data.ByteString.Short as BSS
import Data.ByteString.Lazy (fromStrict, toStrict)
import qualified Data.ByteString.Short as BSS
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
@ -48,8 +48,8 @@ import Data.Time.Clock (UTCTime (..))
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import qualified Data.Typeable as T
import Data.Word (Word32)
import Haskoin.Constants
import Haskoin.Data
import Haskoin.Network.Constants
import Haskoin.Network.Data
import Test.Hspec (Spec, describe, shouldBe, shouldSatisfy)
import Test.Hspec.QuickCheck (prop)
import Test.QuickCheck
@ -81,16 +81,16 @@ arbitraryBSSn n = BSS.pack <$> vectorOf n arbitrary
-- | Arbitrary UTCTime that generates dates after 01 Jan 1970 01:00:00 CET
arbitraryUTCTime :: Gen UTCTime
arbitraryUTCTime = do
w <- arbitrary :: Gen Word32
return $ posixSecondsToUTCTime $ realToFrac w
w <- arbitrary :: Gen Word32
return $ posixSecondsToUTCTime $ realToFrac w
-- | Generate a Maybe from a Gen a
arbitraryMaybe :: Gen a -> Gen (Maybe a)
arbitraryMaybe g =
frequency
[ (1, return Nothing)
, (5, Just <$> g)
]
frequency
[ (1, return Nothing),
(5, Just <$> g)
]
-- | Generate an Network
arbitraryNetwork :: Gen Network
@ -99,51 +99,55 @@ arbitraryNetwork = elements allNets
-- Helpers for creating Serial and JSON Identity tests
data SerialBox
= forall a.
(Show a, Eq a, T.Typeable a, Serial a) =>
SerialBox (Gen a)
= forall a.
(Show a, Eq a, T.Typeable a, Serial a) =>
SerialBox (Gen a)
data ReadBox
= forall a.
(Read a, Show a, Eq a, T.Typeable a) =>
ReadBox (Gen a)
= forall a.
(Read a, Show a, Eq a, T.Typeable a) =>
ReadBox (Gen a)
data JsonBox
= forall a.
(Show a, Eq a, T.Typeable a, A.ToJSON a, A.FromJSON a) =>
JsonBox (Gen a)
= forall a.
(Show a, Eq a, T.Typeable a, A.ToJSON a, A.FromJSON a) =>
JsonBox (Gen a)
data NetBox
= forall a.
(Show a, Eq a, T.Typeable a) =>
NetBox
( Network -> a -> A.Value
, Network -> a -> A.Encoding
, Network -> A.Value -> A.Parser a
, Gen (Network, a)
)
= forall a.
(Show a, Eq a, T.Typeable a) =>
NetBox
( Network -> a -> A.Value,
Network -> a -> A.Encoding,
Network -> A.Value -> A.Parser a,
Gen (Network, a)
)
testIdentity :: [SerialBox] -> [ReadBox] -> [JsonBox] -> [NetBox] -> Spec
testIdentity serialVals readVals jsonVals netVals = do
describe "Binary Encoding" $
forM_ serialVals $ \(SerialBox g) -> testSerial g
describe "Read/Show Encoding" $
forM_ readVals $ \(ReadBox g) -> testRead g
describe "Data.Aeson Encoding" $
forM_ jsonVals $ \(JsonBox g) -> testJson g
describe "Data.Aeson Encoding with Network" $
forM_ netVals $ \(NetBox (j, e, p, g)) -> testNetJson j e p g
describe "Binary Encoding" $
forM_ serialVals $
\(SerialBox g) -> testSerial g
describe "Read/Show Encoding" $
forM_ readVals $
\(ReadBox g) -> testRead g
describe "Data.Aeson Encoding" $
forM_ jsonVals $
\(JsonBox g) -> testJson g
describe "Data.Aeson Encoding with Network" $
forM_ netVals $
\(NetBox (j, e, p, g)) -> testNetJson j e p g
-- | Generate binary identity tests
testSerial ::
(Eq a, Show a, T.Typeable a, Serial a) => Gen a -> Spec
(Eq a, Show a, T.Typeable a, Serial a) => Gen a -> Spec
testSerial gen =
prop ("Binary encoding/decoding identity for " <> name) $
forAll gen $ \x -> do
(runGetL deserialize . runPutL . serialize) x `shouldBe` x
(runGetL deserialize . fromStrict . runPutS . serialize) x `shouldBe` x
(runGetS deserialize . runPutS . serialize) x `shouldBe` Right x
(runGetS deserialize . toStrict . runPutL . serialize) x `shouldBe` Right x
prop ("Binary encoding/decoding identity for " <> name) $
forAll gen $ \x -> do
(runGetL deserialize . runPutL . serialize) x `shouldBe` x
(runGetL deserialize . fromStrict . runPutS . serialize) x `shouldBe` x
(runGetS deserialize . runPutS . serialize) x `shouldBe` Right x
(runGetS deserialize . toStrict . runPutL . serialize) x `shouldBe` Right x
where
name = show $ T.typeRep $ proxy gen
proxy :: Gen a -> Proxy a
@ -151,10 +155,11 @@ testSerial gen =
-- | Generate Read/Show identity tests
testRead ::
(Eq a, Read a, Show a, T.Typeable a) => Gen a -> Spec
(Eq a, Read a, Show a, T.Typeable a) => Gen a -> Spec
testRead gen =
prop ("read/show identity for " <> name) $
forAll gen $ \x -> (read . show) x `shouldBe` x
prop ("read/show identity for " <> name) $
forAll gen $
\x -> (read . show) x `shouldBe` x
where
name = show $ T.typeRep $ proxy gen
proxy :: Gen a -> Proxy a
@ -162,34 +167,36 @@ testRead gen =
-- | Generate Data.Aeson identity tests
testJson ::
(Eq a, Show a, T.Typeable a, A.ToJSON a, A.FromJSON a) => Gen a -> Spec
(Eq a, Show a, T.Typeable a, A.ToJSON a, A.FromJSON a) => Gen a -> Spec
testJson gen = do
prop ("Data.Aeson toJSON/fromJSON identity for " <> name) $
forAll gen (`shouldSatisfy` jsonID)
prop ("Data.Aeson toEncoding/fromJSON identity for " <> name) $
forAll gen (`shouldSatisfy` encodingID)
prop ("Data.Aeson toJSON/fromJSON identity for " <> name) $
forAll gen (`shouldSatisfy` jsonID)
prop ("Data.Aeson toEncoding/fromJSON identity for " <> name) $
forAll gen (`shouldSatisfy` encodingID)
where
name = show $ T.typeRep $ proxy gen
proxy :: Gen a -> Proxy a
proxy = const Proxy
jsonID x = (A.fromJSON . A.toJSON) (toMap x) == A.Success (toMap x)
encodingID x =
(A.decode . A.encodingToLazyByteString . A.toEncoding) (toMap x)
== Just (toMap x)
(A.decode . A.encodingToLazyByteString . A.toEncoding) (toMap x)
== Just (toMap x)
-- | Generate Data.Aeson identity tests for type that need the @Network@
testNetJson ::
(Eq a, Show a, T.Typeable a) =>
(Network -> a -> A.Value) ->
(Network -> a -> A.Encoding) ->
(Network -> A.Value -> A.Parser a) ->
Gen (Network, a) ->
Spec
(Eq a, Show a, T.Typeable a) =>
(Network -> a -> A.Value) ->
(Network -> a -> A.Encoding) ->
(Network -> A.Value -> A.Parser a) ->
Gen (Network, a) ->
Spec
testNetJson j e p g = do
prop ("Data.Aeson toJSON/fromJSON identity (with network) for " <> name) $
forAll g $ \(net, x) -> dec net (encVal net x) `shouldBe` Just x
prop ("Data.Aeson toEncoding/fromJSON identity (with network) for " <> name) $
forAll g $ \(net, x) -> dec net (encEnc net x) `shouldBe` Just x
prop ("Data.Aeson toJSON/fromJSON identity (with network) for " <> name) $
forAll g $
\(net, x) -> dec net (encVal net x) `shouldBe` Just x
prop ("Data.Aeson toEncoding/fromJSON identity (with network) for " <> name) $
forAll g $
\(net, x) -> dec net (encEnc net x) `shouldBe` Just x
where
encVal net = A.encode . toMap . j net
encEnc net = A.encodingToLazyByteString . toMapE . e net
@ -198,17 +205,17 @@ testNetJson j e p g = do
proxy :: (Network -> a -> A.Value) -> Proxy a
proxy = const Proxy
arbitraryNetData :: Arbitrary a => Gen (Network, a)
arbitraryNetData :: (Arbitrary a) => Gen (Network, a)
arbitraryNetData = do
net <- arbitraryNetwork
x <- arbitrary
return (net, x)
net <- arbitraryNetwork
x <- arbitrary
return (net, x)
genNetData :: Gen a -> Gen (Network, a)
genNetData gen = do
net <- arbitraryNetwork
x <- gen
return (net, x)
net <- arbitraryNetwork
x <- gen
return (net, x)
toMap :: a -> Map.Map String a
toMap = Map.singleton "object"

426
src/Haskoin/Util/Helpers.hs Normal file
View 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
View 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

4
stack.yaml
View File

@ -1,8 +1,8 @@
resolver: lts-21.0
resolver: lts-21.4
nix:
packages:
- secp256k1
- pkg-config
extra-deps:
- base16-1.0@sha256:9b72a280a7af75a5026fa25a1b8ae18ec10200a070947723f1fd61dc8d407862,2472
- secp256k1-haskell-0.7.0@sha256:1585601c67d7c62c698402ffe8462de216a499608521a8136d0aa15f0a03a23f,2140
- secp256k1-haskell-1.0.0@sha256:42e1dc0ddba74b752bddf7d55c19aa10b24ff6f51889a53bc07c2ff2107aca16,2082

16
stack.yaml.lock
View File

@ -12,15 +12,15 @@ packages:
original:
hackage: base16-1.0@sha256:9b72a280a7af75a5026fa25a1b8ae18ec10200a070947723f1fd61dc8d407862,2472
- completed:
hackage: secp256k1-haskell-0.7.0@sha256:1585601c67d7c62c698402ffe8462de216a499608521a8136d0aa15f0a03a23f,2140
hackage: secp256k1-haskell-1.0.0@sha256:42e1dc0ddba74b752bddf7d55c19aa10b24ff6f51889a53bc07c2ff2107aca16,2082
pantry-tree:
sha256: a7726275193ac4ef14c9d97378222d3ca494524c48354edf69214513def7d48d
size: 599
sha256: 7846a02f6292cb0179cdf7252b3832f74b3109079e45248c931791f951355702
size: 600
original:
hackage: secp256k1-haskell-0.7.0@sha256:1585601c67d7c62c698402ffe8462de216a499608521a8136d0aa15f0a03a23f,2140
hackage: secp256k1-haskell-1.0.0@sha256:42e1dc0ddba74b752bddf7d55c19aa10b24ff6f51889a53bc07c2ff2107aca16,2082
snapshots:
- completed:
sha256: 1867d84255dff8c87373f5dd03e5a5cb1c10a99587e26c8793e750c54e83ffdc
size: 639139
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/0.yaml
original: lts-21.0
sha256: caa77fdbc5b9f698262b21ee78030133272ec53116ad6ddbefdc4c321f668e0c
size: 640014
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/4.yaml
original: lts-21.4

398
test/Haskoin/Address/Bech32Spec.hs
View File

@ -1,18 +1,17 @@
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
module Haskoin.Address.Bech32Spec (
spec,
) where
module Haskoin.Address.Bech32Spec (spec) where
import Control.Monad
import Data.Bits (xor)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.ByteString qualified as ByteString
import Data.Char (chr, ord, toLower)
import Data.Maybe
import Data.String.Conversions
import Data.Text (Text, append, pack, snoc, uncons)
import qualified Data.Text as T
import Data.Text qualified as Text
import Data.Word (Word8)
import Haskoin.Address
import Haskoin.Address.Bech32
@ -21,238 +20,225 @@ import Test.HUnit
import Test.Hspec
spec = do
describe "bech32 checksum" $ do
it "should be valid" $
forM_ validChecksums (uncurry testValidChecksum)
it "should be invalid" $
forM_ invalidChecksums testInvalidChecksum
it "should be case-insensitive" $
all (== Just "test12hrzfj") $
map (flip (bech32Encode Bech32) []) hrpCaseVariants
describe "bech32 address" $ do
it "should be valid" $
forM_ validChecksums (uncurry testValidChecksum)
it "should be invalid" $
forM_ invalidChecksums testInvalidChecksum
it "should be case-insensitive" $
all (== Just "test12hrzfj") $
map (flip (bech32Encode Bech32) []) hrpCaseVariants
describe "bech32 encoding/decoding" $ do
it "should not encode long data string" $
assert . isNothing $
bech32Encode Bech32 "bc" (replicate 82 (word5 (1 :: Word8)))
it "should not encode bad version number" $
assert $ isNothing $ segwitEncode "bc" 17 []
it "should not encode invalid length for version 0" $
assert $ isNothing $ segwitEncode "bc" 0 (replicate 30 1)
it "should relax length restrictions for versions other than 0" $
assert $ isJust $ segwitEncode "bc" 1 (replicate 30 1)
it "should not encode another long data string" $
assert $ isNothing $ segwitEncode "bc" 1 (replicate 41 1)
it "should not encode empty human readable part" $
assert $ isNothing $ bech32Encode Bech32 "" []
it "should not decode empty human-readable part" $
assert $ isNothing $ bech32Decode "10a06t8"
it "human-readable part should be case-insensitive" $
bech32Encode Bech32 "HRP" [] `shouldBe` bech32Encode Bech32 "hrp" []
describe "bech32 checksum" $ do
it "should be valid" $
forM_ validChecksums (uncurry testValidChecksum)
it "should be invalid" $
forM_ invalidChecksums testInvalidChecksum
it "should be case-insensitive" $
all ((== Just "test12hrzfj") . flip (bech32Encode Bech32) []) hrpCaseVariants
describe "bech32 address" $ do
it "should be valid" $
forM_ validChecksums (uncurry testValidChecksum)
it "should be invalid" $
forM_ invalidChecksums testInvalidChecksum
it "should be case-insensitive" $
all ((== Just "test12hrzfj") . flip (bech32Encode Bech32) []) hrpCaseVariants
describe "bech32 encoding/decoding" $ do
it "should not encode long data string" $
assert . isNothing $
bech32Encode Bech32 "bc" (replicate 82 (word5 (1 :: Word8)))
it "should not encode bad version number" $
assert $
isNothing $
segwitEncode "bc" 17 []
it "should not encode invalid length for version 0" $
assert $
isNothing $
segwitEncode "bc" 0 (replicate 30 1)
it "should relax length restrictions for versions other than 0" $
assert $
isJust $
segwitEncode "bc" 1 (replicate 30 1)
it "should not encode another long data string" $
assert $
isNothing $
segwitEncode "bc" 1 (replicate 41 1)
it "should not encode empty human readable part" $
assert $
isNothing $
bech32Encode Bech32 "" []
it "should not decode empty human-readable part" $
assert $
isNothing $
bech32Decode "10a06t8"
it "human-readable part should be case-insensitive" $
bech32Encode Bech32 "HRP" [] `shouldBe` bech32Encode Bech32 "hrp" []
testValidChecksum :: Bech32Encoding -> Bech32 -> Assertion
testValidChecksum enc checksum = case bech32Decode checksum of
Nothing -> assertFailure (show checksum)
Just (enc', resultHRP, resultData) -> do
assertEqual (show checksum ++ " encoding incorrect") enc enc'
-- test that a corrupted checksum fails decoding.
let (hrp, rest) = T.breakOnEnd "1" checksum
Just (first, rest') = uncons rest
checksumCorrupted = (hrp `snoc` chr (ord first `xor` 1)) `append` rest'
assertBool (show checksum ++ " corrupted") $
isNothing (bech32Decode checksumCorrupted)
-- test that re-encoding the decoded checksum results in the same checksum.
let checksumEncoded = bech32Encode enc' resultHRP resultData
expectedChecksum = Just $ T.toLower checksum
assertEqual
(show checksum ++ " re-encode")
expectedChecksum
checksumEncoded
Nothing -> assertFailure (show checksum)
Just (enc', resultHRP, resultData) -> do
assertEqual (show checksum ++ " encoding incorrect") enc enc'
-- test that a corrupted checksum fails decoding.
let (hrp, rest) = Text.breakOnEnd "1" checksum
Just (first, rest') = uncons rest
checksumCorrupted = (hrp `snoc` chr (ord first `xor` 1)) `append` rest'
assertBool (show checksum ++ " corrupted") $
isNothing (bech32Decode checksumCorrupted)
-- test that re-encoding the decoded checksum results in the same checksum.
let checksumEncoded = bech32Encode enc' resultHRP resultData
expectedChecksum = Just $ Text.toLower checksum
assertEqual
(show checksum ++ " re-encode")
expectedChecksum
checksumEncoded
testInvalidChecksum :: Bech32 -> Assertion
testInvalidChecksum checksum =
assertBool (show checksum) (isNothing $ bech32Decode checksum)
assertBool (show checksum) (isNothing $ bech32Decode checksum)
testValidAddress :: (Text, Text) -> Assertion
testValidAddress (address, hexscript) = do
let address' = T.toLower address
hrp = T.take 2 address'
case segwitDecode hrp address of
Nothing ->
assertFailure (T.unpack address <> ": decode failed")
Just (witver, witprog) -> do
assertEqual
(show address)
(decodeHex hexscript)
(Just $ segwitScriptPubkey witver witprog)
assertEqual
(show address)
(Just address')
(segwitEncode hrp witver witprog)
let address' = Text.toLower address
hrp = Text.take 2 address'
case segwitDecode hrp address of
Nothing ->
assertFailure (Text.unpack address <> ": decode failed")
Just (witver, witprog) -> do
assertEqual
(show address)
(decodeHex hexscript)
(Just $ segwitScriptPubkey witver witprog)
assertEqual
(show address)
(Just address')
(segwitEncode hrp witver witprog)
testInvalidAddress :: Text -> Assertion
testInvalidAddress address = do
assertBool (show address) (isNothing $ segwitDecode "bc" address)
assertBool (show address) (isNothing $ segwitDecode "tb" address)
assertBool (show address) (isNothing $ segwitDecode "bc" address)
assertBool (show address) (isNothing $ segwitDecode "tb" address)
segwitScriptPubkey :: Word8 -> [Word8] -> ByteString
segwitScriptPubkey witver witprog =
B.pack $ witver' : fromIntegral (length witprog) : witprog
ByteString.pack $ witver' : fromIntegral (length witprog) : witprog
where
witver' = if witver == 0 then 0 else witver + 0x50
validChecksums :: [(Bech32Encoding, Text)]
validChecksums =
[
( Bech32
, "A12UEL5L"
)
,
( Bech32
, "an83characterlonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1tt5tgs"
)
,
( Bech32
, "abcdef1qpzry9x8gf2tvdw0s3jn54khce6mua7lmqqqxw"
)
,
( Bech32
, "11qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqc8247j"
)
,
( Bech32
, "split1checkupstagehandshakeupstreamerranterredcaperred2y9e3w"
)
,
( Bech32m
, "A1LQFN3A"
)
,
( Bech32m
, "a1lqfn3a"
)
,
( Bech32m
, "an83characterlonghumanreadablepartthatcontainsthetheexcludedcharactersbioandnumber11sg7hg6"
)
,
( Bech32m
, "abcdef1l7aum6echk45nj3s0wdvt2fg8x9yrzpqzd3ryx"
)
,
( Bech32m
, "11llllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllludsr8"
)
,
( Bech32m
, "split1checkupstagehandshakeupstreamerranterredcaperredlc445v"
)
,
( Bech32m
, "?1v759aa"
)
]
[ ( Bech32,
"A12UEL5L"
),
( Bech32,
"an83characterlonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1tt5tgs"
),
( Bech32,
"abcdef1qpzry9x8gf2tvdw0s3jn54khce6mua7lmqqqxw"
),
( Bech32,
"11qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqc8247j"
),
( Bech32,
"split1checkupstagehandshakeupstreamerranterredcaperred2y9e3w"
),
( Bech32m,
"A1LQFN3A"
),
( Bech32m,
"a1lqfn3a"
),
( Bech32m,
"an83characterlonghumanreadablepartthatcontainsthetheexcludedcharactersbioandnumber11sg7hg6"
),
( Bech32m,
"abcdef1l7aum6echk45nj3s0wdvt2fg8x9yrzpqzd3ryx"
),
( Bech32m,
"11llllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllludsr8"
),
( Bech32m,
"split1checkupstagehandshakeupstreamerranterredcaperredlc445v"
),
( Bech32m,
"?1v759aa"
)
]
invalidChecksums :: [Text]
invalidChecksums =
[ " 1nwldj5"
, "\DEL1axkwrx"
, "an84characterslonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1569pvx"
, "pzry9x0s0muk"
, "1pzry9x0s0muk"
, "x1b4n0q5v"
, "li1dgmt3"
, "de1lg7wt\xFF"
]
[ " 1nwldj5",
"\DEL1axkwrx",
"an84characterslonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1569pvx",
"pzry9x0s0muk",
"1pzry9x0s0muk",
"x1b4n0q5v",
"li1dgmt3",
"de1lg7wt\xFF"
]
validAddresses :: [(Text, Text)]
validAddresses =
[
( "BC1QW508D6QEJXTDG4Y5R3ZARVARY0C5XW7KV8F3T4"
, "0014751e76e8199196d454941c45d1b3a323f1433bd6"
)
,
( "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sl5k7"
, "00201863143c14c5166804bd19203356da136c985678cd4d27a1b8c6329604903262"
)
,
( "tb1qqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesrxh6hy"
, "0020000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433"
)
,
( "BC1QW508D6QEJXTDG4Y5R3ZARVARY0C5XW7KV8F3T4"
, "0014751e76e8199196d454941c45d1b3a323f1433bd6"
)
,
( "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sl5k7"
, "00201863143c14c5166804bd19203356da136c985678cd4d27a1b8c6329604903262"
)
,
( "bc1pw508d6qejxtdg4y5r3zarvary0c5xw7kw508d6qejxtdg4y5r3zarvary0c5xw7kt5nd6y"
, "5128751e76e8199196d454941c45d1b3a323f1433bd6751e76e8199196d454941c45d1b3a323f1433bd6"
)
,
( "BC1SW50QGDZ25J"
, "6002751e"
)
,
( "bc1zw508d6qejxtdg4y5r3zarvaryvaxxpcs"
, "5210751e76e8199196d454941c45d1b3a323"
)
,
( "tb1qqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesrxh6hy"
, "0020000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433"
)
,
( "tb1pqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesf3hn0c"
, "5120000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433"
)
,
( "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqzk5jj0"
, "512079be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798"
)
]
[ ( "BC1QW508D6QEJXTDG4Y5R3ZARVARY0C5XW7KV8F3T4",
"0014751e76e8199196d454941c45d1b3a323f1433bd6"
),
( "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sl5k7",
"00201863143c14c5166804bd19203356da136c985678cd4d27a1b8c6329604903262"
),
( "tb1qqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesrxh6hy",
"0020000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433"
),
( "BC1QW508D6QEJXTDG4Y5R3ZARVARY0C5XW7KV8F3T4",
"0014751e76e8199196d454941c45d1b3a323f1433bd6"
),
( "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sl5k7",
"00201863143c14c5166804bd19203356da136c985678cd4d27a1b8c6329604903262"
),
( "bc1pw508d6qejxtdg4y5r3zarvary0c5xw7kw508d6qejxtdg4y5r3zarvary0c5xw7kt5nd6y",
"5128751e76e8199196d454941c45d1b3a323f1433bd6751e76e8199196d454941c45d1b3a323f1433bd6"
),
( "BC1SW50QGDZ25J",
"6002751e"
),
( "bc1zw508d6qejxtdg4y5r3zarvaryvaxxpcs",
"5210751e76e8199196d454941c45d1b3a323"
),
( "tb1qqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesrxh6hy",
"0020000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433"
),
( "tb1pqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesf3hn0c",
"5120000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433"
),
( "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqzk5jj0",
"512079be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798"
)
]
invalidAddresses :: [Text]
invalidAddresses =
[ "tc1qw508d6qejxtdg4y5r3zarvary0c5xw7kg3g4ty"
, "bc1qw508d6qejxtdg4y5r3zarvary0c5xw7kv8f3t5"
, "BC13W508D6QEJXTDG4Y5R3ZARVARY0C5XW7KN40WF2"
, "bc1rw5uspcuh"
, "bc10w508d6qejxtdg4y5r3zarvary0c5xw7kw508d6qejxtdg4y5r3zarvary0c5xw7kw5rljs90"
, "BC1QR508D6QEJXTDG4Y5R3ZARVARYV98GJ9P"
, "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sL5k7"
, "bc1zw508d6qejxtdg4y5r3zarvaryvqyzf3du"
, "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3pjxtptv"
, "bc1gmk9yu"
, "tc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq5zuyut"
, "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqh2y7hd"
, "tb1z0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqglt7rf"
, "BC1S0XLXVLHEMJA6C4DQV22UAPCTQUPFHLXM9H8Z3K2E72Q4K9HCZ7VQ54WELL"
, "bc1qw508d6qejxtdg4y5r3zarvary0c5xw7kemeawh"
, "tb1q0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq24jc47"
, "bc1p38j9r5y49hruaue7wxjce0updqjuyyx0kh56v8s25huc6995vvpql3jow4"
, "BC130XLXVLHEMJA6C4DQV22UAPCTQUPFHLXM9H8Z3K2E72Q4K9HCZ7VQ7ZWS8R"
, "bc1pw5dgrnzv"
, "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7v8n0nx0muaewav253zgeav"
, "tb1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq47Zagq"
, "bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7v07qwwzcrf"
, "tb1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vpggkg4j"
]
[ "tc1qw508d6qejxtdg4y5r3zarvary0c5xw7kg3g4ty",
"bc1qw508d6qejxtdg4y5r3zarvary0c5xw7kv8f3t5",
"BC13W508D6QEJXTDG4Y5R3ZARVARY0C5XW7KN40WF2",
"bc1rw5uspcuh",
"bc10w508d6qejxtdg4y5r3zarvary0c5xw7kw508d6qejxtdg4y5r3zarvary0c5xw7kw5rljs90",
"BC1QR508D6QEJXTDG4Y5R3ZARVARYV98GJ9P",
"tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sL5k7",
"bc1zw508d6qejxtdg4y5r3zarvaryvqyzf3du",
"tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3pjxtptv",
"bc1gmk9yu",
"tc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq5zuyut",
"bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqh2y7hd",
"tb1z0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vqglt7rf",
"BC1S0XLXVLHEMJA6C4DQV22UAPCTQUPFHLXM9H8Z3K2E72Q4K9HCZ7VQ54WELL",
"bc1qw508d6qejxtdg4y5r3zarvary0c5xw7kemeawh",
"tb1q0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq24jc47",
"bc1p38j9r5y49hruaue7wxjce0updqjuyyx0kh56v8s25huc6995vvpql3jow4",
"BC130XLXVLHEMJA6C4DQV22UAPCTQUPFHLXM9H8Z3K2E72Q4K9HCZ7VQ7ZWS8R",
"bc1pw5dgrnzv",
"bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7v8n0nx0muaewav253zgeav",
"tb1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vq47Zagq",
"bc1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7v07qwwzcrf",
"tb1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vpggkg4j"
]
hrpCaseVariants :: [Text]
hrpCaseVariants = map T.pack hrpTestPermutations
hrpCaseVariants = map Text.pack hrpTestPermutations
hrpTestPermutations :: [String]
hrpTestPermutations = do
a <- ['t', 'T']
b <- ['e', 'E']
c <- ['s', 'S']
d <- ['t', 'T']
return [a, b, c, d]
a <- ['t', 'T']
b <- ['e', 'E']
c <- ['s', 'S']
d <- ['t', 'T']
return [a, b, c, d]

610
test/Haskoin/Address/CashAddrSpec.hs
View File

@ -1,347 +1,315 @@
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
module Haskoin.Address.CashAddrSpec (spec) where
import Control.Monad
import qualified Data.ByteString.Char8 as C
import Data.ByteString.Char8 qualified as Char8
import Data.Maybe
import Data.String.Conversions
import Data.Text (Text)
import Haskoin.Address
import Haskoin.Constants
import Haskoin.Network.Constants
import Haskoin.Util
import Test.HUnit
import Test.Hspec
spec :: Spec
spec = do
describe "cashaddr checksum test vectors" $ do
it "prefix:x64nx6hz" $ do
let mpb = cash32decode "prefix:x64nx6hz"
mpb `shouldBe` Just ("prefix", "")
it "p:gpf8m4h7" $ do
let mpb = cash32decode "p:gpf8m4h7"
mpb `shouldBe` Just ("p", "")
it "bitcoincash:qpzry9x8gf2tvdw0s3jn54khce6mua7lcw20ayyn" $ do
let mpb =
cash32decode
"bitcoincash:qpzry9x8gf2tvdw0s3jn54khce6mua7lcw20ayyn"
mpb
`shouldBe` Just
( "bitcoincash"
, "\NULD2\DC4\199BT\182\&5\207\132e:V\215\198u\190w\223"
)
it "bchtest:testnetaddress4d6njnut" $ do
let mpb = cash32decode "bchtest:testnetaddress4d6njnut"
mpb `shouldBe` Just ("bchtest", "^`\185\229}kG\152")
it "bchreg:555555555555555555555555555555555555555555555udxmlmrz" $ do
let mpb =
cash32decode
"bchreg:555555555555555555555555555555555555555555555udxmlmrz"
mpb
`shouldBe` Just
( "bchreg"
, "\165)JR\148\165)JR\148\165)JR\148\165)JR\148\165)JR\148\165)J"
)
describe "cashaddr to base58 translation test vectors" $ do
it "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu" $ do
let addr =
addrToText bch
=<< textToAddr btc "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu"
addr
`shouldBe` Just "bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a"
it "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR" $ do
let addr =
addrToText bch
=<< textToAddr btc "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR"
addr
`shouldBe` Just "bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy"
it "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb" $ do
let addr =
addrToText bch
=<< textToAddr btc "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb"
addr
`shouldBe` Just "bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r"
it "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC" $ do
let addr =
addrToText bch
=<< textToAddr btc "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC"
addr
`shouldBe` Just "bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq"
it "3LDsS579y7sruadqu11beEJoTjdFiFCdX4" $ do
let addr =
addrToText bch
=<< textToAddr btc "3LDsS579y7sruadqu11beEJoTjdFiFCdX4"
addr
`shouldBe` Just "bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e"
it "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw" $ do
let addr =
addrToText bch
=<< textToAddr btc "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw"
addr
`shouldBe` Just "bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37"
describe "base58 to cashaddr translation test vectors" $ do
it "bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a" $ do
let addr =
addrToText btc
=<< textToAddr
bch
"bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a"
addr `shouldBe` Just "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu"
it "bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy" $ do
let addr =
addrToText btc
=<< textToAddr
bch
"bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy"
addr `shouldBe` Just "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR"
it "bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r" $ do
let addr =
addrToText btc
=<< textToAddr
bch
"bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r"
addr `shouldBe` Just "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb"
it "bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq" $ do
let addr =
addrToText btc
=<< textToAddr
bch
"bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq"
addr `shouldBe` Just "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC"
it "bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e" $ do
let addr =
addrToText btc
=<< textToAddr
bch
"bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e"
addr `shouldBe` Just "3LDsS579y7sruadqu11beEJoTjdFiFCdX4"
it "bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37" $ do
let addr =
addrToText btc
=<< textToAddr
bch
"bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37"
addr `shouldBe` Just "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw"
describe "cashaddr larger test vectors" $
forM_ (zip [0 ..] vectors) $ \(i, vec) ->
it ("cashaddr test vector " <> show (i :: Int)) $ testCashAddr vec
describe "cashaddr checksum test vectors" $ do
it "prefix:x64nx6hz" $ do
let mpb = cash32decode "prefix:x64nx6hz"
mpb `shouldBe` Just ("prefix", "")
it "p:gpf8m4h7" $ do
let mpb = cash32decode "p:gpf8m4h7"
mpb `shouldBe` Just ("p", "")
it "bitcoincash:qpzry9x8gf2tvdw0s3jn54khce6mua7lcw20ayyn" $ do
let mpb =
cash32decode
"bitcoincash:qpzry9x8gf2tvdw0s3jn54khce6mua7lcw20ayyn"
mpb
`shouldBe` Just
( "bitcoincash",
"\NULD2\DC4\199BT\182\&5\207\132e:V\215\198u\190w\223"
)
it "bchtest:testnetaddress4d6njnut" $ do
let mpb = cash32decode "bchtest:testnetaddress4d6njnut"
mpb `shouldBe` Just ("bchtest", "^`\185\229}kG\152")
it "bchreg:555555555555555555555555555555555555555555555udxmlmrz" $ do
let mpb =
cash32decode
"bchreg:555555555555555555555555555555555555555555555udxmlmrz"
mpb
`shouldBe` Just
( "bchreg",
"\165)JR\148\165)JR\148\165)JR\148\165)JR\148\165)JR\148\165)J"
)
describe "cashaddr to base58 translation test vectors" $ do
it "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu" $ do
let addr =
addrToText bch
=<< textToAddr btc "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu"
addr
`shouldBe` Just "bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a"
it "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR" $ do
let addr =
addrToText bch
=<< textToAddr btc "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR"
addr
`shouldBe` Just "bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy"
it "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb" $ do
let addr =
addrToText bch
=<< textToAddr btc "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb"
addr
`shouldBe` Just "bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r"
it "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC" $ do
let addr =
addrToText bch
=<< textToAddr btc "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC"
addr
`shouldBe` Just "bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq"
it "3LDsS579y7sruadqu11beEJoTjdFiFCdX4" $ do
let addr =
addrToText bch
=<< textToAddr btc "3LDsS579y7sruadqu11beEJoTjdFiFCdX4"
addr
`shouldBe` Just "bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e"
it "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw" $ do
let addr =
addrToText bch
=<< textToAddr btc "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw"
addr
`shouldBe` Just "bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37"
describe "base58 to cashaddr translation test vectors" $ do
it "bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a" $ do
let addr =
addrToText btc
=<< textToAddr
bch
"bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a"
addr `shouldBe` Just "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu"
it "bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy" $ do
let addr =
addrToText btc
=<< textToAddr
bch
"bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy"
addr `shouldBe` Just "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR"
it "bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r" $ do
let addr =
addrToText btc
=<< textToAddr
bch
"bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r"
addr `shouldBe` Just "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb"
it "bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq" $ do
let addr =
addrToText btc
=<< textToAddr
bch
"bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq"
addr `shouldBe` Just "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC"
it "bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e" $ do
let addr =
addrToText btc
=<< textToAddr
bch
"bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e"
addr `shouldBe` Just "3LDsS579y7sruadqu11beEJoTjdFiFCdX4"
it "bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37" $ do
let addr =
addrToText btc
=<< textToAddr
bch
"bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37"
addr `shouldBe` Just "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw"
describe "cashaddr larger test vectors" $
forM_ (zip [0 ..] vectors) $ \(i, vec) ->
it ("cashaddr test vector " <> show (i :: Int)) $ testCashAddr vec
{- Various utilities -}
testCashAddr :: (Int, CashVersion, Cash32, Text) -> Assertion
testCashAddr (len, typ, addr, hex) = do
let mbs = decodeHex hex
assertBool "Could not decode hex payload from test vector" (isJust mbs)
let mlow = cash32decode addr
assertBool "Could not decode low level address" (isJust mlow)
let Just (_, lbs) = mlow
assertEqual "Low-level payload size incorrect" len (C.length lbs - 1)
assertEqual "Low-level payload doesn't match" bs (C.tail lbs)
let mdec = cash32decodeType addr
assertBool ("Could not decode test address: " <> cs addr) (isJust mdec)
assertEqual "Length doesn't match" len (C.length pay)
assertEqual "Version doesn't match" typ ver
assertEqual "Payload doesn't match" bs pay
let mbs = decodeHex hex
assertBool "Could not decode hex payload from test vector" (isJust mbs)
let mlow = cash32decode addr
assertBool "Could not decode low level address" (isJust mlow)
let Just (_, lbs) = mlow
assertEqual "Low-level payload size incorrect" len (Char8.length lbs - 1)
assertEqual "Low-level payload doesn't match" bs (Char8.tail lbs)
let mdec = cash32decodeType addr
assertBool ("Could not decode test address: " <> cs addr) (isJust mdec)
assertEqual "Length doesn't match" len (Char8.length pay)
assertEqual "Version doesn't match" typ ver
assertEqual "Payload doesn't match" bs pay
where
Just bs = decodeHex hex
Just (_, ver, pay) = cash32decodeType addr
{- | All vectors starting with @pref@ had the wrong version in the spec
document.
-}
-- | All vectors starting with @pref@ had the wrong version in the spec
-- document.
vectors :: [(Int, CashVersion, Text, Text)]
vectors =
[
( 20
, 0
, "bitcoincash:qr6m7j9njldwwzlg9v7v53unlr4jkmx6eylep8ekg2"
, "F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9"
)
,
( 20
, 1
, "bchtest:pr6m7j9njldwwzlg9v7v53unlr4jkmx6eyvwc0uz5t"
, "F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9"
)
,
( 20
, 1
, "pref:pr6m7j9njldwwzlg9v7v53unlr4jkmx6ey65nvtks5"
, "F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9"
)
,
( 20
, 15
, "prefix:0r6m7j9njldwwzlg9v7v53unlr4jkmx6ey3qnjwsrf"
, "F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9"
)
,
( 24
, 0
, "bitcoincash:q9adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2ws4mr9g0"
, "7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA"
)
,
( 24
, 1
, "bchtest:p9adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2u94tsynr"
, "7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA"
)
,
( 24
, 1
, "pref:p9adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2khlwwk5v"
, "7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA"
)
,
( 24
, 15
, "prefix:09adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2p29kc2lp"
, "7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA"
)
,
( 28
, 0
, "bitcoincash:qgagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkcw59jxxuz"
, "3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B"
)
,
( 28
, 1
, "bchtest:pgagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkcvs7md7wt"
, "3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B"
)
,
( 28
, 1
, "pref:pgagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkcrsr6gzkn"
, "3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B"
)
,
( 28
, 15
, "prefix:0gagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkc5djw8s9g"
, "3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B"
)
,
( 32
, 0
, "bitcoincash:qvch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxq5nlegake"
, "3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060"
)
,
( 32
, 1
, "bchtest:pvch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxq7fqng6m6"
, "3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060"
)
,
( 32
, 1
, "pref:pvch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxq4k9m7qf9"
, "3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060"
)
,
( 32
, 15
, "prefix:0vch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxqsh6jgp6w"
, "3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060"
)
,
( 40
, 0
, "bitcoincash:qnq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklv39gr3uvz"
, "C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB"
)
,
( 40
, 1
, "bchtest:pnq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklvmgm6ynej"
, "C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB"
)
,
( 40
, 1
, "pref:pnq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklv0vx5z0w3"
, "C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB"
)
,
( 40
, 15
, "prefix:0nq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklvwsvctzqy"
, "C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB"
)
,
( 48
, 0
, "bitcoincash:qh3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqex2w82sl"
, "E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C"
)
,
( 48
, 1
, "bchtest:ph3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqnzf7mt6x"
, "E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C"
)
,
( 48
, 1
, "pref:ph3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqjntdfcwg"
, "E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C"
)
,
( 48
, 15
, "prefix:0h3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqakcssnmn"
, "E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C"
)
,
( 56
, 0
, "bitcoincash:qmvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqscw8jd03f"
, "D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041"
)
,
( 56
, 1
, "bchtest:pmvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqs6kgdsg2g"
, "D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041"
)
,
( 56
, 1
, "pref:pmvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqsammyqffl"
, "D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041"
)
,
( 56
, 15
, "prefix:0mvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqsgjrqpnw8"
, "D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041"
)
,
( 64
, 0
, "bitcoincash:qlg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96mtky5sv5w"
, "D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B"
)
,
( 64
, 1
, "bchtest:plg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96mc773cwez"
, "D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B"
)
,
( 64
, 1
, "pref:plg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96mg7pj3lh8"
, "D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B"
)
,
( 64
, 15
, "prefix:0lg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96ms92w6845"
, "D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B"
)
]
[ ( 20,
0,
"bitcoincash:qr6m7j9njldwwzlg9v7v53unlr4jkmx6eylep8ekg2",
"F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9"
),
( 20,
1,
"bchtest:pr6m7j9njldwwzlg9v7v53unlr4jkmx6eyvwc0uz5t",
"F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9"
),
( 20,
1,
"pref:pr6m7j9njldwwzlg9v7v53unlr4jkmx6ey65nvtks5",
"F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9"
),
( 20,
15,
"prefix:0r6m7j9njldwwzlg9v7v53unlr4jkmx6ey3qnjwsrf",
"F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9"
),
( 24,
0,
"bitcoincash:q9adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2ws4mr9g0",
"7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA"
),
( 24,
1,
"bchtest:p9adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2u94tsynr",
"7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA"
),
( 24,
1,
"pref:p9adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2khlwwk5v",
"7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA"
),
( 24,
15,
"prefix:09adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2p29kc2lp",
"7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA"
),
( 28,
0,
"bitcoincash:qgagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkcw59jxxuz",
"3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B"
),
( 28,
1,
"bchtest:pgagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkcvs7md7wt",
"3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B"
),
( 28,
1,
"pref:pgagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkcrsr6gzkn",
"3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B"
),
( 28,
15,
"prefix:0gagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkc5djw8s9g",
"3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B"
),
( 32,
0,
"bitcoincash:qvch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxq5nlegake",
"3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060"
),
( 32,
1,
"bchtest:pvch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxq7fqng6m6",
"3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060"
),
( 32,
1,
"pref:pvch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxq4k9m7qf9",
"3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060"
),
( 32,
15,
"prefix:0vch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxqsh6jgp6w",
"3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060"
),
( 40,
0,
"bitcoincash:qnq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklv39gr3uvz",
"C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB"
),
( 40,
1,
"bchtest:pnq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklvmgm6ynej",
"C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB"
),
( 40,
1,
"pref:pnq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklv0vx5z0w3",
"C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB"
),
( 40,
15,
"prefix:0nq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklvwsvctzqy",
"C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB"
),
( 48,
0,
"bitcoincash:qh3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqex2w82sl",
"E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C"
),
( 48,
1,
"bchtest:ph3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqnzf7mt6x",
"E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C"
),
( 48,
1,
"pref:ph3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqjntdfcwg",
"E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C"
),
( 48,
15,
"prefix:0h3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqakcssnmn",
"E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C"
),
( 56,
0,
"bitcoincash:qmvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqscw8jd03f",
"D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041"
),
( 56,
1,
"bchtest:pmvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqs6kgdsg2g",
"D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041"
),
( 56,
1,
"pref:pmvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqsammyqffl",
"D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041"
),
( 56,
15,
"prefix:0mvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqsgjrqpnw8",
"D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041"
),
( 64,
0,
"bitcoincash:qlg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96mtky5sv5w",
"D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B"
),
( 64,
1,
"bchtest:plg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96mc773cwez",
"D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B"
),
( 64,
1,
"pref:plg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96mg7pj3lh8",
"D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B"
),
( 64,
15,
"prefix:0lg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96ms92w6845",
"D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B"
)
]

265
test/Haskoin/AddressSpec.hs
View File

@ -1,16 +1,17 @@
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
module Haskoin.AddressSpec (spec) where
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS (append, empty, pack)
import Data.ByteString qualified as B
import Data.Maybe (fromJust, isJust)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text qualified as T
import Haskoin.Address
import Haskoin.Constants
import Haskoin.Data
import Haskoin.Keys
import Haskoin.Crypto
import Haskoin.Network.Constants
import Haskoin.Network.Data
import Haskoin.Util
import Haskoin.Util.Arbitrary
import Test.HUnit
@ -26,178 +27,172 @@ readVals = [ReadBox arbitraryAddressAll]
netVals :: [NetBox]
netVals =
[NetBox (addrToJSON, addrToEncoding, addrFromJSON, arbitraryNetAddress)]
[NetBox (marshalValue, marshalEncoding, unmarshalValue, arbitraryNetAddress)]
spec :: Spec
spec = do
testIdentity serialVals readVals [] netVals
describe "Address properties" $ do
prop "encodes and decodes base58 bytestring" $
forAll arbitraryBS $ \bs ->
decodeBase58 (encodeBase58 bs) == Just bs
prop "encodes and decodes base58 bytestring with checksum" $
forAll arbitraryBS $ \bs ->
decodeBase58Check (encodeBase58Check bs) == Just bs
prop "textToAddr . addrToText identity" $
forAll arbitraryNetAddress $ \(net, a) ->
(textToAddr net =<< addrToText net a) == Just a
prop "outputAddress . addressToOutput identity" $
forAll arbitraryAddress $ \a ->
outputAddress (addressToOutput a) == Just a
describe "Address vectors" $ do
it "Passes Base58 vectors 1" $
mapM_ testVector vectors
it "Passes Base58 vectors 2" $
mapM_ testBase58Vector base58Vectors
it "Passes Base58 invalid decoding vectors" $
mapM_ testBase58InvalidVector base58InvalidVectors
it "Passes Base58Check invalid decoding vectors" $
mapM_ testBase58ChkInvalidVector base58ChkInvalidVectors
it "Passes addresses witness p2sh(pwpkh) vectors" $
mapM_ testCompatWitnessVector compatWitnessVectors
spec = prepareContext $ \ctx -> do
testIdentity serialVals readVals [] netVals
describe "Address properties" $ do
prop "encodes and decodes base58 bytestring" $
forAll arbitraryBS $ \bs ->
decodeBase58 (encodeBase58 bs) == Just bs
prop "encodes and decodes base58 bytestring with checksum" $
forAll arbitraryBS $ \bs ->
decodeBase58Check (encodeBase58Check bs) == Just bs
prop "textToAddr . addrToText identity" $
forAll arbitraryNetAddress $ \(net, a) ->
(textToAddr net =<< addrToText net a) == Just a
prop "outputAddress . addressToOutput identity" $
forAll arbitraryAddress $ \a ->
outputAddress ctx (addressToOutput a) == Just a
describe "Address vectors" $ do
it "Passes Base58 vectors 1" $
mapM_ testVector vectors
it "Passes Base58 vectors 2" $
mapM_ testBase58Vector base58Vectors
it "Passes Base58 invalid decoding vectors" $
mapM_ testBase58InvalidVector base58InvalidVectors
it "Passes Base58Check invalid decoding vectors" $
mapM_ testBase58ChkInvalidVector base58ChkInvalidVectors
it "Passes addresses witness p2sh(pwpkh) vectors" $
mapM_ (testCompatWitnessVector ctx) compatWitnessVectors
testVector :: (ByteString, Text, Text) -> Assertion
testVector (bs, e, chk) = do
assertEqual "encodeBase58" e b58
assertEqual "encodeBase58Check" chk b58Chk
assertEqual "decodeBase58" (Just bs) (decodeBase58 b58)
assertEqual "decodeBase58Check" (Just bs) (decodeBase58Check b58Chk)
assertEqual "encodeBase58" e b58
assertEqual "encodeBase58Check" chk b58Chk
assertEqual "decodeBase58" (Just bs) (decodeBase58 b58)
assertEqual "decodeBase58Check" (Just bs) (decodeBase58Check b58Chk)
where
b58 = encodeBase58 bs
b58Chk = encodeBase58Check bs
vectors :: [(ByteString, Text, Text)]
vectors =
[ (BS.empty, "", "3QJmnh")
, (BS.pack [0], "1", "1Wh4bh")
, (BS.pack [0, 0, 0, 0], "1111", "11114bdQda")
, (BS.pack [0, 0, 1, 0, 0], "11LUw", "113CUwsFVuo")
, (BS.pack [255], "5Q", "VrZDWwe")
,
( BS.pack [0, 0, 0, 0] `BS.append` BS.pack [1 .. 255]
, "1111cWB5HCBdLjAuqGGReWE3R3CguuwSjw6RHn39s2yuDRTS5N\
\sBgNiFpWgAnEx6VQi8csexkgYw3mdYrMHr8x9i7aEwP8kZ7vcc\
\XWqKDvGv3u1GxFKPuAkn8JCPPGDMf3vMMnbzm6Nh9zh1gcNsMv\
\H3ZNLmP5fSG6DGbbi2tuwMWPthr4boWwCxf7ewSgNQeacyozhK\
\DDQQ1qL5fQFUW52QKUZDZ5fw3KXNQJMcNTcaB723LchjeKun7M\
\uGW5qyCBZYzA1KjofN1gYBV3NqyhQJ3Ns746GNuf9N2pQPmHz4\
\xpnSrrfCvy6TVVz5d4PdrjeshsWQwpZsZGzvbdAdN8MKV5QsBDY"
, "111151KWPPBRzdWPr1ASeu172gVgLf1YfUp6VJyk6K9t4cLqYt\
\FHcMa2iX8S3NJEprUcW7W5LvaPRpz7UG7puBj5STE3nKhCGt5e\
\ckYq7mMn5nT7oTTic2BAX6zDdqrmGCnkszQkzkz8e5QLGDjf7K\
\eQgtEDm4UER6DMSdBjFQVa6cHrrJn9myVyyhUrsVnfUk2WmNFZ\
\vkWv3Tnvzo2cJ1xW62XDfUgYz1pd97eUGGPuXvDFfLsBVd1dfd\
\UhPwxW7pMPgdWHTmg5uqKGFF6vE4xXpAqZTbTxRZjCDdTn68c2\
\wrcxApm8hq3JX65Hix7VtcD13FF8b7BzBtwjXq1ze6NMjKgUcq\
\pJTN9vt"
)
]
[ (B.empty, "", "3QJmnh"),
(B.pack [0], "1", "1Wh4bh"),
(B.pack [0, 0, 0, 0], "1111", "11114bdQda"),
(B.pack [0, 0, 1, 0, 0], "11LUw", "113CUwsFVuo"),
(B.pack [255], "5Q", "VrZDWwe"),
( B.pack [0, 0, 0, 0] `B.append` B.pack [1 .. 255],
"1111cWB5HCBdLjAuqGGReWE3R3CguuwSjw6RHn39s2yuDRTS5N\
\sBgNiFpWgAnEx6VQi8csexkgYw3mdYrMHr8x9i7aEwP8kZ7vcc\
\XWqKDvGv3u1GxFKPuAkn8JCPPGDMf3vMMnbzm6Nh9zh1gcNsMv\
\H3ZNLmP5fSG6DGbbi2tuwMWPthr4boWwCxf7ewSgNQeacyozhK\
\DDQQ1qL5fQFUW52QKUZDZ5fw3KXNQJMcNTcaB723LchjeKun7M\
\uGW5qyCBZYzA1KjofN1gYBV3NqyhQJ3Ns746GNuf9N2pQPmHz4\
\xpnSrrfCvy6TVVz5d4PdrjeshsWQwpZsZGzvbdAdN8MKV5QsBDY",
"111151KWPPBRzdWPr1ASeu172gVgLf1YfUp6VJyk6K9t4cLqYt\
\FHcMa2iX8S3NJEprUcW7W5LvaPRpz7UG7puBj5STE3nKhCGt5e\
\ckYq7mMn5nT7oTTic2BAX6zDdqrmGCnkszQkzkz8e5QLGDjf7K\
\eQgtEDm4UER6DMSdBjFQVa6cHrrJn9myVyyhUrsVnfUk2WmNFZ\
\vkWv3Tnvzo2cJ1xW62XDfUgYz1pd97eUGGPuXvDFfLsBVd1dfd\
\UhPwxW7pMPgdWHTmg5uqKGFF6vE4xXpAqZTbTxRZjCDdTn68c2\
\wrcxApm8hq3JX65Hix7VtcD13FF8b7BzBtwjXq1ze6NMjKgUcq\
\pJTN9vt"
)
]
-- Test vectors from:
-- https://github.com/bitcoin/bitcoin/blob/master/src/test/data/base58_encode_decode.json
testBase58Vector :: (Text, Text) -> Assertion
testBase58Vector (a, b) = do
assertEqual "encodeBase58 match" b (encodeBase58 bsA)
assertEqual "decodeBase58 match" a (encodeHex bsB)
assertEqual "bytestring match" bsA bsB
assertEqual "encodeBase58 match" b (encodeBase58 bsA)
assertEqual "decodeBase58 match" a (encodeHex bsB)
assertEqual "bytestring match" bsA bsB
where
bsA = fromJust $ decodeHex a
bsB = fromJust $ decodeBase58 b
base58Vectors :: [(Text, Text)]
base58Vectors =
[ ("", "")
, ("61", "2g")
, ("626262", "a3gV")
, ("636363", "aPEr")
,
( "73696d706c792061206c6f6e6720737472696e67"
, "2cFupjhnEsSn59qHXstmK2ffpLv2"
)
,
( "00eb15231dfceb60925886b67d065299925915aeb172c06647"
, "1NS17iag9jJgTHD1VXjvLCEnZuQ3rJDE9L"
)
, ("516b6fcd0f", "ABnLTmg")
, ("bf4f89001e670274dd", "3SEo3LWLoPntC")
, ("572e4794", "3EFU7m")
, ("ecac89cad93923c02321", "EJDM8drfXA6uyA")
, ("10c8511e", "Rt5zm")
, ("00000000000000000000", "1111111111")
,
( "000111d38e5fc9071ffcd20b4a763cc9ae4f252bb4e48fd66a835e252a\
\da93ff480d6dd43dc62a641155a5"
, "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
)
,
( "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c\
\1d1e1f202122232425262728292a2b2c2d2e2f30313233343536373839\
\3a3b3c3d3e3f404142434445464748494a4b4c4d4e4f50515253545556\
\5758595a5b5c5d5e5f606162636465666768696a6b6c6d6e6f70717273\
\7475767778797a7b7c7d7e7f808182838485868788898a8b8c8d8e8f90\
\9192939495969798999a9b9c9d9e9fa0a1a2a3a4a5a6a7a8a9aaabacad\
\aeafb0b1b2b3b4b5b6b7b8b9babbbcbdbebfc0c1c2c3c4c5c6c7c8c9ca\
\cbcccdcecfd0d1d2d3d4d5d6d7d8d9dadbdcdddedfe0e1e2e3e4e5e6e7\
\e8e9eaebecedeeeff0f1f2f3f4f5f6f7f8f9fafbfcfdfeff"
, "1cWB5HCBdLjAuqGGReWE3R3CguuwSjw6RHn39s2yuDRTS5NsBgNiFpWgAn\
\Ex6VQi8csexkgYw3mdYrMHr8x9i7aEwP8kZ7vccXWqKDvGv3u1GxFKPuAk\
\n8JCPPGDMf3vMMnbzm6Nh9zh1gcNsMvH3ZNLmP5fSG6DGbbi2tuwMWPthr\
\4boWwCxf7ewSgNQeacyozhKDDQQ1qL5fQFUW52QKUZDZ5fw3KXNQJMcNTc\
\aB723LchjeKun7MuGW5qyCBZYzA1KjofN1gYBV3NqyhQJ3Ns746GNuf9N2\
\pQPmHz4xpnSrrfCvy6TVVz5d4PdrjeshsWQwpZsZGzvbdAdN8MKV5QsBDY"
)
]
[ ("", ""),
("61", "2g"),
("626262", "a3gV"),
("636363", "aPEr"),
( "73696d706c792061206c6f6e6720737472696e67",
"2cFupjhnEsSn59qHXstmK2ffpLv2"
),
( "00eb15231dfceb60925886b67d065299925915aeb172c06647",
"1NS17iag9jJgTHD1VXjvLCEnZuQ3rJDE9L"
),
("516b6fcd0f", "ABnLTmg"),
("bf4f89001e670274dd", "3SEo3LWLoPntC"),
("572e4794", "3EFU7m"),
("ecac89cad93923c02321", "EJDM8drfXA6uyA"),
("10c8511e", "Rt5zm"),
("00000000000000000000", "1111111111"),
( "000111d38e5fc9071ffcd20b4a763cc9ae4f252bb4e48fd66a835e252a\
\da93ff480d6dd43dc62a641155a5",
"123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
),
( "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c\
\1d1e1f202122232425262728292a2b2c2d2e2f30313233343536373839\
\3a3b3c3d3e3f404142434445464748494a4b4c4d4e4f50515253545556\
\5758595a5b5c5d5e5f606162636465666768696a6b6c6d6e6f70717273\
\7475767778797a7b7c7d7e7f808182838485868788898a8b8c8d8e8f90\
\9192939495969798999a9b9c9d9e9fa0a1a2a3a4a5a6a7a8a9aaabacad\
\aeafb0b1b2b3b4b5b6b7b8b9babbbcbdbebfc0c1c2c3c4c5c6c7c8c9ca\
\cbcccdcecfd0d1d2d3d4d5d6d7d8d9dadbdcdddedfe0e1e2e3e4e5e6e7\
\e8e9eaebecedeeeff0f1f2f3f4f5f6f7f8f9fafbfcfdfeff",
"1cWB5HCBdLjAuqGGReWE3R3CguuwSjw6RHn39s2yuDRTS5NsBgNiFpWgAn\
\Ex6VQi8csexkgYw3mdYrMHr8x9i7aEwP8kZ7vccXWqKDvGv3u1GxFKPuAk\
\n8JCPPGDMf3vMMnbzm6Nh9zh1gcNsMvH3ZNLmP5fSG6DGbbi2tuwMWPthr\
\4boWwCxf7ewSgNQeacyozhKDDQQ1qL5fQFUW52QKUZDZ5fw3KXNQJMcNTc\
\aB723LchjeKun7MuGW5qyCBZYzA1KjofN1gYBV3NqyhQJ3Ns746GNuf9N2\
\pQPmHz4xpnSrrfCvy6TVVz5d4PdrjeshsWQwpZsZGzvbdAdN8MKV5QsBDY"
)
]
-- Test vectors from:
-- https://github.com/bitcoin/bitcoin/blob/master/src/test/base58_tests.cpp
testBase58InvalidVector :: (Text, Maybe Text) -> Assertion
testBase58InvalidVector (a, resM) =
assertEqual "decodeBase58 invalid match" resM (encodeHex <$> decodeBase58 a)
assertEqual "decodeBase58 invalid match" resM (encodeHex <$> decodeBase58 a)
base58InvalidVectors :: [(Text, Maybe Text)]
base58InvalidVectors =
[ ("invalid", Nothing)
, ("\0invalid", Nothing)
, ("good", Just "768320")
, ("bad0IOl", Nothing)
, ("goodbad0IOl", Nothing)
, ("good\0bad0IOl", Nothing)
[ ("invalid", Nothing),
("\0invalid", Nothing),
("good", Just "768320"),
("bad0IOl", Nothing),
("goodbad0IOl", Nothing),
("good\0bad0IOl", Nothing)
-- Haskoin does not remove white spaces before decoding base58 strings
-- , (" \t\n\v\f\r skip \r\f\v\n\t a", Nothing)
-- , (" \t\n\v\f\r skip \r\f\v\n\t ", Just "971a55")
]
]
testBase58ChkInvalidVector :: (Text, Maybe Text) -> Assertion
testBase58ChkInvalidVector (a, resM) =
assertEqual
"decodeBase58Check invalid match"
resM
(encodeHex <$> decodeBase58Check a)
assertEqual
"decodeBase58Check invalid match"
resM
(encodeHex <$> decodeBase58Check a)
base58ChkInvalidVectors :: [(Text, Maybe Text)]
base58ChkInvalidVectors =
[ ("3vQB7B6MrGQZaxCuFg4oh", Just "68656c6c6f20776f726c64")
, ("3vQB7B6MrGQZaxCuFg4oi", Nothing)
, ("3vQB7B6MrGQZaxCuFg4oh0IOl", Nothing)
, ("3vQB7B6MrGQZaxCuFg4oh\00IOl", Nothing)
]
[ ("3vQB7B6MrGQZaxCuFg4oh", Just "68656c6c6f20776f726c64"),
("3vQB7B6MrGQZaxCuFg4oi", Nothing),
("3vQB7B6MrGQZaxCuFg4oh0IOl", Nothing),
("3vQB7B6MrGQZaxCuFg4oh\00IOl", Nothing)
]
testCompatWitnessVector :: (Network, Text, Text) -> Assertion
testCompatWitnessVector (net, seckey, addr) = do
let seckeyM = fromWif net seckey
assertBool "decode seckey" (isJust seckeyM)
let pubkey = derivePubKeyI (fromJust seckeyM)
let addrM = addrToText btcTest (pubKeyCompatWitnessAddr pubkey)
assertBool "address can be encoded" (isJust addrM)
assertEqual "witness address matches" addr (fromJust addrM)
testCompatWitnessVector :: Ctx -> (Network, Text, Text) -> Assertion
testCompatWitnessVector ctx (net, seckey, addr) = do
let seckeyM = fromWif net seckey
assertBool "decode seckey" (isJust seckeyM)
let pubkey = derivePublicKey ctx (fromJust seckeyM)
let addrM = addrToText btcTest (pubKeyCompatWitnessAddr ctx pubkey)
assertBool "address can be encoded" (isJust addrM)
assertEqual "witness address matches" addr (fromJust addrM)
compatWitnessVectors :: [(Network, Text, Text)]
compatWitnessVectors =
[
( btcTest
, "cNUnpYpMsJXYCERYBciJnsWBpcYEFjdcbq6dxj4SskGhs7uHuJ7Q"
, "2N6PDTueBHvXzW61B4oe5SW1D3v2Z3Vpbvw"
)
]
[ ( btcTest,
"cNUnpYpMsJXYCERYBciJnsWBpcYEFjdcbq6dxj4SskGhs7uHuJ7Q",
"2N6PDTueBHvXzW61B4oe5SW1D3v2Z3Vpbvw"
)
]

645
test/Haskoin/BlockSpec.hs
View File

@ -1,8 +1,11 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
module Haskoin.BlockSpec (
spec,
) where
module Haskoin.BlockSpec
( spec,
)
where
import Control.Monad.State.Strict
import Data.Either (fromRight)
@ -12,9 +15,11 @@ import Data.String.Conversions (cs)
import Data.Text (Text)
import Data.Word (Word32)
import Haskoin.Block
import Haskoin.Constants
import Haskoin.Data
import Haskoin.Crypto
import Haskoin.Network.Constants
import Haskoin.Network.Data
import Haskoin.Transaction
import Haskoin.Util
import Haskoin.Util.Arbitrary
import Test.HUnit hiding (State)
import Test.Hspec
@ -22,36 +27,36 @@ import Test.Hspec.QuickCheck
import Test.QuickCheck
import Text.Printf (printf)
serialVals :: [SerialBox]
serialVals =
[ SerialBox (arbitraryBlock =<< arbitraryNetwork)
, SerialBox arbitraryBlockHash
, SerialBox arbitraryBlockHeader
, SerialBox arbitraryGetBlocks
, SerialBox arbitraryGetHeaders
, SerialBox arbitraryHeaders
, SerialBox arbitraryMerkleBlock
, SerialBox arbitraryBlockNode
]
serialVals :: Ctx -> [SerialBox]
serialVals ctx =
[ SerialBox (flip arbitraryBlock ctx =<< arbitraryNetwork),
SerialBox arbitraryBlockHash,
SerialBox arbitraryBlockHeader,
SerialBox arbitraryGetBlocks,
SerialBox arbitraryGetHeaders,
SerialBox arbitraryHeaders,
SerialBox arbitraryMerkleBlock,
SerialBox arbitraryBlockNode
]
readVals :: [ReadBox]
readVals =
[ ReadBox (arbitraryBlock =<< arbitraryNetwork)
, ReadBox arbitraryBlockHash
, ReadBox arbitraryBlockHeader
, ReadBox arbitraryGetBlocks
, ReadBox arbitraryGetHeaders
, ReadBox arbitraryHeaders
, ReadBox arbitraryMerkleBlock
, ReadBox arbitraryBlockNode
]
readVals :: Ctx -> [ReadBox]
readVals ctx =
[ ReadBox (flip arbitraryBlock ctx =<< arbitraryNetwork),
ReadBox arbitraryBlockHash,
ReadBox arbitraryBlockHeader,
ReadBox arbitraryGetBlocks,
ReadBox arbitraryGetHeaders,
ReadBox arbitraryHeaders,
ReadBox arbitraryMerkleBlock,
ReadBox arbitraryBlockNode
]
jsonVals :: [JsonBox]
jsonVals =
[ JsonBox (arbitraryBlock =<< arbitraryNetwork)
, JsonBox arbitraryBlockHash
, JsonBox arbitraryBlockHeader
]
jsonVals :: Ctx -> [JsonBox]
jsonVals ctx =
[ JsonBox (flip arbitraryBlock ctx =<< arbitraryNetwork),
JsonBox arbitraryBlockHash,
JsonBox arbitraryBlockHeader
]
myTime :: Timestamp
myTime = 1499083075
@ -59,66 +64,66 @@ myTime = 1499083075
withChain :: Network -> State HeaderMemory a -> a
withChain net f = evalState f (initialChain net)
chain :: BlockHeaders m => Network -> BlockHeader -> Int -> m ()
chain :: (BlockHeaders m) => Network -> BlockHeader -> Int -> m ()
chain net bh i = do
bnsE <- connectBlocks net myTime bhs
either error (const $ return ()) bnsE
bnsE <- connectBlocks net myTime bhs
either error (const $ return ()) bnsE
where
bhs = appendBlocks net 6 bh i
spec :: Spec
spec = do
testIdentity serialVals readVals jsonVals []
describe "blockchain headers" $ do
it "gets best block on bchRegTest" $
let net = bchRegTest
bb =
withChain net $ do
chain net (getGenesisHeader net) 100
getBestBlockHeader
in nodeHeight bb `shouldBe` 100
it "builds a block locator on bchRegTest" $
let net = bchRegTest
loc =
withChain net $ do
chain net (getGenesisHeader net) 100
bb <- getBestBlockHeader
blockLocatorNodes bb
heights = map nodeHeight loc
in heights `shouldBe` [100, 99 .. 90] <> [88, 84, 76, 60, 28, 0]
it "follows split chains on bchRegTest" $
let net = bchRegTest
bb = withChain net $ splitChain net >> getBestBlockHeader
in nodeHeight bb `shouldBe` 4035
describe "block hash" $ do
prop "encodes and decodes block hash" $
forAll arbitraryBlockHash $ \h ->
hexToBlockHash (blockHashToHex h) == Just h
prop "from string block hash" $
forAll arbitraryBlockHash $ \h ->
fromString (cs $ blockHashToHex h) == h
describe "merkle trees" $ do
prop "builds tree of right width at height 1" testTreeWidth
prop "builds tree of right width at height 0" testBaseWidth
prop "builds and extracts partial merkle tree" $
forAll arbitraryNetwork $ \net ->
forAll
(listOf1 ((,) <$> arbitraryTxHash <*> arbitrary))
(buildExtractTree net)
it "merkle root test vectors" $ mapM_ runMerkleVector merkleVectors
describe "compact number" $ do
it "compact number local vectors" testCompact
it "compact number imported vectors" testCompactBitcoinCore
describe "asert" $
mapM_
( \x ->
asertTests $
"test_vectors_aserti3-2d_run" ++ printf "%02d" x ++ ".txt"
)
[(1 :: Int) .. 12]
describe "helper functions" $ do
it "computes bitcoin block subsidy correctly" (testSubsidy btc)
it "computes regtest block subsidy correctly" (testSubsidy btcRegTest)
spec = prepareContext $ \ctx -> do
testIdentity (serialVals ctx) (readVals ctx) (jsonVals ctx) []
describe "blockchain headers" $ do
it "gets best block on bchRegTest" $
let net = bchRegTest
bb =
withChain net $ do
chain net net.genesisHeader 100
getBestBlockHeader
in bb.height `shouldBe` 100
it "builds a block locator on bchRegTest" $
let net = bchRegTest
loc =
withChain net $ do
chain net net.genesisHeader 100
bb <- getBestBlockHeader
blockLocatorNodes bb
heights = map (.height) loc
in heights `shouldBe` [100, 99 .. 90] <> [88, 84, 76, 60, 28, 0]
it "follows split chains on bchRegTest" $
let net = bchRegTest
bb = withChain net $ splitChain net >> getBestBlockHeader
in bb.height `shouldBe` 4035
describe "block hash" $ do
prop "encodes and decodes block hash" $
forAll arbitraryBlockHash $ \h ->
hexToBlockHash (blockHashToHex h) == Just h
prop "from string block hash" $
forAll arbitraryBlockHash $ \h ->
fromString (cs $ blockHashToHex h) == h
describe "merkle trees" $ do
prop "builds tree of right width at height 1" testTreeWidth
prop "builds tree of right width at height 0" testBaseWidth
prop "builds and extracts partial merkle tree" $
forAll arbitraryNetwork $ \net ->
forAll
(listOf1 ((,) <$> arbitraryTxHash <*> arbitrary))
(buildExtractTree net)
it "merkle root test vectors" $ mapM_ runMerkleVector merkleVectors
describe "compact number" $ do
it "compact number local vectors" testCompact
it "compact number imported vectors" testCompactBitcoinCore
describe "asert" $
mapM_
( \x ->
asertTests $
"test_vectors_aserti3-2d_run" ++ printf "%02d" x ++ ".txt"
)
[(1 :: Int) .. 12]
describe "helper functions" $ do
it "computes bitcoin block subsidy correctly" (testSubsidy btc)
it "computes regtest block subsidy correctly" (testSubsidy btcRegTest)
-- 0 → → 2015 → → → → → → → 4031
-- ↓
@ -127,40 +132,40 @@ spec = do
-- → → 2185
splitChain :: Network -> State HeaderMemory ()
splitChain net = do
start <- go 1 (getGenesisHeader net) 2015
e 2015 (head start)
tail1 <- go 2 (nodeHeader $ head start) 2016
e 4031 (head tail1)
tail2 <- go 3 (nodeHeader $ head start) 20
e 2035 (head tail2)
tail3 <- go 4 (nodeHeader $ head tail2) 2000
e 4035 (head tail3)
tail4 <- go 5 (nodeHeader $ head tail2) 150
e 2185 (head tail4)
sp1 <- splitPoint (head tail1) (head tail3)
unless (sp1 == head start) $
error $
"Split point wrong between blocks 4031 and 4035: "
++ show (nodeHeight sp1)
sp2 <- splitPoint (head tail4) (head tail3)
unless (sp2 == head tail2) $
error $
"Split point wrong between blocks 2185 and 4035: "
++ show (nodeHeight sp2)
start <- go 1 net.genesisHeader 2015
e 2015 (head start)
tail1 <- go 2 (head start).header 2016
e 4031 (head tail1)
tail2 <- go 3 (head start).header 20
e 2035 (head tail2)
tail3 <- go 4 (head tail2).header 2000
e 4035 (head tail3)
tail4 <- go 5 (head tail2).header 150
e 2185 (head tail4)
sp1 <- splitPoint (head tail1) (head tail3)
unless (sp1 == head start) $
error $
"Split point wrong between blocks 4031 and 4035: "
++ show sp1.height
sp2 <- splitPoint (head tail4) (head tail3)
unless (sp2 == head tail2) $
error $
"Split point wrong between blocks 2185 and 4035: "
++ show sp2.height
where
e n bn =
unless (nodeHeight bn == n) $
error $
"Node height "
++ show (nodeHeight bn)
++ " of first chunk should be "
++ show n
e n bn@BlockNode {} =
unless (bn.height == n) $
error $
"Node height "
++ show bn.height
++ " of first chunk should be "
++ show n
go seed start n = do
let bhs = appendBlocks net seed start n
bnE <- connectBlocks net myTime bhs
case bnE of
Right bn -> return bn
Left ex -> error ex
let bhs = appendBlocks net seed start n
bnE <- connectBlocks net myTime bhs
case bnE of
Right bn -> return bn
Left ex -> error ex
{- Merkle Trees -}
@ -172,214 +177,208 @@ testBaseWidth i = i /= 0 ==> calcTreeWidth (abs i) 0 == abs i
buildExtractTree :: Network -> [(TxHash, Bool)] -> Bool
buildExtractTree net txs =
r == buildMerkleRoot (map fst txs) && m == map fst (filter snd txs)
r == buildMerkleRoot (map fst txs) && m == map fst (filter snd txs)
where
(f, h) = buildPartialMerkle txs
(r, m) =
fromRight (error "Could not extract matches from Merkle tree") $
extractMatches net f h (length txs)
fromRight (error "Could not extract matches from Merkle tree") $
extractMatches net f h (length txs)
testCompact :: Assertion
testCompact = do
assertEqual "vector 1" 0x05123456 (encodeCompact 0x1234560000)
assertEqual "vector 2" (0x1234560000, False) (decodeCompact 0x05123456)
assertEqual "vector 3" 0x0600c0de (encodeCompact 0xc0de000000)
assertEqual "vector 4" (0xc0de000000, False) (decodeCompact 0x0600c0de)
assertEqual "vector 5" 0x05c0de00 (encodeCompact (-0x40de000000))
assertEqual "vector 6" (-0x40de000000, False) (decodeCompact 0x05c0de00)
assertEqual "vector 1" 0x05123456 (encodeCompact 0x1234560000)
assertEqual "vector 2" (0x1234560000, False) (decodeCompact 0x05123456)
assertEqual "vector 3" 0x0600c0de (encodeCompact 0xc0de000000)
assertEqual "vector 4" (0xc0de000000, False) (decodeCompact 0x0600c0de)
assertEqual "vector 5" 0x05c0de00 (encodeCompact (-0x40de000000))
assertEqual "vector 6" (-0x40de000000, False) (decodeCompact 0x05c0de00)
testCompactBitcoinCore :: Assertion
testCompactBitcoinCore = do
assertEqual "zero" (0, False) (decodeCompact 0x00000000)
assertEqual
"zero (encode · decode)"
0x00000000
(encodeCompact . fst $ decodeCompact 0x00000000)
assertEqual "rounds to zero" (0, False) (decodeCompact 0x00123456)
assertEqual "rounds to zero" (0, False) (decodeCompact 0x01003456)
assertEqual "rounds to zero" (0, False) (decodeCompact 0x02000056)
assertEqual "rounds to zero" (0, False) (decodeCompact 0x03000000)
assertEqual "rounds to zero" (0, False) (decodeCompact 0x04000000)
assertEqual "rounds to zero" (0, False) (decodeCompact 0x00923456)
assertEqual "rounds to zero" (0, False) (decodeCompact 0x01803456)
assertEqual "rounds to zero" (0, False) (decodeCompact 0x02800056)
assertEqual "rounds to zero" (0, False) (decodeCompact 0x03800000)
assertEqual "rounds to zero" (0, False) (decodeCompact 0x04800000)
assertEqual "vector 1 (decode)" (0x12, False) (decodeCompact 0x01123456)
assertEqual
"vector 1 (encode · decode)"
0x01120000
(encodeCompact . fst $ decodeCompact 0x01123456)
assertEqual "0x80 bit set" 0x02008000 (encodeCompact 0x80)
assertEqual
"vector 2 (negative) (decode)"
(-0x7e, False)
(decodeCompact 0x01fedcba)
assertEqual
"vector 2 (negative) (encode · decode)"
0x01fe0000
(encodeCompact . fst $ decodeCompact 0x01fedcba)
assertEqual "vector 3 (decode)" (0x1234, False) (decodeCompact 0x02123456)
assertEqual
"vector 3 (encode · decode)"
0x02123400
(encodeCompact . fst $ decodeCompact 0x02123456)
assertEqual "vector 4 (decode)" (0x123456, False) (decodeCompact 0x03123456)
assertEqual
"vector 4 (encode · decode)"
0x03123456
(encodeCompact . fst $ decodeCompact 0x03123456)
assertEqual
"vector 5 (decode)"
(0x12345600, False)
(decodeCompact 0x04123456)
assertEqual
"vector 5 (encode · decode)"
0x04123456
(encodeCompact . fst $ decodeCompact 0x04123456)
assertEqual
"vector 6 (decode)"
(-0x12345600, False)
(decodeCompact 0x04923456)
assertEqual
"vector 6 (encode · decode)"
0x04923456
(encodeCompact . fst $ decodeCompact 0x04923456)
assertEqual
"vector 7 (decode)"
(0x92340000, False)
(decodeCompact 0x05009234)
assertEqual
"vector 7 (encode · decode)"
0x05009234
(encodeCompact . fst $ decodeCompact 0x05009234)
assertEqual
"vector 8 (decode)"
( 0x1234560000000000000000000000000000000000000000000000000000000000
, False
)
(decodeCompact 0x20123456)
assertEqual
"vector 8 (encode · decode)"
0x20123456
(encodeCompact . fst $ decodeCompact 0x20123456)
assertBool "vector 9 (decode) (overflow)" (snd $ decodeCompact 0xff123456)
assertBool
"vector 9 (decode) (positive)"
((> 0) . fst $ decodeCompact 0xff123456)
assertEqual "zero" (0, False) (decodeCompact 0x00000000)
assertEqual
"zero (encode · decode)"
0x00000000
(encodeCompact . fst $ decodeCompact 0x00000000)
assertEqual "rounds to zero" (0, False) (decodeCompact 0x00123456)
assertEqual "rounds to zero" (0, False) (decodeCompact 0x01003456)
assertEqual "rounds to zero" (0, False) (decodeCompact 0x02000056)
assertEqual "rounds to zero" (0, False) (decodeCompact 0x03000000)
assertEqual "rounds to zero" (0, False) (decodeCompact 0x04000000)
assertEqual "rounds to zero" (0, False) (decodeCompact 0x00923456)
assertEqual "rounds to zero" (0, False) (decodeCompact 0x01803456)
assertEqual "rounds to zero" (0, False) (decodeCompact 0x02800056)
assertEqual "rounds to zero" (0, False) (decodeCompact 0x03800000)
assertEqual "rounds to zero" (0, False) (decodeCompact 0x04800000)
assertEqual "vector 1 (decode)" (0x12, False) (decodeCompact 0x01123456)
assertEqual
"vector 1 (encode · decode)"
0x01120000
(encodeCompact . fst $ decodeCompact 0x01123456)
assertEqual "0x80 bit set" 0x02008000 (encodeCompact 0x80)
assertEqual
"vector 2 (negative) (decode)"
(-0x7e, False)
(decodeCompact 0x01fedcba)
assertEqual
"vector 2 (negative) (encode · decode)"
0x01fe0000
(encodeCompact . fst $ decodeCompact 0x01fedcba)
assertEqual "vector 3 (decode)" (0x1234, False) (decodeCompact 0x02123456)
assertEqual
"vector 3 (encode · decode)"
0x02123400
(encodeCompact . fst $ decodeCompact 0x02123456)
assertEqual "vector 4 (decode)" (0x123456, False) (decodeCompact 0x03123456)
assertEqual
"vector 4 (encode · decode)"
0x03123456
(encodeCompact . fst $ decodeCompact 0x03123456)
assertEqual
"vector 5 (decode)"
(0x12345600, False)
(decodeCompact 0x04123456)
assertEqual
"vector 5 (encode · decode)"
0x04123456
(encodeCompact . fst $ decodeCompact 0x04123456)
assertEqual
"vector 6 (decode)"
(-0x12345600, False)
(decodeCompact 0x04923456)
assertEqual
"vector 6 (encode · decode)"
0x04923456
(encodeCompact . fst $ decodeCompact 0x04923456)
assertEqual
"vector 7 (decode)"
(0x92340000, False)
(decodeCompact 0x05009234)
assertEqual
"vector 7 (encode · decode)"
0x05009234
(encodeCompact . fst $ decodeCompact 0x05009234)
assertEqual
"vector 8 (decode)"
( 0x1234560000000000000000000000000000000000000000000000000000000000,
False
)
(decodeCompact 0x20123456)
assertEqual
"vector 8 (encode · decode)"
0x20123456
(encodeCompact . fst $ decodeCompact 0x20123456)
assertBool "vector 9 (decode) (overflow)" (snd $ decodeCompact 0xff123456)
assertBool
"vector 9 (decode) (positive)"
((> 0) . fst $ decodeCompact 0xff123456)
runMerkleVector :: (Text, [Text]) -> Assertion
runMerkleVector (r, hs) =
assertBool "merkle vector" $
buildMerkleRoot (map f hs) == getTxHash (f r)
assertBool "merkle vector" $
buildMerkleRoot (map f hs) == (f r).get
where
f = fromJust . hexToTxHash
merkleVectors :: [(Text, [Text])]
merkleVectors =
-- Block 000000000000cd7e8cf6510303dde76121a1a791c15dba0be4be7022b07cf9e1
[
( "fb6698ac95b754256c5e71b4fbe07638cb6ca83ee67f44e181b91727f09f4b1f"
,
[ "dd96fdcfaec994bf583af650ff6022980ee0ba1686d84d0a3a2d24eabf34bc52"
, "1bc216f786a564378710ae589916fc8e092ddfb9f24fe6c47b733550d476d5d9"
, "a1db0b0194426064b067899ff2d975fb277fd52dbb1a38370800c76dd6503d41"
, "d69f7fb0e668fbd437d1bf5211cc34d7eb8746f50cfddf705fe10bc2f8f7035f"
, "5b4057cd80be7df5ed2ac42b776897ed3c26e3a01e4072075b8129c587094ef6"
, "ed6dabcfba0ef43c50d89a8a0e4b236b1bc6585d4c3bbf49728b55f44312d6bc"
, "056aaa9a3c635909c794e9b0acc7dccb0456c59a84c6b08417335bee4515e3d3"
, "05bae5f1d1c874171692e1fc06f664e63eb143d3f096601ef938e4a9012eee66"
, "b5e48e94e3f2fba197b3f591e01f47e185d7834d669529d44078e41c671aab0f"
, "3b56aeadfc0c5484fd507bc89f13f2e5f61c42e0a4ae9062eda9a9aeef7db6a4"
, "2affa187e1ebb94a2a86578b9f64951e854ff3d346fef259acfb6d0f5212e0d3"
]
)
, -- Block 00000000000007cc4b6f07bfed72bccc1ed8dd031a93969a4c22211f784457d4
-- Block 000000000000cd7e8cf6510303dde76121a1a791c15dba0be4be7022b07cf9e1
[ ( "fb6698ac95b754256c5e71b4fbe07638cb6ca83ee67f44e181b91727f09f4b1f",
[ "dd96fdcfaec994bf583af650ff6022980ee0ba1686d84d0a3a2d24eabf34bc52",
"1bc216f786a564378710ae589916fc8e092ddfb9f24fe6c47b733550d476d5d9",
"a1db0b0194426064b067899ff2d975fb277fd52dbb1a38370800c76dd6503d41",
"d69f7fb0e668fbd437d1bf5211cc34d7eb8746f50cfddf705fe10bc2f8f7035f",
"5b4057cd80be7df5ed2ac42b776897ed3c26e3a01e4072075b8129c587094ef6",
"ed6dabcfba0ef43c50d89a8a0e4b236b1bc6585d4c3bbf49728b55f44312d6bc",
"056aaa9a3c635909c794e9b0acc7dccb0456c59a84c6b08417335bee4515e3d3",
"05bae5f1d1c874171692e1fc06f664e63eb143d3f096601ef938e4a9012eee66",
"b5e48e94e3f2fba197b3f591e01f47e185d7834d669529d44078e41c671aab0f",
"3b56aeadfc0c5484fd507bc89f13f2e5f61c42e0a4ae9062eda9a9aeef7db6a4",
"2affa187e1ebb94a2a86578b9f64951e854ff3d346fef259acfb6d0f5212e0d3"
]
),
-- Block 00000000000007cc4b6f07bfed72bccc1ed8dd031a93969a4c22211f784457d4
( "886fea311d2dc64c315519f2d647e43998d780d2170f77e53dc0d85bf2ee680c"
,
[ "c9c9e5211512629fd111cc071d745b8c79bf486b4ea95489eb5de08b5d786b8e"
, "20beb0ee30dfd323ade790ce9a46ae7a174f9ea44ce22a17c4d4eb23b7016f51"
, "d4cb7dd741e78a8f57e12f6c8ddb0361ff2a5bf9365bd7d7df761060847daf9a"
, "ddbfa6fdd29d4b47aeaadf82a4bf0a93d58cd7d8401fabf860a1ae8eeb51f42e"
, "9d82bafe44abee248b968c86f165051c8413482c232659795335c52922dab471"
, "86035372d31b53efd848cea7231aa9738c209aff64d3c59b1619341afb5b6ba3"
, "11e7a7393d9658813dfaebc04fa6d4b73bac8d641bffa7067da879523d43d030"
, "2f676b9aa5bc0ebf3395032c84c466e40cac29f80434cd1138e31c2d0fcc5c13"
, "37567d559fbfae07fda9a90de0ce30b202128bc8ebdfef5ad2b53e865a3478c2"
, "0b8e6c1200c454361e94e261738429e9c9b8dcffd85ec8511bbf5dc7e2e0ada8"
]
)
, -- Block 00000000839a8e6886ab5951d76f411475428afc90947ee320161bbf18eb6048
( "886fea311d2dc64c315519f2d647e43998d780d2170f77e53dc0d85bf2ee680c",
[ "c9c9e5211512629fd111cc071d745b8c79bf486b4ea95489eb5de08b5d786b8e",
"20beb0ee30dfd323ade790ce9a46ae7a174f9ea44ce22a17c4d4eb23b7016f51",
"d4cb7dd741e78a8f57e12f6c8ddb0361ff2a5bf9365bd7d7df761060847daf9a",
"ddbfa6fdd29d4b47aeaadf82a4bf0a93d58cd7d8401fabf860a1ae8eeb51f42e",
"9d82bafe44abee248b968c86f165051c8413482c232659795335c52922dab471",
"86035372d31b53efd848cea7231aa9738c209aff64d3c59b1619341afb5b6ba3",
"11e7a7393d9658813dfaebc04fa6d4b73bac8d641bffa7067da879523d43d030",
"2f676b9aa5bc0ebf3395032c84c466e40cac29f80434cd1138e31c2d0fcc5c13",
"37567d559fbfae07fda9a90de0ce30b202128bc8ebdfef5ad2b53e865a3478c2",
"0b8e6c1200c454361e94e261738429e9c9b8dcffd85ec8511bbf5dc7e2e0ada8"
]
),
-- Block 00000000839a8e6886ab5951d76f411475428afc90947ee320161bbf18eb6048
( "0e3e2357e806b6cdb1f70b54c3a3a17b6714ee1f0e68bebb44a74b1efd512098"
, ["0e3e2357e806b6cdb1f70b54c3a3a17b6714ee1f0e68bebb44a74b1efd512098"]
)
, -- Block 000000000004d160ac1f7b775d7c1823345aeadd5fcb29ca2ad2403bb7babd4c
( "0e3e2357e806b6cdb1f70b54c3a3a17b6714ee1f0e68bebb44a74b1efd512098",
["0e3e2357e806b6cdb1f70b54c3a3a17b6714ee1f0e68bebb44a74b1efd512098"]
),
-- Block 000000000004d160ac1f7b775d7c1823345aeadd5fcb29ca2ad2403bb7babd4c
( "aae018650f513fc42d55b2210ec3ceeeb194fb1261d37989de07451fc0cbac5c"
,
[ "a4454f22831acd7904a9902c5070a3ee4bf4c2b13bc6b2dc66735dd3c4414028"
, "45297f334278885108dd38a0b689ed95a4373dd3f7e4413e6aebdc2654fb771b"
]
)
, -- Block 000000000001d1b13a7e86ddb20da178f20d6da5cd037a29c2a15b8b84cc774e
( "aae018650f513fc42d55b2210ec3ceeeb194fb1261d37989de07451fc0cbac5c",
[ "a4454f22831acd7904a9902c5070a3ee4bf4c2b13bc6b2dc66735dd3c4414028",
"45297f334278885108dd38a0b689ed95a4373dd3f7e4413e6aebdc2654fb771b"
]
),
-- Block 000000000001d1b13a7e86ddb20da178f20d6da5cd037a29c2a15b8b84cc774e
( "ca3580505feb87544760ac14a5859659e23be05f765bbed9f86a3c9aad1a5d0c"
,
[ "60702384c6e9d34ff03c2b3e726bdc649befe603216815bd0a2974921d0d9549"
, "11f40f58941d2a81a1616a3b84b7dd8b9d07e68750827de488c11a18f54220bb"
, "d78e82527aa8cf16e375010bc666362c0258d3c0da1885a1871121706da8b633"
]
)
, -- Block 0000000000000630a4e2266a31776e952a19b7c99a6387917d9de9032f608021
( "ca3580505feb87544760ac14a5859659e23be05f765bbed9f86a3c9aad1a5d0c",
[ "60702384c6e9d34ff03c2b3e726bdc649befe603216815bd0a2974921d0d9549",
"11f40f58941d2a81a1616a3b84b7dd8b9d07e68750827de488c11a18f54220bb",
"d78e82527aa8cf16e375010bc666362c0258d3c0da1885a1871121706da8b633"
]
),
-- Block 0000000000000630a4e2266a31776e952a19b7c99a6387917d9de9032f608021
( "dcce8be0a9a41e7bb726c5b49d957d90b5308e3dc5dce070ccbc8996e265a6c2"
,
[ "c0f58ff12cd1023b05f8f7035cc62bf50958ddb216a4e0eb5471deb7ef25fe81"
, "24e5bbf9008641b8fcf3d076fef66c28c695362ba9f6a6042f8275a98414ee92"
, "e8e1f72abad5e34dabc0f6de46a484b17a9af857d1c41de19482fadf6f7f4b27"
, "540e4d34d9fd9e5ec02853054be7ad9260379bc23388489049cca1b0f7cf518a"
, "324444835c5fe0545f98c4240011b75e6ea1bb76f41829e4cfbe7f75b6cee924"
, "e7d31437ac21bceb0c222a82b2723e2b8a7654147e33397679f041537022a4b2"
, "a8b5768d8b33525ee89d546a6a6897f8e42ba9d56a2c5e871a5d2ab40258dc95"
, "7ba712b31bae8d45810a5cda3838c7e7fb9abd6e88bb4b3ee79be9ea2f714bb4"
, "2ae1c4d927b06edaa626b230976ad8062bbae24da9378d1de2409da5ab08a26d"
, "3c417dc8087d6878003624b74431e17fec9ca761389034b1b1e0f32cbfb11f4f"
, "de6de7beae8d8c98c7d46b4409d5460e58e3204d8b4caed256c7471998595909"
, "c7c3c211402b7c4379f7b01fadc67260ee58d11e8d0bcce3d68cb45f3467e99d"
, "77aa2717e727a096d81074bd46ae59462692d20a1acc1a01b2535518ae5aeb53"
, "4859a710bb673aca46208bbd59d1000ae990dafff5f70b56f0853aeeaea3948b"
, "38deca6991988e461b83aa0d49ffef0f304c4b760371682d152eeb8c56a48174"
, "648f4f50dada3574e2dfe2dc68956b01dd97d543859a3540bbe1ef5418d0e494"
, "9cd7be42c2f0cd8bf38738c162cd05108e213ec7958bf2571cb627872963f5c4"
, "6740e0dd8b97e23864af41839fc197238d2f0dbefce9a82c657556be65c465fa"
, "f75c2e4b70db4b0aabc44b77af1ae75d305340fcf6e7b5f806ddcba4aa42b55d"
, "e125c488636749da68e6696b97525a77146c0777c7946927e37afd513d74a4e6"
, "c20526f119aea10880af631eba7f0b60385a22e0b0c402fe8508d41952e58be9"
, "6456c023c7e245f5c57a168633a23f57f4fadb651115f807694a6bed14ae3b55"
, "98b26e364e2888c9f264e4b5e13103c89608609774eb07ce933d8a2a45d19776"
, "2efaa4f167bb65ba5684f8076cd9279fd67fd9c67388c8862809bab5542e637d"
, "ec44eeb84d8d976d77079a822710b4dfdb11a2d9a03d8cc00bab0ae424e84666"
, "410730d9f807d81ac48b8eafac6f1d36642c1c370241b367a35f0bac6ac7c05f"
, "e95a7d0d477fd3db22756a3fd390a50c7bc48dc9e946fea9d24bd0866b3bb0e9"
, "a72fec99d14939216628aaf7a0afc4c017113bcae964e777e6b508864eeaacc4"
, "8548433310fcf75dbbc042121e8318c678e0a017534786dd322a91cebe8d213f"
]
)
]
( "dcce8be0a9a41e7bb726c5b49d957d90b5308e3dc5dce070ccbc8996e265a6c2",
[ "c0f58ff12cd1023b05f8f7035cc62bf50958ddb216a4e0eb5471deb7ef25fe81",
"24e5bbf9008641b8fcf3d076fef66c28c695362ba9f6a6042f8275a98414ee92",
"e8e1f72abad5e34dabc0f6de46a484b17a9af857d1c41de19482fadf6f7f4b27",
"540e4d34d9fd9e5ec02853054be7ad9260379bc23388489049cca1b0f7cf518a",
"324444835c5fe0545f98c4240011b75e6ea1bb76f41829e4cfbe7f75b6cee924",
"e7d31437ac21bceb0c222a82b2723e2b8a7654147e33397679f041537022a4b2",
"a8b5768d8b33525ee89d546a6a6897f8e42ba9d56a2c5e871a5d2ab40258dc95",
"7ba712b31bae8d45810a5cda3838c7e7fb9abd6e88bb4b3ee79be9ea2f714bb4",
"2ae1c4d927b06edaa626b230976ad8062bbae24da9378d1de2409da5ab08a26d",
"3c417dc8087d6878003624b74431e17fec9ca761389034b1b1e0f32cbfb11f4f",
"de6de7beae8d8c98c7d46b4409d5460e58e3204d8b4caed256c7471998595909",
"c7c3c211402b7c4379f7b01fadc67260ee58d11e8d0bcce3d68cb45f3467e99d",
"77aa2717e727a096d81074bd46ae59462692d20a1acc1a01b2535518ae5aeb53",
"4859a710bb673aca46208bbd59d1000ae990dafff5f70b56f0853aeeaea3948b",
"38deca6991988e461b83aa0d49ffef0f304c4b760371682d152eeb8c56a48174",
"648f4f50dada3574e2dfe2dc68956b01dd97d543859a3540bbe1ef5418d0e494",
"9cd7be42c2f0cd8bf38738c162cd05108e213ec7958bf2571cb627872963f5c4",
"6740e0dd8b97e23864af41839fc197238d2f0dbefce9a82c657556be65c465fa",
"f75c2e4b70db4b0aabc44b77af1ae75d305340fcf6e7b5f806ddcba4aa42b55d",
"e125c488636749da68e6696b97525a77146c0777c7946927e37afd513d74a4e6",
"c20526f119aea10880af631eba7f0b60385a22e0b0c402fe8508d41952e58be9",
"6456c023c7e245f5c57a168633a23f57f4fadb651115f807694a6bed14ae3b55",
"98b26e364e2888c9f264e4b5e13103c89608609774eb07ce933d8a2a45d19776",
"2efaa4f167bb65ba5684f8076cd9279fd67fd9c67388c8862809bab5542e637d",
"ec44eeb84d8d976d77079a822710b4dfdb11a2d9a03d8cc00bab0ae424e84666",
"410730d9f807d81ac48b8eafac6f1d36642c1c370241b367a35f0bac6ac7c05f",
"e95a7d0d477fd3db22756a3fd390a50c7bc48dc9e946fea9d24bd0866b3bb0e9",
"a72fec99d14939216628aaf7a0afc4c017113bcae964e777e6b508864eeaacc4",
"8548433310fcf75dbbc042121e8318c678e0a017534786dd322a91cebe8d213f"
]
)
]
testSubsidy :: Network -> Assertion
testSubsidy net = go (2 * 50 * 100 * 1000 * 1000) 0
where
go previous_subsidy halvings = do
let height = halvings * getHalvingInterval net
subsidy = computeSubsidy net height
if halvings >= 64
then subsidy `shouldBe` 0
else do
subsidy `shouldBe` (previous_subsidy `div` 2)
go subsidy (halvings + 1)
let height = halvings * net.halvingInterval
subsidy = computeSubsidy net height
if halvings >= 64
then subsidy `shouldBe` 0
else do
subsidy `shouldBe` (previous_subsidy `div` 2)
go subsidy (halvings + 1)
data AsertBlock = AsertBlock Int Integer Integer Word32
@ -387,34 +386,34 @@ data AsertVector = AsertVector String Integer Integer Word32 [AsertBlock]
readAsertVector :: FilePath -> IO AsertVector
readAsertVector p = do
(d : ah : apt : ab : _ : _ : _ : _ : xs) <- lines <$> readFile ("data/" ++ p)
let desc = drop 16 d
anchor_height = read (words ah !! 3)
anchor_parent_time = read (words apt !! 4)
anchor_nbits = read (words ab !! 3)
blocks = map (f . words) (init xs)
return $
AsertVector
desc
anchor_height
anchor_parent_time
anchor_nbits
blocks
(d : ah : apt : ab : _ : _ : _ : _ : xs) <- lines <$> readFile ("data/" ++ p)
let desc = drop 16 d
anchor_height = read (words ah !! 3)
anchor_parent_time = read (words apt !! 4)
anchor_nbits = read (words ab !! 3)
blocks = map (f . words) (init xs)
return $
AsertVector
desc
anchor_height
anchor_parent_time
anchor_nbits
blocks
where
f [i, h, t, g] = AsertBlock (read i) (read h) (read t) (read g)
f _ = undefined
asertTests :: FilePath -> SpecWith ()
asertTests file = do
v@(AsertVector d _ _ _ _) <- runIO $ readAsertVector file
it d $ testAsertBits v
v@(AsertVector d _ _ _ _) <- runIO $ readAsertVector file
it d $ testAsertBits v
testAsertBits :: AsertVector -> Assertion
testAsertBits (AsertVector _ anchor_height anchor_parent_time anchor_bits blocks) =
forM_ blocks $ \(AsertBlock _ h t g) ->
computeAsertBits
(2 * 24 * 60 * 60)
anchor_bits
(t - anchor_parent_time)
(h - anchor_height)
`shouldBe` g
forM_ blocks $ \(AsertBlock _ h t g) ->
computeAsertBits
(2 * 24 * 60 * 60)
anchor_bits
(t - anchor_parent_time)
(h - anchor_height)
`shouldBe` g

667
test/Haskoin/Crypto/HashSpec.hs
View File

@ -1,13 +1,16 @@
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoFieldSelectors #-}
module Haskoin.Crypto.HashSpec (spec) where
import Data.Bits
import Data.ByteString (ByteString)
import Data.ByteString.Builder
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Short as BSS
import Data.ByteString.Char8 qualified as Char8
import Data.ByteString.Lazy qualified as Lazy
import Data.ByteString.Short qualified as Short
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
@ -27,51 +30,52 @@ import Test.QuickCheck
serialVals :: [SerialBox]
serialVals =
[ SerialBox arbitraryBS
, SerialBox arbitraryHash160
, SerialBox arbitraryHash256
, SerialBox arbitraryHash512
]
[ SerialBox arbitraryBS,
SerialBox arbitraryHash160,
SerialBox arbitraryHash256,
SerialBox arbitraryHash512
]
readVals :: [ReadBox]
readVals =
[ ReadBox arbitraryBS
, ReadBox arbitraryBSS
, ReadBox arbitraryHash160
, ReadBox arbitraryHash256
, ReadBox arbitraryHash512
]
[ ReadBox arbitraryBS,
ReadBox arbitraryBSS,
ReadBox arbitraryHash160,
ReadBox arbitraryHash256,
ReadBox arbitraryHash512
]
spec :: Spec
spec =
describe "Hash" $ do
testIdentity serialVals readVals [] []
describe "Property Tests" $ do
prop "join512( split512(h) ) == h" $
forAll arbitraryHash256 $ forAll arbitraryHash256 . joinSplit512
prop "decodeCompact . encodeCompact i == i" decEncCompact
prop "from string Hash512" $
forAll arbitraryHash512 $ \h ->
fromString (cs $ encodeHex $ runPutS $ serialize h) == h
prop "from string Hash256" $
forAll arbitraryHash256 $ \h ->
fromString (cs $ encodeHex $ runPutS $ serialize h) == h
prop "from string Hash160" $
forAll arbitraryHash160 $ \h ->
fromString (cs $ encodeHex $ runPutS $ serialize h) == h
describe "Test Vectors" $ do
it "Passes RIPEMD160 test vectors" $
mapM_ (testVector ripemd160 getHash160) ripemd160Vectors
it "Passes SHA1 test vectors" $
mapM_ (testVector sha1 getHash160) sha1Vectors
it "Passes SHA256 test vectors" $
mapM_ (testVector sha256 getHash256) sha256Vectors
it "Passes SHA512 test vectors" $
mapM_ (testVector sha512 getHash512) sha512Vectors
it "Passes HMAC_SHA256 test vectors" $
mapM_ (testHMACVector hmac256 getHash256) hmacSha256Vectors
it "Passes HMAC_SHA512 test vectors" $
mapM_ (testHMACVector hmac512 getHash512) hmacSha512Vectors
describe "Hash" $ do
testIdentity serialVals readVals [] []
describe "Property Tests" $ do
prop "join512( split512(h) ) == h" $
forAll arbitraryHash256 $
forAll arbitraryHash256 . joinSplit512
prop "decodeCompact . encodeCompact i == i" decEncCompact
prop "from string Hash512" $
forAll arbitraryHash512 $ \h ->
fromString (cs $ encodeHex $ runPutS $ serialize h) == h
prop "from string Hash256" $
forAll arbitraryHash256 $ \h ->
fromString (cs $ encodeHex $ runPutS $ serialize h) == h
prop "from string Hash160" $
forAll arbitraryHash160 $ \h ->
fromString (cs $ encodeHex $ runPutS $ serialize h) == h
describe "Test Vectors" $ do
it "Passes RIPEMD160 test vectors" $
mapM_ (testVector ripemd160 (.get)) ripemd160Vectors
it "Passes SHA1 test vectors" $
mapM_ (testVector sha1 (.get)) sha1Vectors
it "Passes SHA256 test vectors" $
mapM_ (testVector sha256 (.get)) sha256Vectors
it "Passes SHA512 test vectors" $
mapM_ (testVector sha512 (.get)) sha512Vectors
it "Passes HMAC_SHA256 test vectors" $
mapM_ (testHMACVector hmac256 (.get)) hmacSha256Vectors
it "Passes HMAC_SHA512 test vectors" $
mapM_ (testHMACVector hmac512 (.get)) hmacSha512Vectors
joinSplit512 :: Hash256 -> Hash256 -> Bool
joinSplit512 a b = split512 (join512 (a, b)) == (a, b)
@ -80,358 +84,317 @@ joinSplit512 a b = split512 (join512 (a, b)) == (a, b)
-- to the old one.
decEncCompact :: Integer -> Bool
decEncCompact i
-- Integer completely fits inside the mantisse
| abs i <= 0x007fffff = decodeCompact (encodeCompact i) == (i, False)
-- Otherwise precision will be lost and the decoded result will
-- be smaller than the original number
| i >= 0 = fst (decodeCompact (encodeCompact i)) < i
| otherwise = fst (decodeCompact (encodeCompact i)) > i
-- Integer completely fits inside the mantisse
| abs i <= 0x007fffff = decodeCompact (encodeCompact i) == (i, False)
-- Otherwise precision will be lost and the decoded result will
-- be smaller than the original number
| i >= 0 = fst (decodeCompact (encodeCompact i)) < i
| otherwise = fst (decodeCompact (encodeCompact i)) > i
-- Test vectors from:
-- https://github.com/bitcoin/bitcoin/blob/master/src/test/crypto_tests.cpp
testVector ::
(ByteString -> a) ->
(a -> BSS.ShortByteString) ->
(ByteString, Text) ->
Assertion
(ByteString -> a) ->
(a -> Short.ShortByteString) ->
(ByteString, Text) ->
Assertion
testVector f1 f2 (i, res) =
assertEqual "Hash matches" res (encodeHex (BSS.fromShort $ f2 $ f1 i))
assertEqual "Hash matches" res (encodeHex (Short.fromShort $ f2 $ f1 i))
testHMACVector ::
(ByteString -> ByteString -> a) ->
(a -> BSS.ShortByteString) ->
(Text, Text, Text) ->
Assertion
(ByteString -> ByteString -> a) ->
(a -> Short.ShortByteString) ->
(Text, Text, Text) ->
Assertion
testHMACVector f1 f2 (k, m, res) =
assertEqual "Hash matches" res (encodeHex (BSS.fromShort $ f2 $ f1 bsK bsM))
assertEqual "Hash matches" res (encodeHex (Short.fromShort $ f2 $ f1 bsK bsM))
where
bsK = fromJust $ decodeHex k
bsM = fromJust $ decodeHex m
longTestString :: ByteString
longTestString =
BL.toStrict $! toLazyByteString $! go [0 .. 199999]
Lazy.toStrict $! toLazyByteString $! go [0 .. 199999]
where
go :: [Word32] -> Builder
go [] = mempty
go (i : is) =
let i1 = fromIntegral $! i
i2 = fromIntegral $! i `shiftR` 4
i3 = fromIntegral $! i `shiftR` 8
i4 = fromIntegral $! i `shiftR` 12
i5 = fromIntegral $! i `shiftR` 16
in word8 i1 <> word8 i2 <> word8 i3 <> word8 i4 <> word8 i5 <> go is
let i1 = fromIntegral $! i
i2 = fromIntegral $! i `shiftR` 4
i3 = fromIntegral $! i `shiftR` 8
i4 = fromIntegral $! i `shiftR` 12
i5 = fromIntegral $! i `shiftR` 16
in word8 i1 <> word8 i2 <> word8 i3 <> word8 i4 <> word8 i5 <> go is
ripemd160Vectors :: [(ByteString, Text)]
ripemd160Vectors =
[ ("", "9c1185a5c5e9fc54612808977ee8f548b2258d31")
, ("abc", "8eb208f7e05d987a9b044a8e98c6b087f15a0bfc")
, ("message digest", "5d0689ef49d2fae572b881b123a85ffa21595f36")
, ("secure hash algorithm", "20397528223b6a5f4cbc2808aba0464e645544f9")
,
( "RIPEMD160 is considered to be safe"
, "a7d78608c7af8a8e728778e81576870734122b66"
)
,
( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
, "12a053384a9c0c88e405a06c27dcf49ada62eb2b"
)
,
( "For this sample, this 63-byte string will be used as input data"
, "de90dbfee14b63fb5abf27c2ad4a82aaa5f27a11"
)
,
( "This is exactly 64 bytes long, not counting the terminating byte"
, "eda31d51d3a623b81e19eb02e24ff65d27d67b37"
)
, (C.replicate 1000000 'a', "52783243c1697bdbe16d37f97f68f08325dc1528")
, (longTestString, "464243587bd146ea835cdf57bdae582f25ec45f1")
]
[ ("", "9c1185a5c5e9fc54612808977ee8f548b2258d31"),
("abc", "8eb208f7e05d987a9b044a8e98c6b087f15a0bfc"),
("message digest", "5d0689ef49d2fae572b881b123a85ffa21595f36"),
("secure hash algorithm", "20397528223b6a5f4cbc2808aba0464e645544f9"),
( "RIPEMD160 is considered to be safe",
"a7d78608c7af8a8e728778e81576870734122b66"
),
( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq",
"12a053384a9c0c88e405a06c27dcf49ada62eb2b"
),
( "For this sample, this 63-byte string will be used as input data",
"de90dbfee14b63fb5abf27c2ad4a82aaa5f27a11"
),
( "This is exactly 64 bytes long, not counting the terminating byte",
"eda31d51d3a623b81e19eb02e24ff65d27d67b37"
),
(Char8.replicate 1000000 'a', "52783243c1697bdbe16d37f97f68f08325dc1528"),
(longTestString, "464243587bd146ea835cdf57bdae582f25ec45f1")
]
sha1Vectors :: [(ByteString, Text)]
sha1Vectors =
[ ("", "da39a3ee5e6b4b0d3255bfef95601890afd80709")
, ("abc", "a9993e364706816aba3e25717850c26c9cd0d89d")
, ("message digest", "c12252ceda8be8994d5fa0290a47231c1d16aae3")
, ("secure hash algorithm", "d4d6d2f0ebe317513bbd8d967d89bac5819c2f60")
,
( "SHA1 is considered to be safe"
, "f2b6650569ad3a8720348dd6ea6c497dee3a842a"
)
,
( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
, "84983e441c3bd26ebaae4aa1f95129e5e54670f1"
)
,
( "For this sample, this 63-byte string will be used as input data"
, "4f0ea5cd0585a23d028abdc1a6684e5a8094dc49"
)
,
( "This is exactly 64 bytes long, not counting the terminating byte"
, "fb679f23e7d1ce053313e66e127ab1b444397057"
)
, (C.replicate 1000000 'a', "34aa973cd4c4daa4f61eeb2bdbad27316534016f")
, (longTestString, "b7755760681cbfd971451668f32af5774f4656b5")
]
[ ("", "da39a3ee5e6b4b0d3255bfef95601890afd80709"),
("abc", "a9993e364706816aba3e25717850c26c9cd0d89d"),
("message digest", "c12252ceda8be8994d5fa0290a47231c1d16aae3"),
("secure hash algorithm", "d4d6d2f0ebe317513bbd8d967d89bac5819c2f60"),
( "SHA1 is considered to be safe",
"f2b6650569ad3a8720348dd6ea6c497dee3a842a"
),
( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq",
"84983e441c3bd26ebaae4aa1f95129e5e54670f1"
),
( "For this sample, this 63-byte string will be used as input data",
"4f0ea5cd0585a23d028abdc1a6684e5a8094dc49"
),
( "This is exactly 64 bytes long, not counting the terminating byte",
"fb679f23e7d1ce053313e66e127ab1b444397057"
),
(Char8.replicate 1000000 'a', "34aa973cd4c4daa4f61eeb2bdbad27316534016f"),
(longTestString, "b7755760681cbfd971451668f32af5774f4656b5")
]
sha256Vectors :: [(ByteString, Text)]
sha256Vectors =
[ ("", "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855")
,
( "abc"
, "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad"
)
,
( "message digest"
, "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650"
)
,
( "secure hash algorithm"
, "f30ceb2bb2829e79e4ca9753d35a8ecc00262d164cc077080295381cbd643f0d"
)
,
( "SHA256 is considered to be safe"
, "6819d915c73f4d1e77e4e1b52d1fa0f9cf9beaead3939f15874bd988e2a23630"
)
,
( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
, "248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1"
)
,
( "For this sample, this 63-byte string will be used as input data"
, "f08a78cbbaee082b052ae0708f32fa1e50c5c421aa772ba5dbb406a2ea6be342"
)
,
( "This is exactly 64 bytes long, not counting the terminating byte"
, "ab64eff7e88e2e46165e29f2bce41826bd4c7b3552f6b382a9e7d3af47c245f8"
)
,
( "As Bitcoin relies on 80 byte header hashes, we want to have an example for that."
, "7406e8de7d6e4fffc573daef05aefb8806e7790f55eab5576f31349743cca743"
)
,
( C.replicate 1000000 'a'
, "cdc76e5c9914fb9281a1c7e284d73e67f1809a48a497200e046d39ccc7112cd0"
)
,
( longTestString
, "a316d55510b49662420f49d145d42fb83f31ef8dc016aa4e32df049991a91e26"
)
]
[ ("", "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855"),
( "abc",
"ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad"
),
( "message digest",
"f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650"
),
( "secure hash algorithm",
"f30ceb2bb2829e79e4ca9753d35a8ecc00262d164cc077080295381cbd643f0d"
),
( "SHA256 is considered to be safe",
"6819d915c73f4d1e77e4e1b52d1fa0f9cf9beaead3939f15874bd988e2a23630"
),
( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq",
"248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1"
),
( "For this sample, this 63-byte string will be used as input data",
"f08a78cbbaee082b052ae0708f32fa1e50c5c421aa772ba5dbb406a2ea6be342"
),
( "This is exactly 64 bytes long, not counting the terminating byte",
"ab64eff7e88e2e46165e29f2bce41826bd4c7b3552f6b382a9e7d3af47c245f8"
),
( "As Bitcoin relies on 80 byte header hashes, we want to have an example for that.",
"7406e8de7d6e4fffc573daef05aefb8806e7790f55eab5576f31349743cca743"
),
( Char8.replicate 1000000 'a',
"cdc76e5c9914fb9281a1c7e284d73e67f1809a48a497200e046d39ccc7112cd0"
),
( longTestString,
"a316d55510b49662420f49d145d42fb83f31ef8dc016aa4e32df049991a91e26"
)
]
sha512Vectors :: [(ByteString, Text)]
sha512Vectors =
[
( ""
, "cf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d1\
\3c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e"
)
,
( "abc"
, "ddaf35a193617abacc417349ae20413112e6fa4e89a97ea20a9eeee64b55d39a219299\
\2a274fc1a836ba3c23a3feebbd454d4423643ce80e2a9ac94fa54ca49f"
)
,
( "message digest"
, "107dbf389d9e9f71a3a95f6c055b9251bc5268c2be16d6c13492ea45b0199f3309e164\
\55ab1e96118e8a905d5597b72038ddb372a89826046de66687bb420e7c"
)
,
( "secure hash algorithm"
, "7746d91f3de30c68cec0dd693120a7e8b04d8073cb699bdce1a3f64127bca7a3d5db50\
\2e814bb63c063a7a5043b2df87c61133395f4ad1edca7fcf4b30c3236e"
)
,
( "SHA512 is considered to be safe"
, "099e6468d889e1c79092a89ae925a9499b5408e01b66cb5b0a3bd0dfa51a99646b4a39\
\01caab1318189f74cd8cf2e941829012f2449df52067d3dd5b978456c2"
)
,
( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
, "204a8fc6dda82f0a0ced7beb8e08a41657c16ef468b228a8279be331a703c33596fd15\
\c13b1b07f9aa1d3bea57789ca031ad85c7a71dd70354ec631238ca3445"
)
,
( "For this sample, this 63-byte string will be used as input data"
, "b3de4afbc516d2478fe9b518d063bda6c8dd65fc38402dd81d1eb7364e72fb6e6663cf\
\6d2771c8f5a6da09601712fb3d2a36c6ffea3e28b0818b05b0a8660766"
)
,
( "This is exactly 64 bytes long, not counting the terminating byte"
, "70aefeaa0e7ac4f8fe17532d7185a289bee3b428d950c14fa8b713ca09814a387d2458\
\70e007a80ad97c369d193e41701aa07f3221d15f0e65a1ff970cedf030"
)
,
( "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmn\
\opjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu"
, "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d28\
\9e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909"
)
,
( C.replicate 1000000 'a'
, "e718483d0ce769644e2e42c7bc15b4638e1f98b13b2044285632a803afa973ebde0ff2\
\44877ea60a4cb0432ce577c31beb009c5c2c49aa2e4eadb217ad8cc09b"
)
,
( longTestString
, "40cac46c147e6131c5193dd5f34e9d8bb4951395f27b08c558c65ff4ba2de59437de8c\
\3ef5459d76a52cedc02dc499a3c9ed9dedbfb3281afd9653b8a112fafc"
)
]
[ ( "",
"cf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d1\
\3c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e"
),
( "abc",
"ddaf35a193617abacc417349ae20413112e6fa4e89a97ea20a9eeee64b55d39a219299\
\2a274fc1a836ba3c23a3feebbd454d4423643ce80e2a9ac94fa54ca49f"
),
( "message digest",
"107dbf389d9e9f71a3a95f6c055b9251bc5268c2be16d6c13492ea45b0199f3309e164\
\55ab1e96118e8a905d5597b72038ddb372a89826046de66687bb420e7c"
),
( "secure hash algorithm",
"7746d91f3de30c68cec0dd693120a7e8b04d8073cb699bdce1a3f64127bca7a3d5db50\
\2e814bb63c063a7a5043b2df87c61133395f4ad1edca7fcf4b30c3236e"
),
( "SHA512 is considered to be safe",
"099e6468d889e1c79092a89ae925a9499b5408e01b66cb5b0a3bd0dfa51a99646b4a39\
\01caab1318189f74cd8cf2e941829012f2449df52067d3dd5b978456c2"
),
( "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq",
"204a8fc6dda82f0a0ced7beb8e08a41657c16ef468b228a8279be331a703c33596fd15\
\c13b1b07f9aa1d3bea57789ca031ad85c7a71dd70354ec631238ca3445"
),
( "For this sample, this 63-byte string will be used as input data",
"b3de4afbc516d2478fe9b518d063bda6c8dd65fc38402dd81d1eb7364e72fb6e6663cf\
\6d2771c8f5a6da09601712fb3d2a36c6ffea3e28b0818b05b0a8660766"
),
( "This is exactly 64 bytes long, not counting the terminating byte",
"70aefeaa0e7ac4f8fe17532d7185a289bee3b428d950c14fa8b713ca09814a387d2458\
\70e007a80ad97c369d193e41701aa07f3221d15f0e65a1ff970cedf030"
),
( "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmn\
\opjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu",
"8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d28\
\9e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909"
),
( Char8.replicate 1000000 'a',
"e718483d0ce769644e2e42c7bc15b4638e1f98b13b2044285632a803afa973ebde0ff2\
\44877ea60a4cb0432ce577c31beb009c5c2c49aa2e4eadb217ad8cc09b"
),
( longTestString,
"40cac46c147e6131c5193dd5f34e9d8bb4951395f27b08c558c65ff4ba2de59437de8c\
\3ef5459d76a52cedc02dc499a3c9ed9dedbfb3281afd9653b8a112fafc"
)
]
-- test cases 1, 2, 3, 4, 6 and 7 of RFC 4231
hmacSha256Vectors :: [(Text, Text, Text)]
hmacSha256Vectors =
[
( "0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b"
, "4869205468657265"
, "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7"
)
,
( "4a656665"
, "7768617420646f2079612077616e7420666f72206e6f7468696e673f"
, "5bdcc146bf60754e6a042426089575c75a003f089d2739839dec58b964ec3843"
)
,
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
, "dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd\
\dddddddddddddddddddddddddddddd"
, "773ea91e36800e46854db8ebd09181a72959098b3ef8c122d9635514ced565fe"
)
,
( "0102030405060708090a0b0c0d0e0f10111213141516171819"
, "cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd\
\cdcdcdcdcdcdcdcdcdcdcdcdcdcdcd"
, "82558a389a443c0ea4cc819899f2083a85f0faa3e578f8077a2e3ff46729665b"
)
,
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
, "54657374205573696e67204c6172676572205468616e20426c6f636b2d53697a65204b\
\6579202d2048617368204b6579204669727374"
, "60e431591ee0b67f0d8a26aacbf5b77f8e0bc6213728c5140546040f0ee37f54"
)
,
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
, "5468697320697320612074657374207573696e672061206c6172676572207468616e20\
\626c6f636b2d73697a65206b657920616e642061206c6172676572207468616e20626c\
\6f636b2d73697a6520646174612e20546865206b6579206e6565647320746f20626520\
\686173686564206265666f7265206265696e6720757365642062792074686520484d41\
\4320616c676f726974686d2e"
, "9b09ffa71b942fcb27635fbcd5b0e944bfdc63644f0713938a7f51535c3a35e2"
)
, -- Test case with key length 63 bytes.
[ ( "0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b",
"4869205468657265",
"b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7"
),
( "4a656665",
"7768617420646f2079612077616e7420666f72206e6f7468696e673f",
"5bdcc146bf60754e6a042426089575c75a003f089d2739839dec58b964ec3843"
),
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa",
"dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd\
\dddddddddddddddddddddddddddddd",
"773ea91e36800e46854db8ebd09181a72959098b3ef8c122d9635514ced565fe"
),
( "0102030405060708090a0b0c0d0e0f10111213141516171819",
"cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd\
\cdcdcdcdcdcdcdcdcdcdcdcdcdcdcd",
"82558a389a443c0ea4cc819899f2083a85f0faa3e578f8077a2e3ff46729665b"
),
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa",
"54657374205573696e67204c6172676572205468616e20426c6f636b2d53697a65204b\
\6579202d2048617368204b6579204669727374",
"60e431591ee0b67f0d8a26aacbf5b77f8e0bc6213728c5140546040f0ee37f54"
),
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa",
"5468697320697320612074657374207573696e672061206c6172676572207468616e20\
\626c6f636b2d73697a65206b657920616e642061206c6172676572207468616e20626c\
\6f636b2d73697a6520646174612e20546865206b6579206e6565647320746f20626520\
\686173686564206265666f7265206265696e6720757365642062792074686520484d41\
\4320616c676f726974686d2e",
"9b09ffa71b942fcb27635fbcd5b0e944bfdc63644f0713938a7f51535c3a35e2"
),
-- Test case with key length 63 bytes.
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566\
\654a6566654a6566654a6566654a6566654a6566654a6566654a6566"
, "7768617420646f2079612077616e7420666f72206e6f7468696e673f"
, "9de4b546756c83516720a4ad7fe7bdbeac4298c6fdd82b15f895a6d10b0769a6"
)
, -- Test case with key length 64 bytes.
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566\
\654a6566654a6566654a6566654a6566654a6566654a6566654a6566",
"7768617420646f2079612077616e7420666f72206e6f7468696e673f",
"9de4b546756c83516720a4ad7fe7bdbeac4298c6fdd82b15f895a6d10b0769a6"
),
-- Test case with key length 64 bytes.
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566\
\654a6566654a6566654a6566654a6566654a6566654a6566654a656665"
, "7768617420646f2079612077616e7420666f72206e6f7468696e673f"
, "528c609a4c9254c274585334946b7c2661bad8f1fc406b20f6892478d19163dd"
)
, -- Test case with key length 65 bytes.
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566\
\654a6566654a6566654a6566654a6566654a6566654a6566654a656665",
"7768617420646f2079612077616e7420666f72206e6f7468696e673f",
"528c609a4c9254c274585334946b7c2661bad8f1fc406b20f6892478d19163dd"
),
-- Test case with key length 65 bytes.
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566\
\654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a"
, "7768617420646f2079612077616e7420666f72206e6f7468696e673f"
, "d06af337f359a2330deffb8e3cbe4b5b7aa8ca1f208528cdbd245d5dc63c4483"
)
]
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566\
\654a6566654a6566654a6566654a6566654a6566654a6566654a6566654a",
"7768617420646f2079612077616e7420666f72206e6f7468696e673f",
"d06af337f359a2330deffb8e3cbe4b5b7aa8ca1f208528cdbd245d5dc63c4483"
)
]
-- test cases 1, 2, 3, 4, 6 and 7 of RFC 4231
hmacSha512Vectors :: [(Text, Text, Text)]
hmacSha512Vectors =
[
( "0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b"
, "4869205468657265"
, "87aa7cdea5ef619d4ff0b4241a1d6cb02379f4e2ce4ec2787ad0b30545e17cde\
\daa833b7d6b8a702038b274eaea3f4e4be9d914eeb61f1702e696c203a126854"
)
,
( "4a656665"
, "7768617420646f2079612077616e7420666f72206e6f7468696e673f"
, "164b7a7bfcf819e2e395fbe73b56e0a387bd64222e831fd610270cd7ea250554\
\9758bf75c05a994a6d034f65f8f0e6fdcaeab1a34d4a6b4b636e070a38bce737"
)
,
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
, "dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd\
\dddddddddddddddddddddddddddddddddddd"
, "fa73b0089d56a284efb0f0756c890be9b1b5dbdd8ee81a3655f83e33b2279d39\
\bf3e848279a722c806b485a47e67c807b946a337bee8942674278859e13292fb"
)
,
( "0102030405060708090a0b0c0d0e0f10111213141516171819"
, "cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd\
\cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd"
, "b0ba465637458c6990e5a8c5f61d4af7e576d97ff94b872de76f8050361ee3db\
\a91ca5c11aa25eb4d679275cc5788063a5f19741120c4f2de2adebeb10a298dd"
)
,
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaa"
, "54657374205573696e67204c6172676572205468616e20426c6f636b2d53697a\
\65204b6579202d2048617368204b6579204669727374"
, "80b24263c7c1a3ebb71493c1dd7be8b49b46d1f41b4aeec1121b013783f8f352\
\6b56d037e05f2598bd0fd2215d6a1e5295e64f73f63f0aec8b915a985d786598"
)
,
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaa"
, "5468697320697320612074657374207573696e672061206c6172676572207468\
\616e20626c6f636b2d73697a65206b657920616e642061206c61726765722074\
\68616e20626c6f636b2d73697a6520646174612e20546865206b6579206e6565\
\647320746f20626520686173686564206265666f7265206265696e6720757365\
\642062792074686520484d414320616c676f726974686d2e"
, "e37b6a775dc87dbaa4dfa9f96e5e3ffddebd71f8867289865df5a32d20cdc944\
\b6022cac3c4982b10d5eeb55c3e4de15134676fb6de0446065c97440fa8c6a58"
)
, -- Test case with key length 127 bytes.
[ ( "0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b",
"4869205468657265",
"87aa7cdea5ef619d4ff0b4241a1d6cb02379f4e2ce4ec2787ad0b30545e17cde\
\daa833b7d6b8a702038b274eaea3f4e4be9d914eeb61f1702e696c203a126854"
),
( "4a656665",
"7768617420646f2079612077616e7420666f72206e6f7468696e673f",
"164b7a7bfcf819e2e395fbe73b56e0a387bd64222e831fd610270cd7ea250554\
\9758bf75c05a994a6d034f65f8f0e6fdcaeab1a34d4a6b4b636e070a38bce737"
),
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa",
"dddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddddd\
\dddddddddddddddddddddddddddddddddddd",
"fa73b0089d56a284efb0f0756c890be9b1b5dbdd8ee81a3655f83e33b2279d39\
\bf3e848279a722c806b485a47e67c807b946a337bee8942674278859e13292fb"
),
( "0102030405060708090a0b0c0d0e0f10111213141516171819",
"cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd\
\cdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcdcd",
"b0ba465637458c6990e5a8c5f61d4af7e576d97ff94b872de76f8050361ee3db\
\a91ca5c11aa25eb4d679275cc5788063a5f19741120c4f2de2adebeb10a298dd"
),
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaa",
"54657374205573696e67204c6172676572205468616e20426c6f636b2d53697a\
\65204b6579202d2048617368204b6579204669727374",
"80b24263c7c1a3ebb71493c1dd7be8b49b46d1f41b4aeec1121b013783f8f352\
\6b56d037e05f2598bd0fd2215d6a1e5295e64f73f63f0aec8b915a985d786598"
),
( "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\
\aaaaaa",
"5468697320697320612074657374207573696e672061206c6172676572207468\
\616e20626c6f636b2d73697a65206b657920616e642061206c61726765722074\
\68616e20626c6f636b2d73697a6520646174612e20546865206b6579206e6565\
\647320746f20626520686173686564206265666f7265206265696e6720757365\
\642062792074686520484d414320616c676f726974686d2e",
"e37b6a775dc87dbaa4dfa9f96e5e3ffddebd71f8867289865df5a32d20cdc944\
\b6022cac3c4982b10d5eeb55c3e4de15134676fb6de0446065c97440fa8c6a58"
),
-- Test case with key length 127 bytes.
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566"
, "7768617420646f2079612077616e7420666f72206e6f7468696e673f"
, "267424dfb8eeb999f3e5ec39a4fe9fd14c923e6187e0897063e5c9e02b2e624a\
\c04413e762977df71a9fb5d562b37f89dfdfb930fce2ed1fa783bbc2a203d80e"
)
, -- Test case with key length 128 bytes.
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a6566",
"7768617420646f2079612077616e7420666f72206e6f7468696e673f",
"267424dfb8eeb999f3e5ec39a4fe9fd14c923e6187e0897063e5c9e02b2e624a\
\c04413e762977df71a9fb5d562b37f89dfdfb930fce2ed1fa783bbc2a203d80e"
),
-- Test case with key length 128 bytes.
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665"
, "7768617420646f2079612077616e7420666f72206e6f7468696e673f"
, "43aaac07bb1dd97c82c04df921f83b16a68d76815cd1a30d3455ad43a3d80484\
\2bb35462be42cc2e4b5902de4d204c1c66d93b47d1383e3e13a3788687d61258"
)
, -- Test case with key length 129 bytes.
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665",
"7768617420646f2079612077616e7420666f72206e6f7468696e673f",
"43aaac07bb1dd97c82c04df921f83b16a68d76815cd1a30d3455ad43a3d80484\
\2bb35462be42cc2e4b5902de4d204c1c66d93b47d1383e3e13a3788687d61258"
),
-- Test case with key length 129 bytes.
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
\4a"
, "7768617420646f2079612077616e7420666f72206e6f7468696e673f"
, "0b273325191cfc1b4b71d5075c8fcad67696309d292b1dad2cd23983a35feb8e\
\fb29795e79f2ef27f68cb1e16d76178c307a67beaad9456fac5fdffeadb16e2c"
)
]
( "4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
\4a6566654a6566654a6566654a6566654a6566654a6566654a6566654a656665\
\4a",
"7768617420646f2079612077616e7420666f72206e6f7468696e673f",
"0b273325191cfc1b4b71d5075c8fcad67696309d292b1dad2cd23983a35feb8e\
\fb29795e79f2ef27f68cb1e16d76178c307a67beaad9456fac5fdffeadb16e2c"
)
]

608
test/Haskoin/Crypto/Keys/ExtendedSpec.hs Normal file
View 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
View 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
View 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

693
test/Haskoin/Crypto/SignatureSpec.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
module Haskoin.Crypto.SignatureSpec (spec) where
@ -5,114 +7,120 @@ module Haskoin.Crypto.SignatureSpec (spec) where
import Control.Monad
import Data.Bits (testBit)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.ByteString qualified as BS
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Map.Strict qualified as Map
import Data.Maybe
import Data.Serialize as S
import Data.String.Conversions (cs)
import Data.Text (Text)
import Haskoin.Address
import Haskoin.Constants
import Haskoin.Crypto
import Haskoin.Keys
import Haskoin.Network.Constants
import Haskoin.Script
import Haskoin.Transaction
import Haskoin.Util
import Haskoin.Util.Arbitrary
import Haskoin.UtilSpec (readTestFile)
import Test.HUnit
import Test.Hspec
import Test.Hspec.QuickCheck
import Test.QuickCheck
spec :: Spec
spec = do
describe "Signature properties" $ do
prop "verify signature" $
forAll arbitrarySignature $ \(m, key', sig) ->
verifyHashSig m sig (derivePubKey key')
prop "s component less than half order" $
forAll arbitrarySignature $ isCanonicalHalfOrder . lst3
prop "encoded signature is canonical" $
forAll arbitrarySignature $ testIsCanonical . lst3
prop "decodeStrictSig . exportSig identity" $
forAll arbitrarySignature $
(\s -> decodeStrictSig (exportSig s) == Just s) . lst3
prop "importSig . exportSig identity" $
forAll arbitrarySignature $
(\s -> importSig (exportSig s) == Just s) . lst3
prop "getSig . putSig identity" $
forAll arbitrarySignature $
(\s -> runGet getSig (runPut $ putSig s) == Right s) . lst3
describe "Signature vectors" $
checkDistSig $ \file1 file2 -> do
vectors <- runIO (readTestFile file1 :: IO [(Text, Text, Text)])
vectorsDER <- runIO (readTestFile file2 :: IO [(Text, Text, Text)])
it "Passes the trezor rfc6979 test vectors" $
mapM_ (testRFC6979Vector . toVector) vectors
it "Passes the rfc6979 DER test vectors" $
mapM_ (testRFC6979DERVector . toVector) vectorsDER
describe "BIP143 signature vectors" $ do
it "agrees with BIP143 p2wpkh example" testBip143p2wpkh
it "agrees with BIP143 p2sh-p2wpkh example" testBip143p2shp2wpkh
it "builds a p2wsh multisig transaction" testP2WSHMulsig
it "agrees with BIP143 p2sh-p2wsh multisig example" testBip143p2shp2wpkhMulsig
spec = prepareContext $ \ctx -> do
describe "Signature property checks" $ do
prop "verifies signature" $
forAll (arbitrarySignature ctx) $ \(m, key', sig) ->
verifyHashSig ctx m sig (derivePubKey ctx key')
prop "s component less than half order" $
forAll (arbitrarySignature ctx) $
isCanonicalHalfOrder ctx . lst3
prop "encoded signature is canonical" $
forAll (arbitrarySignature ctx) $
testIsCanonical ctx . lst3
prop "decodeStrictSig . exportSig identity" $
forAll (arbitrarySignature ctx) $
(\s -> decodeStrictSig ctx (exportSig ctx s) == Just s) . lst3
prop "importSig . exportSig identity" $
forAll (arbitrarySignature ctx) $
(\s -> importSig ctx (exportSig ctx s) == Just s) . lst3
prop "signature JSON identity" $
forAll (arbitrarySignature ctx) $
(\s -> (unmarshalJSON ctx . marshalJSON ctx) s == Just s) . lst3
prop "getSig . putSig identity" $
forAll (arbitrarySignature ctx) $
(\s -> unmarshal ctx (marshal ctx s) == Right s) . lst3
describe "Signature vectors" $ do
it "passes RFC6979 test vectors" $
checkDistSig ctx $ \file1 file2 -> do
vectors <- readTestFile file1 :: IO [(Text, Text, Text)]
vectorsDER <- readTestFile file2 :: IO [(Text, Text, Text)]
mapM_ (testRFC6979Vector ctx . toVector) vectors
mapM_ (testRFC6979DERVector ctx . toVector) vectorsDER
describe "BIP143 signature vectors" $ do
it "agrees with BIP143 p2wpkh example" $
testBip143p2wpkh ctx
it "agrees with BIP143 p2sh-p2wpkh example" $
testBip143p2shp2wpkh ctx
it "builds a p2wsh multisig transaction" $
testP2WSHMulsig ctx
it "agrees with BIP143 p2sh-p2wsh multisig example" $
testBip143p2shp2wpkhMulsig ctx
-- github.com/bitcoin/bitcoin/blob/master/src/script.cpp
-- from function IsCanonicalSignature
testIsCanonical :: Sig -> Bool
testIsCanonical sig =
not $
-- Non-canonical signature: too short
(len < 8)
||
-- Non-canonical signature: too long
(len > 72)
||
-- Non-canonical signature: wrong type
(BS.index s 0 /= 0x30)
||
-- Non-canonical signature: wrong length marker
(BS.index s 1 /= len - 2)
||
-- Non-canonical signature: S length misplaced
(5 + rlen >= len)
||
-- Non-canonical signature: R+S length mismatch
(rlen + slen + 6 /= len)
||
-- Non-canonical signature: R value type mismatch
(BS.index s 2 /= 0x02)
||
-- Non-canonical signature: R length is zero
(rlen == 0)
||
-- Non-canonical signature: R value negative
testBit (BS.index s 4) 7
||
-- Non-canonical signature: R value excessively padded
( rlen > 1
&& BS.index s 4 == 0
&& not (testBit (BS.index s 5) 7)
)
||
-- Non-canonical signature: S value type mismatch
(BS.index s (fromIntegral rlen + 4) /= 0x02)
||
-- Non-canonical signature: S length is zero
(slen == 0)
||
-- Non-canonical signature: S value negative
testBit (BS.index s (fromIntegral rlen + 6)) 7
||
-- Non-canonical signature: S value excessively padded
( slen > 1
&& BS.index s (fromIntegral rlen + 6) == 0
&& not (testBit (BS.index s (fromIntegral rlen + 7)) 7)
)
testIsCanonical :: Ctx -> Sig -> Bool
testIsCanonical ctx sig =
not $
-- Non-canonical signature: too short
(len < 8)
||
-- Non-canonical signature: too long
(len > 72)
||
-- Non-canonical signature: wrong type
(BS.index s 0 /= 0x30)
||
-- Non-canonical signature: wrong length marker
(BS.index s 1 /= len - 2)
||
-- Non-canonical signature: S length misplaced
(5 + rlen >= len)
||
-- Non-canonical signature: R+S length mismatch
(rlen + slen + 6 /= len)
||
-- Non-canonical signature: R value type mismatch
(BS.index s 2 /= 0x02)
||
-- Non-canonical signature: R length is zero
(rlen == 0)
||
-- Non-canonical signature: R value negative
testBit (BS.index s 4) 7
||
-- Non-canonical signature: R value excessively padded
( rlen > 1
&& BS.index s 4 == 0
&& not (testBit (BS.index s 5) 7)
)
||
-- Non-canonical signature: S value type mismatch
(BS.index s (fromIntegral rlen + 4) /= 0x02)
||
-- Non-canonical signature: S length is zero
(slen == 0)
||
-- Non-canonical signature: S value negative
testBit (BS.index s (fromIntegral rlen + 6)) 7
||
-- Non-canonical signature: S value excessively padded
( slen > 1
&& BS.index s (fromIntegral rlen + 6) == 0
&& not (testBit (BS.index s (fromIntegral rlen + 7)) 7)
)
where
s = exportSig sig
s = exportSig ctx sig
len = fromIntegral $ BS.length s
rlen = BS.index s 3
slen = BS.index s (fromIntegral rlen + 5)
@ -123,49 +131,46 @@ testIsCanonical sig =
-- between implementations. We check the output of signMsg 1 0
data ValidImpl
= ImplCore
| ImplABC
= ImplCore
| ImplCash
implSig :: Text
implSig =
encodeHex $
exportSig $
signMsg
"0000000000000000000000000000000000000000000000000000000000000001"
"0000000000000000000000000000000000000000000000000000000000000000"
implSig :: Ctx -> Text
implSig ctx =
encodeHex $
exportSig ctx $
signMsg
ctx
"0000000000000000000000000000000000000000000000000000000000000001"
"0000000000000000000000000000000000000000000000000000000000000000"
-- We have test vectors for these cases
validImplMap :: Map Text ValidImpl
validImplMap =
Map.fromList
[
( "3045022100a0b37f8fba683cc68f6574cd43b39f0343a50008bf6ccea9d13231\
\d9e7e2e1e4022011edc8d307254296264aebfc3dc76cd8b668373a072fd64665\
\b50000e9fcce52"
, ImplCore
)
,
( "304402200581361d23e645be9e3efe63a9a2ac2e8dd0c70ba3ac8554c9befe06\
\0ad0b36202207d8172f1e259395834793d81b17e986f1e6131e4734969d2f4ae\
\3a9c8bc42965"
, ImplABC
)
]
Map.fromList
[ ( "3045022100a0b37f8fba683cc68f6574cd43b39f0343a50008bf6ccea9d13231\
\d9e7e2e1e4022011edc8d307254296264aebfc3dc76cd8b668373a072fd64665\
\b50000e9fcce52",
ImplCore
),
( "304402200581361d23e645be9e3efe63a9a2ac2e8dd0c70ba3ac8554c9befe06\
\0ad0b36202207d8172f1e259395834793d81b17e986f1e6131e4734969d2f4ae\
\3a9c8bc42965",
ImplCash
)
]
getImpl :: Maybe ValidImpl
getImpl = implSig `Map.lookup` validImplMap
getImpl :: Ctx -> Maybe ValidImpl
getImpl ctx = implSig ctx `Map.lookup` validImplMap
rfc6979files :: ValidImpl -> (FilePath, FilePath)
rfc6979files ImplCore = ("rfc6979core.json", "rfc6979DERcore.json")
rfc6979files ImplABC = ("rfc6979abc.json", "rfc6979DERabc.json")
rfc6979files ImplCash = ("rfc6979cash.json", "rfc6979DERcash.json")
checkDistSig :: (FilePath -> FilePath -> Spec) -> Spec
checkDistSig go =
case rfc6979files <$> getImpl of
Just (file1, file2) -> go file1 file2
_ ->
it "Passes rfc6979 test vectors" $
void $ assertFailure "Invalid rfc6979 signature"
checkDistSig :: Ctx -> (FilePath -> FilePath -> Assertion) -> Assertion
checkDistSig ctx go =
case rfc6979files <$> getImpl ctx of
Just (file1, file2) -> go file1 file2
_ -> assertFailure "invalid RFC6979 signature"
{- Trezor RFC 6979 Test Vectors -}
-- github.com/trezor/python-ecdsa/blob/master/ecdsa/test_pyecdsa.py
@ -173,272 +178,272 @@ checkDistSig go =
toVector :: (Text, Text, Text) -> (SecKey, ByteString, Text)
toVector (prv, m, res) = (fromJust $ (secKey <=< decodeHex) prv, cs m, res)
testRFC6979Vector :: (SecKey, ByteString, Text) -> Assertion
testRFC6979Vector (prv, m, res) = do
assertEqual "RFC 6979 Vector" res (encodeHex $ encode $ exportCompactSig s)
assertBool "Signature is valid" $ verifyHashSig h s (derivePubKey prv)
assertBool "Signature is canonical" $ testIsCanonical s
assertBool "Signature is normalized" $ isCanonicalHalfOrder s
testRFC6979Vector :: Ctx -> (SecKey, ByteString, Text) -> Assertion
testRFC6979Vector ctx (prv, m, res) = do
assertEqual "RFC 6979 Vector" res (encodeHex (exportCompactSig ctx s).get)
assertBool "Signature is valid" $ verifyHashSig ctx h s (derivePubKey ctx prv)
assertBool "Signature is canonical" $ testIsCanonical ctx s
assertBool "Signature is normalized" $ isCanonicalHalfOrder ctx s
where
h = sha256 m
s = signHash prv h
s = signHash ctx prv h
-- Test vectors from:
-- https://crypto.stackexchange.com/questions/20838/request-for-data-to-test-deterministic-ecdsa-signature-algorithm-for-secp256k1
testRFC6979DERVector :: (SecKey, ByteString, Text) -> Assertion
testRFC6979DERVector (prv, m, res) = do
assertEqual "RFC 6979 DER Vector" res (encodeHex $ exportSig s)
assertBool "DER Signature is valid" $ verifyHashSig h s (derivePubKey prv)
assertBool "DER Signature is canonical" $ testIsCanonical s
assertBool "DER Signature is normalized" $ isCanonicalHalfOrder s
testRFC6979DERVector :: Ctx -> (SecKey, ByteString, Text) -> Assertion
testRFC6979DERVector ctx (prv, m, res) = do
assertEqual "RFC 6979 DER Vector" res (encodeHex $ exportSig ctx s)
assertBool "DER Signature is valid" $ verifyHashSig ctx h s (derivePubKey ctx prv)
assertBool "DER Signature is canonical" $ testIsCanonical ctx s
assertBool "DER Signature is normalized" $ isCanonicalHalfOrder ctx s
where
h = sha256 m
s = signHash prv h
s = signHash ctx prv h
-- Reproduce the P2WPKH example from BIP 143
testBip143p2wpkh :: Assertion
testBip143p2wpkh =
case getImpl of
Just ImplCore ->
assertEqual "BIP143 Core p2wpkh" (Right signedTxCore) generatedSignedTx
Just ImplABC ->
assertEqual "BIP143 ABC p2wpkh" (Right signedTxABC) generatedSignedTx
Nothing -> assertFailure "Invalid secp256k1 library"
testBip143p2wpkh :: Ctx -> Assertion
testBip143p2wpkh ctx =
case getImpl ctx of
Just ImplCore ->
assertEqual "BIP143 Core p2wpkh" (Right signedTxCore) generatedSignedTx
Just ImplCash ->
assertEqual "BIP143 ABC p2wpkh" (Right signedTxCash) generatedSignedTx
Nothing -> assertFailure "Invalid secp256k1 library"
where
signedTxCore =
"01000000000102fff7f7881a8099afa6940d42d1e7f6362bec38171ea3edf433\
\541db4e4ad969f00000000494830450221008b9d1dc26ba6a9cb62127b02742f\
\a9d754cd3bebf337f7a55d114c8e5cdd30be022040529b194ba3f9281a99f2b1\
\c0a19c0489bc22ede944ccf4ecbab4cc618ef3ed01eeffffffef51e1b804cc89\
\d182d279655c3aa89e815b1b309fe287d9b2b55d57b90ec68a0100000000ffff\
\ffff02202cb206000000001976a9148280b37df378db99f66f85c95a783a76ac\
\7a6d5988ac9093510d000000001976a9143bde42dbee7e4dbe6a21b2d50ce2f0\
\167faa815988ac000247304402203609e17b84f6a7d30c80bfa610b5b4542f32\
\a8a0d5447a12fb1366d7f01cc44a0220573a954c4518331561406f90300e8f33\
\58f51928d43c212a8caed02de67eebee0121025476c2e83188368da1ff3e292e\
\7acafcdb3566bb0ad253f62fc70f07aeee635711000000"
signedTxABC =
"01000000000102fff7f7881a8099afa6940d42d1e7f6362bec38171ea3edf433\
\541db4e4ad969f000000004847304402200fbc9dad97500334e47c2dca50096a\
\2117c01952c2870102e320823d21c36229022007cb36c2b141d11c08ef81d948\
\f148332fc09fe8f6d226aaaf8ba6ae0d8a66ba01eeffffffef51e1b804cc89d1\
\82d279655c3aa89e815b1b309fe287d9b2b55d57b90ec68a0100000000ffffff\
\ff02202cb206000000001976a9148280b37df378db99f66f85c95a783a76ac7a\
\6d5988ac9093510d000000001976a9143bde42dbee7e4dbe6a21b2d50ce2f016\
\7faa815988ac0002473044022011cb891cee521eb1fc7aef681655a881288553\
\fc024cff9cee5007bae5e6b8c602200b89d60ee2f98aa9a645dad59cd680b4b6\
\25f343efcd3e7fb70852100ef601890121025476c2e83188368da1ff3e292e7a\
\cafcdb3566bb0ad253f62fc70f07aeee635711000000"
"01000000000102fff7f7881a8099afa6940d42d1e7f6362bec38171ea3edf433\
\541db4e4ad969f00000000494830450221008b9d1dc26ba6a9cb62127b02742f\
\a9d754cd3bebf337f7a55d114c8e5cdd30be022040529b194ba3f9281a99f2b1\
\c0a19c0489bc22ede944ccf4ecbab4cc618ef3ed01eeffffffef51e1b804cc89\
\d182d279655c3aa89e815b1b309fe287d9b2b55d57b90ec68a0100000000ffff\
\ffff02202cb206000000001976a9148280b37df378db99f66f85c95a783a76ac\
\7a6d5988ac9093510d000000001976a9143bde42dbee7e4dbe6a21b2d50ce2f0\
\167faa815988ac000247304402203609e17b84f6a7d30c80bfa610b5b4542f32\
\a8a0d5447a12fb1366d7f01cc44a0220573a954c4518331561406f90300e8f33\
\58f51928d43c212a8caed02de67eebee0121025476c2e83188368da1ff3e292e\
\7acafcdb3566bb0ad253f62fc70f07aeee635711000000"
signedTxCash =
"01000000000102fff7f7881a8099afa6940d42d1e7f6362bec38171ea3edf433\
\541db4e4ad969f000000004847304402200fbc9dad97500334e47c2dca50096a\
\2117c01952c2870102e320823d21c36229022007cb36c2b141d11c08ef81d948\
\f148332fc09fe8f6d226aaaf8ba6ae0d8a66ba01eeffffffef51e1b804cc89d1\
\82d279655c3aa89e815b1b309fe287d9b2b55d57b90ec68a0100000000ffffff\
\ff02202cb206000000001976a9148280b37df378db99f66f85c95a783a76ac7a\
\6d5988ac9093510d000000001976a9143bde42dbee7e4dbe6a21b2d50ce2f016\
\7faa815988ac0002473044022011cb891cee521eb1fc7aef681655a881288553\
\fc024cff9cee5007bae5e6b8c602200b89d60ee2f98aa9a645dad59cd680b4b6\
\25f343efcd3e7fb70852100ef601890121025476c2e83188368da1ff3e292e7a\
\cafcdb3566bb0ad253f62fc70f07aeee635711000000"
unsignedTx =
"0100000002fff7f7881a8099afa6940d42d1e7f6362bec38171ea3edf433541d\
\b4e4ad969f0000000000eeffffffef51e1b804cc89d182d279655c3aa89e815b\
\1b309fe287d9b2b55d57b90ec68a0100000000ffffffff02202cb20600000000\
\1976a9148280b37df378db99f66f85c95a783a76ac7a6d5988ac9093510d0000\
\00001976a9143bde42dbee7e4dbe6a21b2d50ce2f0167faa815988ac11000000"
"0100000002fff7f7881a8099afa6940d42d1e7f6362bec38171ea3edf433541d\
\b4e4ad969f0000000000eeffffffef51e1b804cc89d182d279655c3aa89e815b\
\1b309fe287d9b2b55d57b90ec68a0100000000ffffffff02202cb20600000000\
\1976a9148280b37df378db99f66f85c95a783a76ac7a6d5988ac9093510d0000\
\00001976a9143bde42dbee7e4dbe6a21b2d50ce2f0167faa815988ac11000000"
Just key0 =
secHexKey
"bbc27228ddcb9209d7fd6f36b02f7dfa6252af40bb2f1cbc7a557da8027ff866"
pubKey0 = toPubKey key0
secHexKey
"bbc27228ddcb9209d7fd6f36b02f7dfa6252af40bb2f1cbc7a557da8027ff866"
pubKey0 = toPubKey ctx key0
Just key1 =
secHexKey
"619c335025c7f4012e556c2a58b2506e30b8511b53ade95ea316fd8c3286feb9"
[op0, op1] = prevOutput <$> txIn unsignedTx
secHexKey
"619c335025c7f4012e556c2a58b2506e30b8511b53ade95ea316fd8c3286feb9"
[op0, op1] = (.outpoint) <$> unsignedTx.inputs
sigIn0 = SigInput (PayPK pubKey0) 625000000 op0 sigHashAll Nothing
WitnessPubKeyAddress h = pubKeyWitnessAddr $ toPubKey key1
WitnessPubKeyAddress h = pubKeyWitnessAddr ctx $ toPubKey ctx key1
sigIn1 = SigInput (PayWitnessPKHash h) 600000000 op1 sigHashAll Nothing
generatedSignedTx = signTx btc unsignedTx [sigIn0, sigIn1] [key0, key1]
generatedSignedTx = signTx btc ctx unsignedTx [sigIn0, sigIn1] [key0, key1]
-- Reproduce the P2SH-P2WPKH example from BIP 143
testBip143p2shp2wpkh :: Assertion
testBip143p2shp2wpkh =
case getImpl of
Just ImplCore ->
assertEqual "BIP143 Core p2sh-p2wpkh" (Right signedTxCore) generatedSignedTx
Just ImplABC ->
assertEqual "BIP143 ABC p2sh-p2wpkh" (Right signedTxABC) generatedSignedTx
Nothing -> assertFailure "Invalid secp256k1 library"
testBip143p2shp2wpkh :: Ctx -> Assertion
testBip143p2shp2wpkh ctx =
case getImpl ctx of
Just ImplCore ->
assertEqual "BIP143 Core p2sh-p2wpkh" (Right signedTxCore) generatedSignedTx
Just ImplCash ->
assertEqual "BIP143 Cash p2sh-p2wpkh" (Right signedTxCash) generatedSignedTx
Nothing -> assertFailure "Invalid secp256k1 library"
where
signedTxCore =
"01000000000101db6b1b20aa0fd7b23880be2ecbd4a98130974cf4748fb66092\
\ac4d3ceb1a5477010000001716001479091972186c449eb1ded22b78e40d009b\
\df0089feffffff02b8b4eb0b000000001976a914a457b684d7f0d539a46a45bb\
\c043f35b59d0d96388ac0008af2f000000001976a914fd270b1ee6abcaea97fe\
\a7ad0402e8bd8ad6d77c88ac02473044022047ac8e878352d3ebbde1c94ce3a1\
\0d057c24175747116f8288e5d794d12d482f0220217f36a485cae903c713331d\
\877c1f64677e3622ad4010726870540656fe9dcb012103ad1d8e89212f0b92c7\
\4d23bb710c00662ad1470198ac48c43f7d6f93a2a2687392040000"
signedTxABC =
"01000000000101db6b1b20aa0fd7b23880be2ecbd4a98130974cf4748fb66092\
\ac4d3ceb1a5477010000001716001479091972186c449eb1ded22b78e40d009b\
\df0089feffffff02b8b4eb0b000000001976a914a457b684d7f0d539a46a45bb\
\c043f35b59d0d96388ac0008af2f000000001976a914fd270b1ee6abcaea97fe\
\a7ad0402e8bd8ad6d77c88ac024730440220091c78fd1e21535f6ddc45515e4c\
\afca15cdf344765d72c1529fb82d3ada2d1802204a980d5e37d0b04f5e1185a0\
\f97295c383764e9a4b08d8bd1161b33c6719139a012103ad1d8e89212f0b92c7\
\4d23bb710c00662ad1470198ac48c43f7d6f93a2a2687392040000"
"01000000000101db6b1b20aa0fd7b23880be2ecbd4a98130974cf4748fb66092\
\ac4d3ceb1a5477010000001716001479091972186c449eb1ded22b78e40d009b\
\df0089feffffff02b8b4eb0b000000001976a914a457b684d7f0d539a46a45bb\
\c043f35b59d0d96388ac0008af2f000000001976a914fd270b1ee6abcaea97fe\
\a7ad0402e8bd8ad6d77c88ac02473044022047ac8e878352d3ebbde1c94ce3a1\
\0d057c24175747116f8288e5d794d12d482f0220217f36a485cae903c713331d\
\877c1f64677e3622ad4010726870540656fe9dcb012103ad1d8e89212f0b92c7\
\4d23bb710c00662ad1470198ac48c43f7d6f93a2a2687392040000"
signedTxCash =
"01000000000101db6b1b20aa0fd7b23880be2ecbd4a98130974cf4748fb66092\
\ac4d3ceb1a5477010000001716001479091972186c449eb1ded22b78e40d009b\
\df0089feffffff02b8b4eb0b000000001976a914a457b684d7f0d539a46a45bb\
\c043f35b59d0d96388ac0008af2f000000001976a914fd270b1ee6abcaea97fe\
\a7ad0402e8bd8ad6d77c88ac024730440220091c78fd1e21535f6ddc45515e4c\
\afca15cdf344765d72c1529fb82d3ada2d1802204a980d5e37d0b04f5e1185a0\
\f97295c383764e9a4b08d8bd1161b33c6719139a012103ad1d8e89212f0b92c7\
\4d23bb710c00662ad1470198ac48c43f7d6f93a2a2687392040000"
unsignedTx =
"0100000001db6b1b20aa0fd7b23880be2ecbd4a98130974cf4748fb66092ac4d\
\3ceb1a54770100000000feffffff02b8b4eb0b000000001976a914a457b684d7\
\f0d539a46a45bbc043f35b59d0d96388ac0008af2f000000001976a914fd270b\
\1ee6abcaea97fea7ad0402e8bd8ad6d77c88ac92040000"
"0100000001db6b1b20aa0fd7b23880be2ecbd4a98130974cf4748fb66092ac4d\
\3ceb1a54770100000000feffffff02b8b4eb0b000000001976a914a457b684d7\
\f0d539a46a45bbc043f35b59d0d96388ac0008af2f000000001976a914fd270b\
\1ee6abcaea97fea7ad0402e8bd8ad6d77c88ac92040000"
Just key0 =
secHexKey
"eb696a065ef48a2192da5b28b694f87544b30fae8327c4510137a922f32c6dcf"
op0 = prevOutput . head $ txIn unsignedTx
WitnessPubKeyAddress h = pubKeyWitnessAddr $ toPubKey key0
secHexKey
"eb696a065ef48a2192da5b28b694f87544b30fae8327c4510137a922f32c6dcf"
op0 = (head unsignedTx.inputs).outpoint
WitnessPubKeyAddress h = pubKeyWitnessAddr ctx $ toPubKey ctx key0
sigIn0 = SigInput (PayWitnessPKHash h) 1000000000 op0 sigHashAll Nothing
generatedSignedTx = signNestedWitnessTx btc unsignedTx [sigIn0] [key0]
generatedSignedTx = signNestedWitnessTx btc ctx unsignedTx [sigIn0] [key0]
-- P2WSH multisig example (tested against bitcoin-core 0.19.0.1)
testP2WSHMulsig :: Assertion
testP2WSHMulsig =
case getImpl of
Just ImplCore ->
assertEqual "Core p2wsh multisig" (Right signedTxCore) generatedSignedTx
Just ImplABC ->
assertEqual "ABC p2wsh multisig" (Right signedTxABC) generatedSignedTx
Nothing -> assertFailure "Invalid secp256k1 library"
testP2WSHMulsig :: Ctx -> Assertion
testP2WSHMulsig ctx =
case getImpl ctx of
Just ImplCore ->
assertEqual "Core p2wsh multisig" (Right signedTxCore) generatedSignedTx
Just ImplCash ->
assertEqual "Cash p2wsh multisig" (Right signedTxCash) generatedSignedTx
Nothing -> assertFailure "Invalid secp256k1 library"
where
signedTxCore =
"01000000000101d2e34df5d7ee565208eddd231548916b9b0e99f4f5071f8961\
\34a448c5fb07bf0100000000ffffffff01f0b9f505000000001976a9143d5a35\
\2cab583b12fbcb26d1269b4a2c951a33ad88ac0400483045022100fad4fedd2b\
\b4c439c64637eb8e9150d9020a7212808b8dc0578d5ff5b4ad65fe0220714640\
\f261b37eb3106310bf853f4b706e51436fb6b64c2ab00768814eb55b98014730\
\44022100baff4e4ceea4022b9725a2e6f6d77997a554f858165b91ac8c16c983\
\3008bee9021f5f70ebc3f8580dc0a5e96451e3697bdf1f1f5883944f0f33ab0c\
\fb272354040169522102ba46d3bb8db74c77c6cf082db57fc0548058fcdea811\
\549e186526e3d10caf6721038ac8aef2dd9cea5e7d66e2f6e23f177a6c21f69e\
\a311fa0c85d81badb6b37ceb2103d96d2bfbbc040faaf93491d69e2bfe9695e2\
\d8e007a7f26db96c2ee42db15dc953ae00000000"
signedTxABC =
"01000000000101d2e34df5d7ee565208eddd231548916b9b0e99f4f5071f8961\
\34a448c5fb07bf0100000000ffffffff01f0b9f505000000001976a9143d5a35\
\2cab583b12fbcb26d1269b4a2c951a33ad88ac0400483045022100b79bf3714a\
\50f8f0e2f946034361ba4f6567b796d55910d89e98720d2e99f98c0220134879\
\518002df23e80a058475fa8b10bc4182bedfecd5f85e446a00f211ea53014830\
\45022100ce3c77480d664430a7544c1a962d1ae31151109a528a37e5bccc92ba\
\2e460ad10220317bc9a71d0c3471058d16d4c3b1ea99616208db6b9b9040fb81\
\0a7fa27f72b40169522102ba46d3bb8db74c77c6cf082db57fc0548058fcdea8\
\11549e186526e3d10caf6721038ac8aef2dd9cea5e7d66e2f6e23f177a6c21f6\
\9ea311fa0c85d81badb6b37ceb2103d96d2bfbbc040faaf93491d69e2bfe9695\
\e2d8e007a7f26db96c2ee42db15dc953ae00000000"
"01000000000101d2e34df5d7ee565208eddd231548916b9b0e99f4f5071f8961\
\34a448c5fb07bf0100000000ffffffff01f0b9f505000000001976a9143d5a35\
\2cab583b12fbcb26d1269b4a2c951a33ad88ac0400483045022100fad4fedd2b\
\b4c439c64637eb8e9150d9020a7212808b8dc0578d5ff5b4ad65fe0220714640\
\f261b37eb3106310bf853f4b706e51436fb6b64c2ab00768814eb55b98014730\
\44022100baff4e4ceea4022b9725a2e6f6d77997a554f858165b91ac8c16c983\
\3008bee9021f5f70ebc3f8580dc0a5e96451e3697bdf1f1f5883944f0f33ab0c\
\fb272354040169522102ba46d3bb8db74c77c6cf082db57fc0548058fcdea811\
\549e186526e3d10caf6721038ac8aef2dd9cea5e7d66e2f6e23f177a6c21f69e\
\a311fa0c85d81badb6b37ceb2103d96d2bfbbc040faaf93491d69e2bfe9695e2\
\d8e007a7f26db96c2ee42db15dc953ae00000000"
signedTxCash =
"01000000000101d2e34df5d7ee565208eddd231548916b9b0e99f4f5071f8961\
\34a448c5fb07bf0100000000ffffffff01f0b9f505000000001976a9143d5a35\
\2cab583b12fbcb26d1269b4a2c951a33ad88ac0400483045022100b79bf3714a\
\50f8f0e2f946034361ba4f6567b796d55910d89e98720d2e99f98c0220134879\
\518002df23e80a058475fa8b10bc4182bedfecd5f85e446a00f211ea53014830\
\45022100ce3c77480d664430a7544c1a962d1ae31151109a528a37e5bccc92ba\
\2e460ad10220317bc9a71d0c3471058d16d4c3b1ea99616208db6b9b9040fb81\
\0a7fa27f72b40169522102ba46d3bb8db74c77c6cf082db57fc0548058fcdea8\
\11549e186526e3d10caf6721038ac8aef2dd9cea5e7d66e2f6e23f177a6c21f6\
\9ea311fa0c85d81badb6b37ceb2103d96d2bfbbc040faaf93491d69e2bfe9695\
\e2d8e007a7f26db96c2ee42db15dc953ae00000000"
unsignedTx =
"0100000001d2e34df5d7ee565208eddd231548916b9b0e99f4f5071f896134a4\
\48c5fb07bf0100000000ffffffff01f0b9f505000000001976a9143d5a352cab\
\583b12fbcb26d1269b4a2c951a33ad88ac00000000"
op0 = head $ prevOutput <$> txIn unsignedTx
"0100000001d2e34df5d7ee565208eddd231548916b9b0e99f4f5071f896134a4\
\48c5fb07bf0100000000ffffffff01f0b9f505000000001976a9143d5a352cab\
\583b12fbcb26d1269b4a2c951a33ad88ac00000000"
op0 = (head unsignedTx.inputs).outpoint
Just keys =
traverse
secHexKey
[ "3030303030303030303030303030303030303030303030303030303030303031"
, "3030303030303030303030303030303030303030303030303030303030303032"
, "3030303030303030303030303030303030303030303030303030303030303033"
]
rdm = PayMulSig (toPubKey <$> keys) 2
traverse
secHexKey
[ "3030303030303030303030303030303030303030303030303030303030303031",
"3030303030303030303030303030303030303030303030303030303030303032",
"3030303030303030303030303030303030303030303030303030303030303033"
]
rdm = PayMulSig (toPubKey ctx <$> keys) 2
sigIn =
SigInput
(toP2WSH $ encodeOutput rdm)
100000000
op0
sigHashAll
(Just rdm)
generatedSignedTx = signTx btc unsignedTx [sigIn] (take 2 keys)
SigInput
(toP2WSH $ encodeOutput ctx rdm)
100000000
op0
sigHashAll
(Just rdm)
generatedSignedTx = signTx btc ctx unsignedTx [sigIn] (take 2 keys)
-- Reproduce the P2SH-P2WSH multisig example from BIP 143
testBip143p2shp2wpkhMulsig :: Assertion
testBip143p2shp2wpkhMulsig =
case getImpl of
Just ImplCore ->
assertEqual
"BIP143 Core p2sh-p2wsh multisig"
(Right signedTxCore)
generatedSignedTx
Just ImplABC ->
assertEqual
"BIP143 Core p2sh-p2wsh multisig"
(Right signedTxABC)
generatedSignedTx
Nothing -> assertFailure "Invalid secp256k1 library"
testBip143p2shp2wpkhMulsig :: Ctx -> Assertion
testBip143p2shp2wpkhMulsig ctx =
case getImpl ctx of
Just ImplCore ->
assertEqual
"BIP143 Core p2sh-p2wsh multisig"
(Right signedTxCore)
generatedSignedTx
Just ImplCash ->
assertEqual
"BIP143 Core p2sh-p2wsh multisig"
(Right signedTxCash)
generatedSignedTx
Nothing -> assertFailure "Invalid secp256k1 library"
where
signedTxCore =
"0100000000010136641869ca081e70f394c6948e8af409e18b619df2ed74aa10\
\6c1ca29787b96e0100000023220020a16b5755f7f6f96dbd65f5f0d6ab9418b8\
\9af4b1f14a1bb8a09062c35f0dcb54ffffffff0200e9a435000000001976a914\
\389ffce9cd9ae88dcc0631e88a821ffdbe9bfe2688acc0832f05000000001976\
\a9147480a33f950689af511e6e84c138dbbd3c3ee41588ac080047304402206a\
\c44d672dac41f9b00e28f4df20c52eeb087207e8d758d76d92c6fab3b73e2b02\
\20367750dbbe19290069cba53d096f44530e4f98acaa594810388cf7409a1870\
\ce01473044022068c7946a43232757cbdf9176f009a928e1cd9a1a8c212f15c1\
\e11ac9f2925d9002205b75f937ff2f9f3c1246e547e54f62e027f64eefa26955\
\78cc6432cdabce271502473044022059ebf56d98010a932cf8ecfec54c48e613\
\9ed6adb0728c09cbe1e4fa0915302e022007cd986c8fa870ff5d2b3a89139c9f\
\e7e499259875357e20fcbb15571c76795403483045022100fbefd94bd0a488d5\
\0b79102b5dad4ab6ced30c4069f1eaa69a4b5a763414067e02203156c6a5c9cf\
\88f91265f5a942e96213afae16d83321c8b31bb342142a14d163814830450221\
\00a5263ea0553ba89221984bd7f0b13613db16e7a70c549a86de0cc0444141a4\
\07022005c360ef0ae5a5d4f9f2f87a56c1546cc8268cab08c73501d6b3be2e1e\
\1a8a08824730440220525406a1482936d5a21888260dc165497a90a15669636d\
\8edca6b9fe490d309c022032af0c646a34a44d1f4576bf6a4a74b67940f8faa8\
\4c7df9abe12a01a11e2b4783cf56210307b8ae49ac90a048e9b53357a2354b33\
\34e9c8bee813ecb98e99a7e07e8c3ba32103b28f0c28bfab54554ae8c658ac5c\
\3e0ce6e79ad336331f78c428dd43eea8449b21034b8113d703413d57761b8b97\
\81957b8c0ac1dfe69f492580ca4195f50376ba4a21033400f6afecb833092a9a\
\21cfdf1ed1376e58c5d1f47de74683123987e967a8f42103a6d48b1131e94ba0\
\4d9737d61acdaa1322008af9602b3b14862c07a1789aac162102d8b661b0b330\
\2ee2f162b09e07a55ad5dfbe673a9f01d9f0c19617681024306b56ae00000000"
signedTxABC =
"0100000000010136641869ca081e70f394c6948e8af409e18b619df2ed74aa10\
\6c1ca29787b96e0100000023220020a16b5755f7f6f96dbd65f5f0d6ab9418b8\
\9af4b1f14a1bb8a09062c35f0dcb54ffffffff0200e9a435000000001976a914\
\389ffce9cd9ae88dcc0631e88a821ffdbe9bfe2688acc0832f05000000001976\
\a9147480a33f950689af511e6e84c138dbbd3c3ee41588ac0800483045022100\
\b70b684ef0d17b51adf71c0dae932beca5d447dd5eec03394328436bdba836e7\
\0220208ebfd7408d21e41da11d8287655528385429d3fe300bee241f10944339\
\5b580147304402204b5f9bc06c8f0a252b9842ea44785853beb1638002cec5f2\
\489d73e5f6f5109302204f3b132b32638835d4b1a651e7d18dc93c10192db553\
\999932af6a8e3d8a153202483045022100e0ed8d3a245a138c751d74e1359aee\
\6a52476ddf33a3a9a5f0c2ad30147319650220581318187061ad0f48fc4f5c85\
\1822e554d59977005b8de4b78bf2ce2fe8399703483045022100a0a40abc581e\
\4b725775a3aa93bf0f0fd9a02ad3aa0f93483214784a47ba5387022069151c30\
\f85a7e20c8671107c5af884ee4c5a82bd06398327fa68a993f7cc64b81473044\
\022016d828460f6fab3cf89ae4b87c8f02c11c798cf739967f3b7406e7367c29\
\ae8b022079e82b822eb6c37a66efabc3f0b40a2b98c52f848d36463f6623cbdc\
\fe675812824730440220225a14ba7434858dbb5e6e0a0969ddf3b5455edaabf9\
\9f5773d1f59e7816b918022047ed1ab87840a74f7e9489f3af051e5fd26b790f\
\b308c79f4b0ed73c0422795d83cf56210307b8ae49ac90a048e9b53357a2354b\
\3334e9c8bee813ecb98e99a7e07e8c3ba32103b28f0c28bfab54554ae8c658ac\
\5c3e0ce6e79ad336331f78c428dd43eea8449b21034b8113d703413d57761b8b\
\9781957b8c0ac1dfe69f492580ca4195f50376ba4a21033400f6afecb833092a\
\9a21cfdf1ed1376e58c5d1f47de74683123987e967a8f42103a6d48b1131e94b\
\a04d9737d61acdaa1322008af9602b3b14862c07a1789aac162102d8b661b0b3\
\302ee2f162b09e07a55ad5dfbe673a9f01d9f0c19617681024306b56ae00000000"
"0100000000010136641869ca081e70f394c6948e8af409e18b619df2ed74aa10\
\6c1ca29787b96e0100000023220020a16b5755f7f6f96dbd65f5f0d6ab9418b8\
\9af4b1f14a1bb8a09062c35f0dcb54ffffffff0200e9a435000000001976a914\
\389ffce9cd9ae88dcc0631e88a821ffdbe9bfe2688acc0832f05000000001976\
\a9147480a33f950689af511e6e84c138dbbd3c3ee41588ac080047304402206a\
\c44d672dac41f9b00e28f4df20c52eeb087207e8d758d76d92c6fab3b73e2b02\
\20367750dbbe19290069cba53d096f44530e4f98acaa594810388cf7409a1870\
\ce01473044022068c7946a43232757cbdf9176f009a928e1cd9a1a8c212f15c1\
\e11ac9f2925d9002205b75f937ff2f9f3c1246e547e54f62e027f64eefa26955\
\78cc6432cdabce271502473044022059ebf56d98010a932cf8ecfec54c48e613\
\9ed6adb0728c09cbe1e4fa0915302e022007cd986c8fa870ff5d2b3a89139c9f\
\e7e499259875357e20fcbb15571c76795403483045022100fbefd94bd0a488d5\
\0b79102b5dad4ab6ced30c4069f1eaa69a4b5a763414067e02203156c6a5c9cf\
\88f91265f5a942e96213afae16d83321c8b31bb342142a14d163814830450221\
\00a5263ea0553ba89221984bd7f0b13613db16e7a70c549a86de0cc0444141a4\
\07022005c360ef0ae5a5d4f9f2f87a56c1546cc8268cab08c73501d6b3be2e1e\
\1a8a08824730440220525406a1482936d5a21888260dc165497a90a15669636d\
\8edca6b9fe490d309c022032af0c646a34a44d1f4576bf6a4a74b67940f8faa8\
\4c7df9abe12a01a11e2b4783cf56210307b8ae49ac90a048e9b53357a2354b33\
\34e9c8bee813ecb98e99a7e07e8c3ba32103b28f0c28bfab54554ae8c658ac5c\
\3e0ce6e79ad336331f78c428dd43eea8449b21034b8113d703413d57761b8b97\
\81957b8c0ac1dfe69f492580ca4195f50376ba4a21033400f6afecb833092a9a\
\21cfdf1ed1376e58c5d1f47de74683123987e967a8f42103a6d48b1131e94ba0\
\4d9737d61acdaa1322008af9602b3b14862c07a1789aac162102d8b661b0b330\
\2ee2f162b09e07a55ad5dfbe673a9f01d9f0c19617681024306b56ae00000000"
signedTxCash =
"0100000000010136641869ca081e70f394c6948e8af409e18b619df2ed74aa10\
\6c1ca29787b96e0100000023220020a16b5755f7f6f96dbd65f5f0d6ab9418b8\
\9af4b1f14a1bb8a09062c35f0dcb54ffffffff0200e9a435000000001976a914\
\389ffce9cd9ae88dcc0631e88a821ffdbe9bfe2688acc0832f05000000001976\
\a9147480a33f950689af511e6e84c138dbbd3c3ee41588ac0800483045022100\
\b70b684ef0d17b51adf71c0dae932beca5d447dd5eec03394328436bdba836e7\
\0220208ebfd7408d21e41da11d8287655528385429d3fe300bee241f10944339\
\5b580147304402204b5f9bc06c8f0a252b9842ea44785853beb1638002cec5f2\
\489d73e5f6f5109302204f3b132b32638835d4b1a651e7d18dc93c10192db553\
\999932af6a8e3d8a153202483045022100e0ed8d3a245a138c751d74e1359aee\
\6a52476ddf33a3a9a5f0c2ad30147319650220581318187061ad0f48fc4f5c85\
\1822e554d59977005b8de4b78bf2ce2fe8399703483045022100a0a40abc581e\
\4b725775a3aa93bf0f0fd9a02ad3aa0f93483214784a47ba5387022069151c30\
\f85a7e20c8671107c5af884ee4c5a82bd06398327fa68a993f7cc64b81473044\
\022016d828460f6fab3cf89ae4b87c8f02c11c798cf739967f3b7406e7367c29\
\ae8b022079e82b822eb6c37a66efabc3f0b40a2b98c52f848d36463f6623cbdc\
\fe675812824730440220225a14ba7434858dbb5e6e0a0969ddf3b5455edaabf9\
\9f5773d1f59e7816b918022047ed1ab87840a74f7e9489f3af051e5fd26b790f\
\b308c79f4b0ed73c0422795d83cf56210307b8ae49ac90a048e9b53357a2354b\
\3334e9c8bee813ecb98e99a7e07e8c3ba32103b28f0c28bfab54554ae8c658ac\
\5c3e0ce6e79ad336331f78c428dd43eea8449b21034b8113d703413d57761b8b\
\9781957b8c0ac1dfe69f492580ca4195f50376ba4a21033400f6afecb833092a\
\9a21cfdf1ed1376e58c5d1f47de74683123987e967a8f42103a6d48b1131e94b\
\a04d9737d61acdaa1322008af9602b3b14862c07a1789aac162102d8b661b0b3\
\302ee2f162b09e07a55ad5dfbe673a9f01d9f0c19617681024306b56ae00000000"
unsignedTx =
"010000000136641869ca081e70f394c6948e8af409e18b619df2ed74aa106c1c\
\a29787b96e0100000000ffffffff0200e9a435000000001976a914389ffce9cd\
\9ae88dcc0631e88a821ffdbe9bfe2688acc0832f05000000001976a9147480a3\
\3f950689af511e6e84c138dbbd3c3ee41588ac00000000"
op0 = head $ prevOutput <$> txIn unsignedTx
"010000000136641869ca081e70f394c6948e8af409e18b619df2ed74aa106c1c\
\a29787b96e0100000000ffffffff0200e9a435000000001976a914389ffce9cd\
\9ae88dcc0631e88a821ffdbe9bfe2688acc0832f05000000001976a9147480a3\
\3f950689af511e6e84c138dbbd3c3ee41588ac00000000"
op0 = (head unsignedTx.inputs).outpoint
rawKeys =
[ "730fff80e1413068a05b57d6a58261f07551163369787f349438ea38ca80fac6"
, "11fa3d25a17cbc22b29c44a484ba552b5a53149d106d3d853e22fdd05a2d8bb3"
, "77bf4141a87d55bdd7f3cd0bdccf6e9e642935fec45f2f30047be7b799120661"
, "14af36970f5025ea3e8b5542c0f8ebe7763e674838d08808896b63c3351ffe49"
, "fe9a95c19eef81dde2b95c1284ef39be497d128e2aa46916fb02d552485e0323"
, "428a7aee9f0c2af0cd19af3cf1c78149951ea528726989b2e83e4778d2c3f890"
]
[ "730fff80e1413068a05b57d6a58261f07551163369787f349438ea38ca80fac6",
"11fa3d25a17cbc22b29c44a484ba552b5a53149d106d3d853e22fdd05a2d8bb3",
"77bf4141a87d55bdd7f3cd0bdccf6e9e642935fec45f2f30047be7b799120661",
"14af36970f5025ea3e8b5542c0f8ebe7763e674838d08808896b63c3351ffe49",
"fe9a95c19eef81dde2b95c1284ef39be497d128e2aa46916fb02d552485e0323",
"428a7aee9f0c2af0cd19af3cf1c78149951ea528726989b2e83e4778d2c3f890"
]
Just keys = traverse secHexKey rawKeys
rdm = PayMulSig (toPubKey <$> keys) 6
sigIn sh = SigInput (toP2WSH $ encodeOutput rdm) 987654321 op0 sh (Just rdm)
rdm = PayMulSig (toPubKey ctx <$> keys) 6
sigIn sh = SigInput (toP2WSH $ encodeOutput ctx rdm) 987654321 op0 sh (Just rdm)
sigHashesA = [sigHashAll, sigHashNone, sigHashSingle]
sigHashesB = setAnyoneCanPayFlag <$> sigHashesA
sigHashesB = setAnyoneCanPay <$> sigHashesA
sigIns = sigIn <$> (sigHashesA <> sigHashesB)
generatedSignedTx = foldM addSig unsignedTx $ zip sigIns keys
addSig tx (sigIn', key') = signNestedWitnessTx btc tx [sigIn'] [key']
addSig tx (sigIn', key') = signNestedWitnessTx btc ctx tx [sigIn'] [key']
secHexKey :: Text -> Maybe SecKey
secHexKey = decodeHex >=> secKey
toPubKey :: SecKey -> PubKeyI
toPubKey = derivePubKeyI . wrapSecKey True
toPubKey :: Ctx -> SecKey -> PublicKey
toPubKey ctx = derivePublicKey ctx . wrapSecKey True

621
test/Haskoin/Keys/ExtendedSpec.hs
View File

@ -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"
]
]

498
test/Haskoin/Keys/MnemonicSpec.hs
View File

@ -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

266
test/Haskoin/KeysSpec.hs
View File

@ -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

230
test/Haskoin/NetworkSpec.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
module Haskoin.NetworkSpec (spec) where
@ -9,13 +11,12 @@ import Data.Maybe (fromJust)
import Data.Text (Text)
import Data.Word (Word32)
import Haskoin.Address
import Haskoin.Constants
import Haskoin.Keys
import Haskoin.Crypto
import Haskoin.Network
import Haskoin.Network.Constants
import Haskoin.Transaction
import Haskoin.Util
import Haskoin.Util.Arbitrary
import Haskoin.UtilSpec (customCerealID)
import Test.HUnit (Assertion, assertBool, assertEqual)
import Test.Hspec
import Test.Hspec.QuickCheck
@ -23,54 +24,55 @@ import Test.QuickCheck
serialVals :: [SerialBox]
serialVals =
[ SerialBox arbitraryVarInt
, SerialBox arbitraryVarString
, SerialBox arbitraryNetworkAddress
, SerialBox arbitraryInvType
, SerialBox arbitraryInvVector
, SerialBox arbitraryInv1
, SerialBox arbitraryVersion
, SerialBox arbitraryAddr1
, SerialBox arbitraryAlert
, SerialBox arbitraryReject
, SerialBox arbitraryRejectCode
, SerialBox arbitraryGetData
, SerialBox arbitraryNotFound
, SerialBox arbitraryPing
, SerialBox arbitraryPong
, SerialBox arbitraryMessageCommand
, SerialBox arbitraryMessageHeader
, SerialBox arbitraryBloomFlags
, SerialBox arbitraryBloomFilter
, SerialBox arbitraryFilterLoad
, SerialBox arbitraryFilterAdd
]
[ SerialBox arbitraryVarInt,
SerialBox arbitraryVarString,
SerialBox arbitraryNetworkAddress,
SerialBox arbitraryInvType,
SerialBox arbitraryInvVector,
SerialBox arbitraryInv1,
SerialBox arbitraryVersion,
SerialBox arbitraryAddr1,
SerialBox arbitraryAlert,
SerialBox arbitraryReject,
SerialBox arbitraryRejectCode,
SerialBox arbitraryGetData,
SerialBox arbitraryNotFound,
SerialBox arbitraryPing,
SerialBox arbitraryPong,
SerialBox arbitraryMessageCommand,
SerialBox arbitraryMessageHeader,
SerialBox arbitraryBloomFlags,
SerialBox arbitraryBloomFilter,
SerialBox arbitraryFilterLoad,
SerialBox arbitraryFilterAdd
]
spec :: Spec
spec = do
testIdentity serialVals [] [] []
describe "Custom identity tests" $ do
prop "Data.Serialize Encoding for type Message" $
forAll arbitraryNetwork $ \net ->
forAll (arbitraryMessage net) $
customCerealID (getMessage net) (putMessage net)
describe "bloom filters" $ do
it "bloom filter vector 1" bloomFilter1
it "bloom filter vector 2" bloomFilter2
it "bloom filter vector 3" bloomFilter3
describe "relevant bloom filter update" $ do
it "Relevant Update" relevantOutputUpdated
it "Irrelevant Update" irrelevantOutputNotUpdated
spec = prepareContext $ \ctx -> do
testIdentity serialVals [] [] []
describe "Custom identity tests" $ do
prop "Data.Serialize Encoding for type Message" $
forAll arbitraryNetwork $ \net ->
forAll (arbitraryMessage net ctx) $
customCerealID (getMessage net) (putMessage net)
describe "bloom filters" $ do
it "bloom filter vector 1" bloomFilter1
it "bloom filter vector 2" bloomFilter2
it "bloom filter vector 3" $ bloomFilter3 ctx
describe "relevant bloom filter update" $ do
it "Relevant Update" $ relevantOutputUpdated ctx
it "Irrelevant Update" $ irrelevantOutputNotUpdated ctx
bloomFilter :: Word32 -> Text -> Assertion
bloomFilter n x = do
assertBool "Bloom filter doesn't contain vector 1" $ bloomContains f1 v1
assertBool "Bloom filter contains something it should not" $
not $ bloomContains f1 v2
assertBool "Bloom filter doesn't contain vector 3" $ bloomContains f3 v3
assertBool "Bloom filter doesn't contain vector 4" $ bloomContains f4 v4
assertBool "Bloom filter serialization is incorrect" $
runPutS (serialize f4) == bs
assertBool "Bloom filter doesn't contain vector 1" $ bloomContains f1 v1
assertBool "Bloom filter contains something it should not" $
not $
bloomContains f1 v2
assertBool "Bloom filter doesn't contain vector 3" $ bloomContains f3 v3
assertBool "Bloom filter doesn't contain vector 4" $ bloomContains f4 v4
assertBool "Bloom filter serialization is incorrect" $
runPutS (serialize f4) == bs
where
f0 = bloomCreate 3 0.01 n BloomUpdateAll
f1 = bloomInsert f0 v1
@ -88,97 +90,97 @@ bloomFilter1 = bloomFilter 0 "03614e9b050000000000000001"
bloomFilter2 :: Assertion
bloomFilter2 = bloomFilter 2147483649 "03ce4299050000000100008001"
bloomFilter3 :: Assertion
bloomFilter3 =
assertBool "Bloom filter serialization is incorrect" $
runPutS (serialize f2) == bs
bloomFilter3 :: Ctx -> Assertion
bloomFilter3 ctx =
assertBool "Bloom filter serialization is incorrect" $
runPutS (serialize f2) == bs
where
f0 = bloomCreate 2 0.001 0 BloomUpdateAll
f1 = bloomInsert f0 $ runPutS $ serialize p
f2 = bloomInsert f1 $ runPutS $ serialize $ getAddrHash160 $ pubKeyAddr p
f1 = bloomInsert f0 $ marshal ctx p
f2 = bloomInsert f1 $ runPutS $ serialize (pubKeyAddr ctx p).hash160
k = fromJust $ fromWif btc "5Kg1gnAjaLfKiwhhPpGS3QfRg2m6awQvaj98JCZBZQ5SuS2F15C"
p = derivePubKeyI k
p = derivePublicKey ctx k
bs = fromJust $ decodeHex "038fc16b080000000000000001"
relevantOutputUpdated :: Assertion
relevantOutputUpdated =
assertBool "Bloom filter output updated" $
any (bloomContains bf2) spendTxInput
relevantOutputUpdated :: Ctx -> Assertion
relevantOutputUpdated ctx =
assertBool "Bloom filter output updated" $
any (bloomContains bf2) spendTxInput
where
bf0 = bloomCreate 10 0.000001 0 BloomUpdateAll
relevantOutputHash = fromJust $ decodeHex "03f47604ea2736334151081e13265b4fe38e6fa8"
bf1 = bloomInsert bf0 relevantOutputHash
bf2 = fromJust $ bloomRelevantUpdate bf1 relevantTx
spendTxInput = runPutS . serialize . prevOutput <$> txIn spendRelevantTx
bf2 = fromJust $ bloomRelevantUpdate ctx bf1 relevantTx
spendTxInput = runPutS . serialize . (.outpoint) <$> spendRelevantTx.inputs
irrelevantOutputNotUpdated :: Assertion
irrelevantOutputNotUpdated = assertEqual "Bloom filter not updated" Nothing bf2
irrelevantOutputNotUpdated :: Ctx -> Assertion
irrelevantOutputNotUpdated ctx = assertEqual "Bloom filter not updated" Nothing bf2
where
bf0 = bloomCreate 10 0.000001 0 BloomUpdateAll
relevantOutputHash = fromJust $ decodeHex "03f47604ea2736334151081e13265b4fe38e6fa8"
bf1 = bloomInsert bf0 relevantOutputHash
bf2 = bloomRelevantUpdate bf1 unrelatedTx
bf2 = bloomRelevantUpdate ctx bf1 unrelatedTx
-- Random transaction (57dc904f32ad4daab7b321dd469e8791ad09df784cdd273a73985150a4f225e9)
relevantTx :: Tx
relevantTx =
Tx
{ txVersion = 1
, txIn =
[ TxIn
{ prevOutput = OutPoint "35fe9017b7e3af592920b56fa06ac02faf0c52cdb19dcb416129ac71c95d060e" 1
, scriptInput = fromJust $ decodeHex "473044022032fc8eef299b7e94b9a986a6aa2dcb9733ab804bef80df995e443b9c1f8c604202203335df7a2e2b4789451cdb4b2b05a786a81c51519eb6a567fd6fe8cd7b2d33fe014104272502dc63a512dad1473cb82a71be9baf4f4303abd1ff6028fc8a78e1f3aec1218907119dec14f07354850758ff0948e88a904fa411c4df7d5444414ec64ad6"
, txInSequence = 4294967295
}
]
, txOut =
[ TxOut{outValue = 100000000, scriptOutput = fromJust $ decodeHex "76a91403f47604ea2736334151081e13265b4fe38e6fa888ac"}
, TxOut{outValue = 107980000, scriptOutput = fromJust $ decodeHex "76a91481cc186a2f4a69f633ed4bf10ef4a78be13effdd88ac"}
]
, txWitness = []
, txLockTime = 0
}
Tx
{ version = 1,
inputs =
[ TxIn
{ outpoint = OutPoint "35fe9017b7e3af592920b56fa06ac02faf0c52cdb19dcb416129ac71c95d060e" 1,
script = fromJust $ decodeHex "473044022032fc8eef299b7e94b9a986a6aa2dcb9733ab804bef80df995e443b9c1f8c604202203335df7a2e2b4789451cdb4b2b05a786a81c51519eb6a567fd6fe8cd7b2d33fe014104272502dc63a512dad1473cb82a71be9baf4f4303abd1ff6028fc8a78e1f3aec1218907119dec14f07354850758ff0948e88a904fa411c4df7d5444414ec64ad6",
sequence = 4294967295
}
],
outputs =
[ TxOut {value = 100000000, script = fromJust $ decodeHex "76a91403f47604ea2736334151081e13265b4fe38e6fa888ac"},
TxOut {value = 107980000, script = fromJust $ decodeHex "76a91481cc186a2f4a69f633ed4bf10ef4a78be13effdd88ac"}
],
witness = [],
locktime = 0
}
-- Transaction that spends above (fd6e3b693b844aa431fad46765c1aa019a6b13aebfa9dae916b3ffa43283a300)
spendRelevantTx :: Tx
spendRelevantTx =
Tx
{ txVersion = 1
, txIn =
[ TxIn
{ prevOutput = OutPoint "57dc904f32ad4daab7b321dd469e8791ad09df784cdd273a73985150a4f225e9" 0
, scriptInput = fromJust $ decodeHex "483045022100ecc334821e4e94cc2fdc841d5ad147d5bb942b993ba81460cc446e0410afa811022015fcbc542b734dbb61a05ec06012095096de5839c50808fe56f2b315e877c20d012103fb64e5792fa586172339b776b7017d3d529358cb73be6406a1fc994228d14f88"
, txInSequence = 4294967295
}
, TxIn
{ prevOutput = OutPoint "cfee6a8d6e68e8fd16df6fff010afffcd19d7e075aa7b707dd1bae6adc420042" 0
, scriptInput = fromJust $ decodeHex "47304402200e6bb95fa606f254d17089d83c4ceeb19c5d1699b4faddcd4f1f1568286e6b650220087fb8439f31e1b30e47710d095422405f601d6151f2f93e125e1a08a6e29ad4012103b49252e8fc6d5b49c8d14ee71fab45591df4a126a6c453c724f3d356e38f0cee"
, txInSequence = 4294967295
}
]
, txOut =
[ TxOut{outValue = 3851100, scriptOutput = fromJust $ decodeHex "76a914a297cae82a9a3b932bf023ae274fe2585295c9ca88ac"}
, TxOut{outValue = 111000000, scriptOutput = fromJust $ decodeHex "76a9148f952c38600a61385974acc30a64f74407f9801488ac"}
]
, txWitness = []
, txLockTime = 0
}
Tx
{ version = 1,
inputs =
[ TxIn
{ outpoint = OutPoint "57dc904f32ad4daab7b321dd469e8791ad09df784cdd273a73985150a4f225e9" 0,
script = fromJust $ decodeHex "483045022100ecc334821e4e94cc2fdc841d5ad147d5bb942b993ba81460cc446e0410afa811022015fcbc542b734dbb61a05ec06012095096de5839c50808fe56f2b315e877c20d012103fb64e5792fa586172339b776b7017d3d529358cb73be6406a1fc994228d14f88",
sequence = 4294967295
},
TxIn
{ outpoint = OutPoint "cfee6a8d6e68e8fd16df6fff010afffcd19d7e075aa7b707dd1bae6adc420042" 0,
script = fromJust $ decodeHex "47304402200e6bb95fa606f254d17089d83c4ceeb19c5d1699b4faddcd4f1f1568286e6b650220087fb8439f31e1b30e47710d095422405f601d6151f2f93e125e1a08a6e29ad4012103b49252e8fc6d5b49c8d14ee71fab45591df4a126a6c453c724f3d356e38f0cee",
sequence = 4294967295
}
],
outputs =
[ TxOut {value = 3851100, script = fromJust $ decodeHex "76a914a297cae82a9a3b932bf023ae274fe2585295c9ca88ac"},
TxOut {value = 111000000, script = fromJust $ decodeHex "76a9148f952c38600a61385974acc30a64f74407f9801488ac"}
],
witness = [],
locktime = 0
}
-- This random transaction is unrelated to the others
unrelatedTx :: Tx
unrelatedTx =
Tx
{ txVersion = 1
, txIn =
[ TxIn
{ prevOutput = OutPoint "3ec3a71431c68e5d978a5fb4a0a1081d8bee8384d8aa4c06b1fbaf9413e2214f" 20
, scriptInput = fromJust $ decodeHex "483045022100ec9c202c9d3140b973aca9d7f21a82138aa4cfa43fddc5419098ac5e26a6f152022010848fd688f290ae010fb5cb493410caa03145fc12445900ec1ad2bde33aecd9012102c7445e72d723f99a0064526c28269d07f47c8fd81531a94a8d3bf5ebd5e23ef1"
, txInSequence = 4294967295
}
]
, txOut =
[ TxOut{outValue = 12600000, scriptOutput = fromJust $ decodeHex "76a9148fef3b7051de8cc44e966159e7ea37f4520187e888ac"}
]
, txWitness = []
, txLockTime = 0
}
Tx
{ version = 1,
inputs =
[ TxIn
{ outpoint = OutPoint "3ec3a71431c68e5d978a5fb4a0a1081d8bee8384d8aa4c06b1fbaf9413e2214f" 20,
script = fromJust $ decodeHex "483045022100ec9c202c9d3140b973aca9d7f21a82138aa4cfa43fddc5419098ac5e26a6f152022010848fd688f290ae010fb5cb493410caa03145fc12445900ec1ad2bde33aecd9012102c7445e72d723f99a0064526c28269d07f47c8fd81531a94a8d3bf5ebd5e23ef1",
sequence = 4294967295
}
],
outputs =
[ TxOut {value = 12600000, script = fromJust $ decodeHex "76a9148fef3b7051de8cc44e966159e7ea37f4520187e888ac"}
],
witness = [],
locktime = 0
}

727
test/Haskoin/ScriptSpec.hs
View File

@ -1,11 +1,15 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
module Haskoin.ScriptSpec (spec) where
import Control.Monad
import Data.Aeson as A
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.ByteString qualified as B
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
@ -17,14 +21,13 @@ import Data.String.Conversions (cs)
import Data.Text (Text)
import Data.Word
import Haskoin.Address
import Haskoin.Constants
import Haskoin.Data
import Haskoin.Keys
import Haskoin.Crypto
import Haskoin.Network.Constants
import Haskoin.Network.Data
import Haskoin.Script
import Haskoin.Transaction
import Haskoin.Util
import Haskoin.Util.Arbitrary
import Haskoin.UtilSpec (readTestFile)
import Test.HUnit as HUnit
import Test.Hspec
import Test.Hspec.QuickCheck
@ -33,196 +36,187 @@ import Text.Read
serialVals :: [SerialBox]
serialVals =
[ SerialBox arbitraryScriptOp
, SerialBox arbitraryScript
]
[ SerialBox arbitraryScriptOp,
SerialBox arbitraryScript
]
readVals :: [ReadBox]
readVals =
[ ReadBox arbitrarySigHash
, ReadBox arbitrarySigHashFlag
, ReadBox arbitraryScript
, ReadBox arbitraryPushDataType
, ReadBox arbitraryScriptOp
, ReadBox (arbitraryScriptOutput =<< arbitraryNetwork)
]
readVals :: Ctx -> [ReadBox]
readVals ctx =
[ ReadBox arbitrarySigHash,
ReadBox arbitrarySigHashFlag,
ReadBox arbitraryScript,
ReadBox arbitraryPushDataType,
ReadBox arbitraryScriptOp,
ReadBox ((`arbitraryScriptOutput` ctx) =<< arbitraryNetwork)
]
jsonVals :: [JsonBox]
jsonVals =
[ JsonBox $ arbitraryScriptOutput =<< arbitraryNetwork
, JsonBox arbitraryOutPoint
, JsonBox arbitrarySigHash
, JsonBox $ fst <$> (arbitrarySigInput =<< arbitraryNetwork)
]
jsonVals :: Ctx -> [JsonBox]
jsonVals ctx =
[ JsonBox $
fmap (marshalValue ctx) $
arbitraryNetwork >>= flip arbitraryScriptOutput ctx,
JsonBox arbitraryOutPoint,
JsonBox arbitrarySigHash,
JsonBox $
fmap (marshalValue ctx . fst) $
arbitraryNetwork >>= flip arbitrarySigInput ctx
]
netVals :: Ctx -> [NetBox]
netVals ctx =
[ NetBox
( marshalValue . (,ctx),
marshalEncoding . (,ctx),
unmarshalValue . (,ctx),
do
net <- arbitraryNetwork
(_, _, txsig) <- arbitraryTxSignature net ctx
return (net, txsig)
)
]
spec :: Spec
spec = do
testIdentity serialVals readVals jsonVals []
describe "btc scripts" $ props btc
describe "bch scripts" $ props bch
describe "multi signatures" $
zipWithM_ (curry mapMulSigVector) mulSigVectors [0 ..]
describe "signature decoding" $
zipWithM_ (curry (sigDecodeMap btc)) scriptSigSignatures [0 ..]
describe "SigHashFlag fromEnum/toEnum" $
prop "fromEnum/toEnum" $
forAll arbitrarySigHashFlag $ \f -> toEnum (fromEnum f) `shouldBe` f
describe "Script vectors" $
it "Can encode script vectors" encodeScriptVector
spec = prepareContext $ \ctx -> do
testIdentity serialVals (readVals ctx) (jsonVals ctx) (netVals ctx)
describe "btc scripts" $ props btc ctx
describe "bch scripts" $ props bch ctx
describe "multi signatures" $
zipWithM_ (curry (mapMulSigVector ctx)) mulSigVectors [0 ..]
describe "signature decoding" $
zipWithM_ (curry (sigDecodeMap btc ctx)) scriptSigSignatures [0 ..]
describe "SigHashFlag fromEnum/toEnum" $
prop "fromEnum/toEnum" $
forAll arbitrarySigHashFlag $
\f -> toEnum (fromEnum f) `shouldBe` f
describe "Script vectors" $
it "Can encode script vectors" encodeScriptVector
props :: Network -> Spec
props net = do
standardSpec net
strictSigSpec net
scriptSpec net
txSigHashForkIdSpec net
forkIdScriptSpec net
sigHashSpec net
txSigHashSpec net
props :: Network -> Ctx -> Spec
props net ctx = do
standardSpec net ctx
strictSigSpec net ctx
scriptSpec net ctx
txSigHashForkIdSpec net
forkIdScriptSpec net ctx
sigHashSpec net ctx
txSigHashSpec net
standardSpec :: Network -> Spec
standardSpec net = do
prop "has intToScriptOp . scriptOpToInt identity" $
forAll arbitraryIntScriptOp $ \i ->
intToScriptOp <$> scriptOpToInt i `shouldBe` Right i
prop "has decodeOutput . encodeOutput identity" $
forAll (arbitraryScriptOutput net) $ \so ->
decodeOutput (encodeOutput so) `shouldBe` Right so
prop "has decodeInput . encodeOutput identity" $
forAll (arbitraryScriptInput net) $ \si ->
decodeInput net (encodeInput si) `shouldBe` Right si
prop "can sort multisig scripts" $
forAll arbitraryMSOutput $ \out ->
map
(runPutS . serialize)
(getOutputMulSigKeys (sortMulSig out))
`shouldSatisfy` \xs -> xs == sort xs
it "can decode inputs with empty signatures" $ do
decodeInput net (Script [OP_0])
`shouldBe` Right (RegularInput (SpendPK TxSignatureEmpty))
decodeInput net (Script [opPushData ""])
`shouldBe` Right (RegularInput (SpendPK TxSignatureEmpty))
let pk =
derivePubKeyI $
wrapSecKey True $ fromJust $ secKey $ B.replicate 32 1
decodeInput net (Script [OP_0, opPushData $ runPutS $ serialize pk])
`shouldBe` Right (RegularInput (SpendPKHash TxSignatureEmpty pk))
decodeInput net (Script [OP_0, OP_0])
`shouldBe` Right (RegularInput (SpendMulSig [TxSignatureEmpty]))
decodeInput net (Script [OP_0, OP_0, OP_0, OP_0])
`shouldBe` Right (RegularInput (SpendMulSig $ replicate 3 TxSignatureEmpty))
standardSpec :: Network -> Ctx -> Spec
standardSpec net ctx = do
prop "has intToScriptOp . scriptOpToInt identity" $
forAll arbitraryIntScriptOp $ \i ->
intToScriptOp <$> scriptOpToInt i `shouldBe` Right i
prop "has decodeOutput . encodeOutput identity" $
forAll (arbitraryScriptOutput net ctx) $ \so ->
decodeOutput ctx (encodeOutput ctx so) `shouldBe` Right so
prop "has decodeInput . encodeOutput identity" $
forAll (arbitraryScriptInput net ctx) $ \si ->
(decodeInput net ctx . encodeInput net ctx) si `shouldBe` Right si
prop "can sort multisig scripts" $
forAll (arbitraryMSOutput ctx) $ \out ->
let keyList = map (marshal ctx) (sortMulSig ctx out).keys
isSorted xs = xs == sort xs
in keyList `shouldSatisfy` isSorted
it "can decode inputs with empty signatures" $ do
decodeInput net ctx (Script [OP_0])
`shouldBe` Right (RegularInput (SpendPK TxSignatureEmpty))
decodeInput net ctx (Script [opPushData ""])
`shouldBe` Right (RegularInput (SpendPK TxSignatureEmpty))
let Just sk = secKey (B.replicate 32 1)
pk = derivePublicKey ctx (wrapSecKey True sk)
decodeInput net ctx (Script [OP_0, opPushData $ marshal ctx pk])
`shouldBe` Right (RegularInput (SpendPKHash TxSignatureEmpty pk))
decodeInput net ctx (Script [OP_0, OP_0])
`shouldBe` Right (RegularInput (SpendMulSig [TxSignatureEmpty]))
decodeInput net ctx (Script [OP_0, OP_0, OP_0, OP_0])
`shouldBe` Right (RegularInput (SpendMulSig $ replicate 3 TxSignatureEmpty))
scriptSpec :: Network -> Spec
scriptSpec net =
when (getNetworkName net == "btc") $
it "can verify standard scripts from script_tests.json file" $ do
xs <- readTestFile "script_tests.json" :: IO [A.Value]
let vectorsA =
mapMaybe (A.decode . A.encode) xs ::
[ ( String
, String
, String
, String
, String
)
]
vectorsB =
mapMaybe (A.decode . A.encode) xs ::
[ ( [Word64]
, String
, String
, String
, String
, String
)
]
vectors =
map (\(a, b, c, d, e) -> ([0], a, b, c, d, e)) vectorsA
<> vectorsB
length vectors `shouldBe` 86
forM_ vectors $ \([val], siStr, soStr, flags, res, desc) ->
-- We can disable specific tests by adding a DISABLED flag in the data
scriptSpec :: Network -> Ctx -> Spec
scriptSpec net ctx =
when (net.name == "btc") $
it "can verify standard scripts from script_tests.json file" $ do
xs <- readTestFile "script_tests.json" :: IO [A.Value]
let vectorsA =
mapMaybe (A.decode . A.encode) xs ::
[(String, String, String, String, String)]
vectorsB =
mapMaybe (A.decode . A.encode) xs ::
[([Word64], String, String, String, String, String)]
vectors =
map (\(a, b, c, d, e) -> ([0], a, b, c, d, e)) vectorsA
<> vectorsB
length vectors `shouldBe` 86
forM_ vectors $ \([val], siStr, soStr, flags, res, desc) ->
-- We can disable specific tests by adding a DISABLED flag in the data
unless ("DISABLED" `isInfixOf` flags) $ do
let _strict =
any
(`isInfixOf` flags)
["DERSIG", "STRICTENC", "NULLDUMMY"]
scriptSig = parseScript siStr
scriptPubKey = parseScript soStr
out = unmarshal ctx scriptPubKey
tx = spendTx scriptPubKey 0 scriptSig
sat = val * 100000000
ver o = verifyStdInput net ctx tx 0 o sat
valid = either (const False) ver out
assertBool desc $ if res == "OK" then valid else not valid
unless ("DISABLED" `isInfixOf` flags) $ do
let _strict =
"DERSIG" `isInfixOf` flags
|| "STRICTENC" `isInfixOf` flags
|| "NULLDUMMY" `isInfixOf` flags
scriptSig = parseScript siStr
scriptPubKey = parseScript soStr
decodedOutput = decodeOutputBS scriptPubKey
ver = either (const False) $ \so ->
verifyStdInput
net
(spendTx scriptPubKey 0 scriptSig)
0
so
(val * 100000000)
case res of
"OK" -> assertBool desc $ ver decodedOutput
_ -> assertBool desc (not $ ver decodedOutput)
forkIdScriptSpec :: Network -> Spec
forkIdScriptSpec net =
when (isJust (getSigHashForkId net)) $
it "can verify scripts from forkid_script_tests.json file" $ do
xs <- readTestFile "forkid_script_tests.json" :: IO [A.Value]
let vectors =
mapMaybe (A.decode . A.encode) xs ::
[ ( [Word64]
, String
, String
, String
, String
, String
)
]
length vectors `shouldBe` 3
forM_ vectors $ \([valBTC], siStr, soStr, _, res, _) -> do
let val = valBTC * 100000000
scriptSig = parseScript siStr
scriptPubKey = parseScript soStr
decodedOutput =
fromRight (error $ "Could not decode output: " <> soStr) $
decodeOutputBS scriptPubKey
ver =
verifyStdInput
net
(spendTx scriptPubKey val scriptSig)
0
decodedOutput
val
case res of
"OK" -> ver `shouldBe` True
_ -> ver `shouldBe` False
forkIdScriptSpec :: Network -> Ctx -> Spec
forkIdScriptSpec net ctx =
when (isJust net.sigHashForkId) $
it "can verify scripts from forkid_script_tests.json file" $ do
xs <- readTestFile "forkid_script_tests.json" :: IO [A.Value]
let vectors =
mapMaybe (A.decode . A.encode) xs ::
[ ( [Word64],
String,
String,
String,
String,
String
)
]
length vectors `shouldBe` 3
forM_ vectors $ \([valBTC], siStr, soStr, _, res, _) -> do
let val = valBTC * 100000000
scriptSig = parseScript siStr
scriptPubKey = parseScript soStr
out = unmarshal ctx scriptPubKey
tx = spendTx scriptPubKey val scriptSig
ver o = verifyStdInput net ctx tx 0 o val
valid = either (const False) ver out
case res of
"OK" -> valid `shouldBe` True
_ -> valid `shouldBe` False
creditTx :: ByteString -> Word64 -> Tx
creditTx scriptPubKey val =
Tx 1 [txI] [txO] [] 0
Tx 1 [txI] [txO] [] 0
where
txO = TxOut{outValue = val, scriptOutput = scriptPubKey}
txO = TxOut {value = val, script = scriptPubKey}
txI =
TxIn
{ prevOutput = nullOutPoint
, scriptInput = runPutS $ serialize $ Script [OP_0, OP_0]
, txInSequence = maxBound
}
TxIn
{ outpoint = nullOutPoint,
script = runPutS $ serialize $ Script [OP_0, OP_0],
sequence = maxBound
}
spendTx :: ByteString -> Word64 -> ByteString -> Tx
spendTx scriptPubKey val scriptSig =
Tx 1 [txI] [txO] [] 0
Tx 1 [txI] [txO] [] 0
where
txO = TxOut{outValue = val, scriptOutput = B.empty}
txO = TxOut {value = val, script = B.empty}
txI =
TxIn
{ prevOutput = OutPoint (txHash $ creditTx scriptPubKey val) 0
, scriptInput = scriptSig
, txInSequence = maxBound
}
TxIn
{ outpoint = OutPoint (txHash $ creditTx scriptPubKey val) 0,
script = scriptSig,
sequence = maxBound
}
parseScript :: String -> ByteString
parseScript str =
B.concat $ fromMaybe err $ mapM f $ words str
B.concat $ fromMaybe err $ mapM f $ words str
where
f = decodeHex . cs . dropHex . replaceToken
dropHex ('0' : 'x' : xs) = xs
@ -231,233 +225,238 @@ parseScript str =
replaceToken :: String -> String
replaceToken str = case readMaybe $ "OP_" <> str of
Just opcode -> "0x" <> cs (encodeHex $ runPutS $ serialize (opcode :: ScriptOp))
_ -> str
Just opcode -> "0x" <> cs (encodeHex $ runPutS $ serialize (opcode :: ScriptOp))
_ -> str
strictSigSpec :: Network -> Spec
strictSigSpec net =
when (getNetworkName net == "btc") $ do
it "can decode strict signatures" $ do
xs <- readTestFile "sig_strict.json"
let vectors = mapMaybe decodeHex xs
length vectors `shouldBe` 3
forM_ vectors $ \sig ->
decodeTxSig net sig `shouldSatisfy` isRight
it "can detect non-strict signatures" $ do
xs <- readTestFile "sig_nonstrict.json"
let vectors = mapMaybe decodeHex xs
length vectors `shouldBe` 17
forM_ vectors $ \sig ->
decodeTxSig net sig `shouldSatisfy` isLeft
strictSigSpec :: Network -> Ctx -> Spec
strictSigSpec net ctx =
when (net.name == "btc") $ do
it "can decode strict signatures" $ do
xs <- readTestFile "sig_strict.json"
let vectors = mapMaybe decodeHex xs
length vectors `shouldBe` 3
forM_ vectors $ \sig ->
let eitherSig :: Either String TxSignature
eitherSig = decodeTxSig net ctx sig
in eitherSig `shouldSatisfy` isRight
it "can detect non-strict signatures" $ do
xs <- readTestFile "sig_nonstrict.json"
let vectors = mapMaybe decodeHex xs
length vectors `shouldBe` 17
forM_ vectors $ \sig ->
let eitherSig = decodeTxSig net ctx sig
in eitherSig `shouldSatisfy` isLeft
txSigHashSpec :: Network -> Spec
txSigHashSpec net =
when (getNetworkName net == "btc") $
it "can produce valid sighashes from sighash.json test vectors" $ do
xs <- readTestFile "sighash.json" :: IO [A.Value]
let vectors =
mapMaybe (A.decode . A.encode) xs ::
[ ( String
, String
, Int
, Integer
, String
)
]
length vectors `shouldBe` 500
forM_ vectors $ \(txStr, scpStr, i, shI, resStr) -> do
let tx = fromString txStr
s =
fromMaybe (error $ "Could not decode script: " <> cs scpStr) $
eitherToMaybe . runGetS deserialize =<< decodeHex (cs scpStr)
sh = fromIntegral shI
res =
eitherToMaybe . runGetS deserialize . B.reverse
=<< decodeHex (cs resStr)
Just (txSigHash net tx s 0 i sh) `shouldBe` res
when (net.name == "btc") $
it "can produce valid sighashes from sighash.json test vectors" $ do
xs <- readTestFile "sighash.json" :: IO [A.Value]
let vectors =
mapMaybe (A.decode . A.encode) xs ::
[ ( String,
String,
Int,
Integer,
String
)
]
length vectors `shouldBe` 500
forM_ vectors $ \(txStr, scpStr, i, shI, resStr) -> do
let tx = fromString txStr
s =
fromMaybe (error $ "Could not decode script: " <> cs scpStr) $
eitherToMaybe . runGetS deserialize =<< decodeHex (cs scpStr)
sh = fromIntegral shI
res =
eitherToMaybe . runGetS deserialize . B.reverse
=<< decodeHex (cs resStr)
Just (txSigHash net tx s 0 i sh) `shouldBe` res
txSigHashForkIdSpec :: Network -> Spec
txSigHashForkIdSpec net =
when (getNetworkName net == "btc") $
it "can produce valid sighashes from forkid_sighash.json test vectors" $ do
xs <- readTestFile "forkid_sighash.json" :: IO [A.Value]
let vectors =
mapMaybe (A.decode . A.encode) xs ::
[ ( String
, String
, Int
, Word64
, Integer
, String
)
]
length vectors `shouldBe` 13
forM_ vectors $ \(txStr, scpStr, i, val, shI, resStr) -> do
let tx = fromString txStr
s =
fromMaybe (error $ "Could not decode script: " <> cs scpStr) $
eitherToMaybe . runGetS deserialize =<< decodeHex (cs scpStr)
sh = fromIntegral shI
res = eitherToMaybe . runGetS deserialize =<< decodeHex (cs resStr)
Just (txSigHashForkId net tx s val i sh) `shouldBe` res
when (net.name == "btc") $
it "can produce valid sighashes from forkid_sighash.json test vectors" $ do
xs <- readTestFile "forkid_sighash.json" :: IO [A.Value]
let vectors =
mapMaybe (A.decode . A.encode) xs ::
[ ( String,
String,
Int,
Word64,
Integer,
String
)
]
length vectors `shouldBe` 13
forM_ vectors $ \(txStr, scpStr, i, val, shI, resStr) -> do
let tx = fromString txStr
s =
fromMaybe (error $ "Could not decode script: " <> cs scpStr) $
eitherToMaybe . runGetS deserialize =<< decodeHex (cs scpStr)
sh = fromIntegral shI
res = eitherToMaybe . runGetS deserialize =<< decodeHex (cs resStr)
Just (txSigHashForkId net tx s val i sh) `shouldBe` res
sigHashSpec :: Network -> Spec
sigHashSpec net = do
it "can correctly show" $ do
show (0x00 :: SigHash) `shouldBe` "SigHash " <> show (0x00 :: Word32)
show (0x01 :: SigHash) `shouldBe` "SigHash " <> show (0x01 :: Word32)
show (0xff :: SigHash) `shouldBe` "SigHash " <> show (0xff :: Word32)
show (0xabac3344 :: SigHash) `shouldBe` "SigHash "
<> show (0xabac3344 :: Word32)
it "can add a forkid" $ do
0x00 `sigHashAddForkId` 0x00 `shouldBe` 0x00
0xff `sigHashAddForkId` 0x00ffffff `shouldBe` 0xffffffff
0xffff `sigHashAddForkId` 0x00aaaaaa `shouldBe` 0xaaaaaaff
0xffff `sigHashAddForkId` 0xaaaaaaaa `shouldBe` 0xaaaaaaff
0xffff `sigHashAddForkId` 0x00004444 `shouldBe` 0x004444ff
0xff01 `sigHashAddForkId` 0x44440000 `shouldBe` 0x44000001
0xff03 `sigHashAddForkId` 0x00550000 `shouldBe` 0x55000003
it "can extract a forkid" $ do
sigHashGetForkId 0x00000000 `shouldBe` 0x00000000
sigHashGetForkId 0x80000000 `shouldBe` 0x00800000
sigHashGetForkId 0xffffffff `shouldBe` 0x00ffffff
sigHashGetForkId 0xabac3403 `shouldBe` 0x00abac34
it "can build some vectors" $ do
sigHashAll `shouldBe` 0x01
sigHashNone `shouldBe` 0x02
sigHashSingle `shouldBe` 0x03
setForkIdFlag sigHashAll `shouldBe` 0x41
setAnyoneCanPayFlag sigHashAll `shouldBe` 0x81
setAnyoneCanPayFlag (setForkIdFlag sigHashAll) `shouldBe` 0xc1
it "can test flags" $ do
hasForkIdFlag sigHashAll `shouldBe` False
hasForkIdFlag (setForkIdFlag sigHashAll) `shouldBe` True
hasAnyoneCanPayFlag sigHashAll `shouldBe` False
hasAnyoneCanPayFlag (setAnyoneCanPayFlag sigHashAll) `shouldBe` True
isSigHashAll sigHashNone `shouldBe` False
isSigHashAll sigHashAll `shouldBe` True
isSigHashNone sigHashSingle `shouldBe` False
isSigHashNone sigHashNone `shouldBe` True
isSigHashSingle sigHashAll `shouldBe` False
isSigHashSingle sigHashSingle `shouldBe` True
isSigHashUnknown sigHashAll `shouldBe` False
isSigHashUnknown sigHashNone `shouldBe` False
isSigHashUnknown sigHashSingle `shouldBe` False
isSigHashUnknown 0x00 `shouldBe` True
isSigHashUnknown 0x04 `shouldBe` True
it "can decodeTxSig . encode a TxSignature" $
property $
forAll (arbitraryTxSignature net) $ \(_, _, ts) ->
decodeTxSig net (encodeTxSig ts) `shouldBe` Right ts
it "can produce the sighash one" $
property $
forAll (arbitraryTx net) $ forAll arbitraryScript . testSigHashOne net
sigHashSpec :: Network -> Ctx -> Spec
sigHashSpec net ctx = do
it "can correctly show" $ do
show (0x00 :: SigHash) `shouldBe` "SigHash " <> show (0x00 :: Word32)
show (0x01 :: SigHash) `shouldBe` "SigHash " <> show (0x01 :: Word32)
show (0xff :: SigHash) `shouldBe` "SigHash " <> show (0xff :: Word32)
show (0xabac3344 :: SigHash)
`shouldBe` "SigHash "
<> show (0xabac3344 :: Word32)
it "can add a forkid" $ do
0x00 `sigHashAddForkId` 0x00 `shouldBe` 0x00
0xff `sigHashAddForkId` 0x00ffffff `shouldBe` 0xffffffff
0xffff `sigHashAddForkId` 0x00aaaaaa `shouldBe` 0xaaaaaaff
0xffff `sigHashAddForkId` 0xaaaaaaaa `shouldBe` 0xaaaaaaff
0xffff `sigHashAddForkId` 0x00004444 `shouldBe` 0x004444ff
0xff01 `sigHashAddForkId` 0x44440000 `shouldBe` 0x44000001
0xff03 `sigHashAddForkId` 0x00550000 `shouldBe` 0x55000003
it "can extract a forkid" $ do
sigHashGetForkId 0x00000000 `shouldBe` 0x00000000
sigHashGetForkId 0x80000000 `shouldBe` 0x00800000
sigHashGetForkId 0xffffffff `shouldBe` 0x00ffffff
sigHashGetForkId 0xabac3403 `shouldBe` 0x00abac34
it "can build some vectors" $ do
sigHashAll `shouldBe` 0x01
sigHashNone `shouldBe` 0x02
sigHashSingle `shouldBe` 0x03
setForkIdFlag sigHashAll `shouldBe` 0x41
setAnyoneCanPay sigHashAll `shouldBe` 0x81
setAnyoneCanPay (setForkIdFlag sigHashAll) `shouldBe` 0xc1
it "can test flags" $ do
hasForkIdFlag sigHashAll `shouldBe` False
hasForkIdFlag (setForkIdFlag sigHashAll) `shouldBe` True
anyoneCanPay sigHashAll `shouldBe` False
anyoneCanPay (setAnyoneCanPay sigHashAll) `shouldBe` True
isSigHashAll sigHashNone `shouldBe` False
isSigHashAll sigHashAll `shouldBe` True
isSigHashNone sigHashSingle `shouldBe` False
isSigHashNone sigHashNone `shouldBe` True
isSigHashSingle sigHashAll `shouldBe` False
isSigHashSingle sigHashSingle `shouldBe` True
isSigHashUnknown sigHashAll `shouldBe` False
isSigHashUnknown sigHashNone `shouldBe` False
isSigHashUnknown sigHashSingle `shouldBe` False
isSigHashUnknown 0x00 `shouldBe` True
isSigHashUnknown 0x04 `shouldBe` True
it "can decodeTxSig . encode a TxSignature" $
property $
forAll (arbitraryTxSignature net ctx) $ \(_, _, ts) ->
let f = decodeTxSig net ctx . encodeTxSig net ctx
in f ts `shouldBe` Right ts
it "can produce the sighash one" $
property $
forAll (arbitraryTx net ctx) $
forAll arbitraryScript . testSigHashOne net
testSigHashOne :: Network -> Tx -> Script -> Word64 -> Bool -> Property
testSigHashOne net tx s val acp =
not (null $ txIn tx)
==> if length (txIn tx) > length (txOut tx)
then res `shouldBe` one
else res `shouldNotBe` one
not (null tx.inputs) ==>
if length tx.inputs > length tx.outputs
then res `shouldBe` one
else res `shouldNotBe` one
where
res = txSigHash net tx s val (length (txIn tx) - 1) (f sigHashSingle)
res = txSigHash net tx s val (length tx.inputs - 1) (f sigHashSingle)
one = "0100000000000000000000000000000000000000000000000000000000000000"
f =
if acp
then setAnyoneCanPayFlag
else id
if acp
then setAnyoneCanPay
else id
{- Parse tests from bitcoin-qt repository -}
mapMulSigVector :: ((Text, Text), Int) -> Spec
mapMulSigVector (v, i) =
it name $ runMulSigVector v
mapMulSigVector :: Ctx -> ((Text, Text), Int) -> Spec
mapMulSigVector ctx (v, i) =
it name $ runMulSigVector ctx v
where
name = "check multisig vector " <> show i
runMulSigVector :: (Text, Text) -> Assertion
runMulSigVector (a, ops) = assertBool "multisig vector" $ Just a == b
runMulSigVector :: Ctx -> (Text, Text) -> Assertion
runMulSigVector ctx (a, ops) = assertBool "multisig vector" $ Just a == b
where
s = do
s' <- decodeHex ops
eitherToMaybe $ runGetS deserialize s'
s' <- decodeHex ops
eitherToMaybe $ runGetS deserialize s'
b = do
o <- s
d <- eitherToMaybe $ decodeOutput o
addrToText btc $ payToScriptAddress d
o <- s
d <- eitherToMaybe $ decodeOutput ctx o
addrToText btc $ payToScriptAddress ctx d
sigDecodeMap :: Network -> (Text, Int) -> Spec
sigDecodeMap net (_, i) =
it ("check signature " ++ show i) func
sigDecodeMap :: Network -> Ctx -> (Text, Int) -> Spec
sigDecodeMap net ctx (_, i) =
it ("check signature " ++ show i) func
where
func = testSigDecode net $ scriptSigSignatures !! i
func = testSigDecode net ctx $ scriptSigSignatures !! i
testSigDecode :: Network -> Text -> Assertion
testSigDecode net str =
let bs = fromJust $ decodeHex str
eitherSig = decodeTxSig net bs
in assertBool
( unwords
[ "Decode failed:"
, fromLeft (error "Decode did not fail") eitherSig
]
)
$ isRight eitherSig
testSigDecode :: Network -> Ctx -> Text -> Assertion
testSigDecode net ctx str =
let bs = fromJust $ decodeHex str
eitherSig = decodeTxSig net ctx bs
in assertBool
( unwords
[ "Decode failed:",
fromLeft (error "Decode did not fail") eitherSig
]
)
$ isRight eitherSig
mulSigVectors :: [(Text, Text)]
mulSigVectors =
[
( "3QJmV3qfvL9SuYo34YihAf3sRCW3qSinyC"
, "52410491bba2510912a5bd37da1fb5b1673010e43d2c6d812c514e91bfa9f2eb\
\129e1c183329db55bd868e209aac2fbc02cb33d98fe74bf23f0c235d6126b1d8\
\334f864104865c40293a680cb9c020e7b1e106d8c1916d3cef99aa431a56d253\
\e69256dac09ef122b1a986818a7cb624532f062c1d1f8722084861c5c3291ccf\
\fef4ec687441048d2455d2403e08708fc1f556002f1b6cd83f992d085097f997\
\4ab08a28838f07896fbab08f39495e15fa6fad6edbfb1e754e35fa1c7844c41f\
\322a1863d4621353ae"
)
]
[ ( "3QJmV3qfvL9SuYo34YihAf3sRCW3qSinyC",
"52410491bba2510912a5bd37da1fb5b1673010e43d2c6d812c514e91bfa9f2eb\
\129e1c183329db55bd868e209aac2fbc02cb33d98fe74bf23f0c235d6126b1d8\
\334f864104865c40293a680cb9c020e7b1e106d8c1916d3cef99aa431a56d253\
\e69256dac09ef122b1a986818a7cb624532f062c1d1f8722084861c5c3291ccf\
\fef4ec687441048d2455d2403e08708fc1f556002f1b6cd83f992d085097f997\
\4ab08a28838f07896fbab08f39495e15fa6fad6edbfb1e754e35fa1c7844c41f\
\322a1863d4621353ae"
)
]
scriptSigSignatures :: [Text]
scriptSigSignatures =
-- Signature in input of txid
-- 1983a69265920c24f89aac81942b1a59f7eb30821a8b3fb258f88882b6336053
[ "304402205ca6249f43538908151fe67b26d020306c0e59fa206cf9f3ccf641f333\
\57119d02206c82f244d04ac0a48024fb9cc246b66e58598acf206139bdb7b75a29\
\41a2b1e401"
-- Signature in input of txid
-- 1983a69265920c24f89aac81942b1a59f7eb30821a8b3fb258f88882b6336053
[ "304402205ca6249f43538908151fe67b26d020306c0e59fa206cf9f3ccf641f333\
\57119d02206c82f244d04ac0a48024fb9cc246b66e58598acf206139bdb7b75a29\
\41a2b1e401"
-- Signature in input of txid
-- fb0a1d8d34fa5537e461ac384bac761125e1bfa7fec286fa72511240fa66864d.
-- Strange DER sizes, but in Blockchain. Now invalid as Haskoin can only
-- decode strict signatures.
-- "3048022200002b83d59c1d23c08efd82ee0662fec23309c3adbcbd1f0b8695378d\
-- \b4b14e736602220000334a96676e58b1bb01784cb7c556dd8ce1c220171904da22\
-- \e18fe1e7d1510db501"
]
-- fb0a1d8d34fa5537e461ac384bac761125e1bfa7fec286fa72511240fa66864d.
-- Strange DER sizes, but in Blockchain. Now invalid as Haskoin can only
-- decode strict signatures.
-- "3048022200002b83d59c1d23c08efd82ee0662fec23309c3adbcbd1f0b8695378d\
-- \b4b14e736602220000334a96676e58b1bb01784cb7c556dd8ce1c220171904da22\
-- \e18fe1e7d1510db501"
]
encodeScriptVector :: Assertion
encodeScriptVector =
assertEqual "Encode script" res (encodeHex $ runPutS $ serialize s)
assertEqual "Encode script" res (encodeHex $ runPutS $ serialize s)
where
res =
"514104cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef58b\
\bfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d11fcdd0d\
\348ac4410461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2f\
\cfdeb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39f58b\
\25c15342af52ae"
"514104cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef58b\
\bfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d11fcdd0d\
\348ac4410461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2f\
\cfdeb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39f58b\
\25c15342af52ae"
s =
Script
[ OP_1
, opPushData $
d
"04cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef5\
\8bbfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d\
\11fcdd0d348ac4"
, opPushData $
d
"0461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2fcf\
\deb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39\
\f58b25c15342af"
, OP_2
, OP_CHECKMULTISIG
]
Script
[ OP_1,
opPushData $
d
"04cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef5\
\8bbfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d\
\11fcdd0d348ac4",
opPushData $
d
"0461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2fcf\
\deb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39\
\f58b25c15342af",
OP_2,
OP_CHECKMULTISIG
]
d = fromJust . decodeHex

905
test/Haskoin/Transaction/PartialSpec.hs
View File

File diff suppressed because it is too large Load Diff

250
test/Haskoin/Transaction/TaprootSpec.hs
View File

@ -1,189 +1,181 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
module Haskoin.Transaction.TaprootSpec (spec) where
import Control.Applicative ((<|>))
import Control.Monad (zipWithM, (<=<))
import Data.Aeson (FromJSON (parseJSON), withObject, (.:), (.:?))
import Data.Aeson.Types (Parser)
import qualified Data.ByteArray as BA
import Data.Aeson
import Data.Aeson.Types
import Data.ByteArray qualified as BA
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.ByteString qualified as BS
import Data.Bytes.Get (runGetS)
import Data.Bytes.Put (runPutS)
import Data.Bytes.Serial (deserialize, serialize)
import Data.Text (Text)
import Data.Word (Word8)
import Haskoin (
MAST (..),
PubKey,
PubKeyI (PubKeyI),
ScriptOutput,
ScriptPathData (..),
TaprootOutput (TaprootOutput),
TaprootWitness (ScriptPathSpend),
XOnlyPubKey (..),
addrToText,
btc,
decodeHex,
encodeTaprootWitness,
getMerkleProofs,
mastCommitment,
outputAddress,
taprootInternalKey,
taprootMAST,
taprootOutputKey,
taprootScriptOutput,
verifyScriptPathData,
)
import Haskoin.UtilSpec (readTestFile)
import Haskoin
import Test.HUnit (assertBool, (@?=))
import Test.Hspec (Spec, describe, it, runIO)
spec :: Spec
spec = do
TestVector{testScriptPubKey} <- runIO $ readTestFile "bip341.json"
describe "Taproot" $ do
it "should calculate the correct hashes" $ mapM_ testHashes testScriptPubKey
it "should build the correct output key" $ mapM_ testOutputKey testScriptPubKey
it "should build the correct script output" $ mapM_ testScriptOutput testScriptPubKey
it "should calculate the correct control blocks" $ mapM_ testControlBlocks testScriptPubKey
it "should arrive at the correct address" $ mapM_ testAddress testScriptPubKey
spec = prepareContext $ \ctx -> do
TestVector {testScriptPubKey} <-
runIO $
readTestFileParser (testVectorParseJSON ctx) "bip341.json"
describe "Taproot" $ do
it "should calculate the correct hashes" $
mapM_ testHashes testScriptPubKey
it "should build the correct output key" $
mapM_ (testOutputKey ctx) testScriptPubKey
it "should build the correct script output" $
mapM_ (testScriptOutput ctx) testScriptPubKey
it "should calculate the correct control blocks" $
mapM_ (testControlBlocks ctx) testScriptPubKey
it "should arrive at the correct address" $
mapM_ (testAddress ctx) testScriptPubKey
testHashes :: TestScriptPubKey -> IO ()
testHashes testData =
mapM_ checkMASTDetails $ (taprootMAST . tspkGiven) testData
mapM_ checkMASTDetails $ ((.mast) . tspkGiven) testData
where
checkMASTDetails theMAST = do
-- Leaf hashes
(Just . getLeafHashes) theMAST @?= (spkiLeafHashes . tspkIntermediary) testData
-- Merkle root
(Just . BA.convert . mastCommitment) theMAST @?= (spkiMerkleRoot . tspkIntermediary) testData
-- Leaf hashes
(Just . getLeafHashes) theMAST @?= (spkiLeafHashes . tspkIntermediary) testData
-- Merkle root
(Just . BA.convert . mastCommitment) theMAST @?= (spkiMerkleRoot . tspkIntermediary) testData
getLeafHashes = \case
MASTBranch branchL branchR -> getLeafHashes branchL <> getLeafHashes branchR
leaf@MASTLeaf{} -> [BA.convert $ mastCommitment leaf]
MASTCommitment{} -> mempty -- The test vectors have complete trees
MASTBranch branchL branchR -> getLeafHashes branchL <> getLeafHashes branchR
leaf@MASTLeaf {} -> [BA.convert $ mastCommitment leaf]
MASTCommitment {} -> mempty -- The test vectors have complete trees
testOutputKey :: TestScriptPubKey -> IO ()
testOutputKey testData = do
XOnlyPubKey (taprootOutputKey theOutput) @?= theOutputKey
testOutputKey :: Ctx -> TestScriptPubKey -> IO ()
testOutputKey ctx testData = do
XOnlyPubKey (taprootOutputKey ctx theOutput) @?= theOutputKey
where
theOutput = tspkGiven testData
theOutputKey = XOnlyPubKey . spkiTweakedPubKey $ tspkIntermediary testData
testScriptOutput :: TestScriptPubKey -> IO ()
testScriptOutput testData =
taprootScriptOutput (tspkGiven testData) @?= (spkeScriptPubKey . tspkExpected) testData
testScriptOutput :: Ctx -> TestScriptPubKey -> IO ()
testScriptOutput ctx testData =
taprootScriptOutput ctx (tspkGiven testData) @?= (spkeScriptPubKey . tspkExpected) testData
testControlBlocks :: TestScriptPubKey -> IO ()
testControlBlocks testData = do
mapM_ onExamples exampleControlBlocks
mapM_ checkVerification scriptPathSpends
testControlBlocks :: Ctx -> TestScriptPubKey -> IO ()
testControlBlocks ctx testData = do
mapM_ onExamples exampleControlBlocks
mapM_ checkVerification scriptPathSpends
where
theOutput = tspkGiven testData
theOutputKey = taprootOutputKey theOutput
theOutputKey = taprootOutputKey ctx theOutput
exampleControlBlocks = spkeControlBlocks $ tspkExpected testData
calculatedControlBlocks =
(!! 1) . encodeTaprootWitness . ScriptPathSpend <$> scriptPathSpends
(!! 1) . encodeTaprootWitness ctx . ScriptPathSpend <$> scriptPathSpends
scriptPathSpends =
fmap mkScriptPathSpend
. maybe mempty getMerkleProofs
$ taprootMAST theOutput
mkScriptPathSpend (scriptPathLeafVersion, scriptPathScript, proof) =
ScriptPathData
{ scriptPathAnnex = Nothing
, scriptPathStack = mempty
, scriptPathScript
, scriptPathExternalIsOdd = odd $ keyParity theOutputKey
, scriptPathLeafVersion
, scriptPathInternalKey = taprootInternalKey theOutput
, scriptPathControl = BA.convert <$> proof
}
mkScriptPathSpend <$> maybe mempty getMerkleProofs theOutput.mast
mkScriptPathSpend (leafVersion, script, proof) =
ScriptPathData
{ annex = Nothing,
stack = mempty,
script,
extIsOdd = odd $ keyParity ctx theOutputKey,
leafVersion,
internalKey = theOutput.internalKey,
control = BA.convert <$> proof
}
onExamples = zipWithM (@?=) calculatedControlBlocks
checkVerification = assertBool "Script verifies" . verifyScriptPathData theOutputKey
checkVerification = assertBool "Script verifies" . verifyScriptPathData ctx theOutputKey
keyParity :: PubKey -> Word8
keyParity key = case BS.unpack . runPutS . serialize $ PubKeyI key True of
keyParity :: Ctx -> PubKey -> Word8
keyParity ctx key =
case BS.unpack . marshal ctx $ PublicKey key True of
0x02 : _ -> 0x00
_ -> 0x01
testAddress :: TestScriptPubKey -> IO ()
testAddress testData = computedAddress @?= (Just . spkeAddress . tspkExpected) testData
testAddress :: Ctx -> TestScriptPubKey -> IO ()
testAddress ctx testData =
computedAddress @?= (Just . spkeAddress . tspkExpected) testData
where
computedAddress = (addrToText btc <=< outputAddress) . taprootScriptOutput $ tspkGiven testData
computedAddress =
(addrToText btc <=< outputAddress ctx)
. taprootScriptOutput ctx
$ tspkGiven testData
newtype SpkGiven = SpkGiven {unSpkGiven :: TaprootOutput}
instance FromJSON SpkGiven where
parseJSON = withObject "SpkGiven" $ \obj ->
fmap SpkGiven $
TaprootOutput
<$> (xOnlyPubKey <$> obj .: "internalPubkey")
<*> (obj .:? "scriptTree" >>= traverse parseScriptTree)
where
parseScriptTree v =
parseScriptLeaf v
<|> parseScriptBranch v
<|> fail "Unable to parse scriptTree"
parseScriptLeaf = withObject "ScriptTree leaf" $ \obj ->
MASTLeaf
<$> obj .: "leafVersion"
<*> (obj .: "script" >>= hexScript)
parseScriptBranch v =
parseJSON v >>= \case
[v1, v2] -> MASTBranch <$> parseScriptTree v1 <*> parseScriptTree v2
_ -> fail "ScriptTree branch"
hexScript = either fail pure . runGetS deserialize <=< jsonHex
spkGivenParseJSON :: Ctx -> Value -> Parser SpkGiven
spkGivenParseJSON ctx = withObject "SpkGiven" $ \obj -> do
pxopk@XOnlyPubKey {} <- unmarshalValue ctx =<< obj .: "internalPubkey"
tree <- traverse parseScriptTree =<< obj .:? "scriptTree"
return $ SpkGiven $ TaprootOutput pxopk.point tree
where
parseScriptTree v =
parseScriptLeaf v
<|> parseScriptBranch v
<|> fail "Unable to parse scriptTree"
parseScriptLeaf = withObject "ScriptTree leaf" $ \obj ->
MASTLeaf
<$> obj .: "leafVersion"
<*> (obj .: "script" >>= hexScript)
parseScriptBranch v =
parseJSON v >>= \case
[v1, v2] -> MASTBranch <$> parseScriptTree v1 <*> parseScriptTree v2
_ -> fail "ScriptTree branch"
hexScript = either fail pure . runGetS deserialize <=< jsonHex
data SpkIntermediary = SpkIntermediary
{ spkiLeafHashes :: Maybe [ByteString]
, spkiMerkleRoot :: Maybe ByteString
, spkiTweakedPubKey :: PubKey
}
{ spkiLeafHashes :: Maybe [ByteString],
spkiMerkleRoot :: Maybe ByteString,
spkiTweakedPubKey :: PubKey
}
instance FromJSON SpkIntermediary where
parseJSON = withObject "SpkIntermediary" $ \obj ->
SpkIntermediary
<$> (obj .:? "leafHashes" >>= (traverse . traverse) jsonHex)
<*> (obj .: "merkleRoot" >>= traverse jsonHex)
<*> (xOnlyPubKey <$> obj .: "tweakedPubkey")
spkIntermediaryParseJSON :: Ctx -> Value -> Parser SpkIntermediary
spkIntermediaryParseJSON ctx = withObject "SpkIntermediary" $ \obj ->
SpkIntermediary
<$> (obj .:? "leafHashes" >>= (traverse . traverse) jsonHex)
<*> (obj .: "merkleRoot" >>= traverse jsonHex)
<*> fmap
(\(XOnlyPubKey k) -> k)
(unmarshalValue ctx =<< obj .: "tweakedPubkey")
data SpkExpected = SpkExpected
{ spkeScriptPubKey :: ScriptOutput
, spkeControlBlocks :: Maybe [ByteString]
, spkeAddress :: Text
}
{ spkeScriptPubKey :: ScriptOutput,
spkeControlBlocks :: Maybe [ByteString],
spkeAddress :: Text
}
instance FromJSON SpkExpected where
parseJSON = withObject "SpkExpected" $ \obj ->
SpkExpected
<$> obj .: "scriptPubKey"
<*> (obj .:? "scriptPathControlBlocks" >>= (traverse . traverse) jsonHex)
<*> obj .: "bip350Address"
spkExpectedParseJSON :: Ctx -> Value -> Parser SpkExpected
spkExpectedParseJSON ctx = withObject "SpkExpected" $ \obj ->
SpkExpected
<$> (unmarshalValue ctx =<< obj .: "scriptPubKey")
<*> ((traverse . traverse) jsonHex =<< obj .:? "scriptPathControlBlocks")
<*> obj .: "bip350Address"
data TestScriptPubKey = TestScriptPubKey
{ tspkGiven :: TaprootOutput
, tspkIntermediary :: SpkIntermediary
, tspkExpected :: SpkExpected
}
{ tspkGiven :: TaprootOutput,
tspkIntermediary :: SpkIntermediary,
tspkExpected :: SpkExpected
}
instance FromJSON TestScriptPubKey where
parseJSON = withObject "TestScriptPubKey" $ \obj ->
TestScriptPubKey
<$> (unSpkGiven <$> obj .: "given")
<*> obj .: "intermediary"
<*> obj .: "expected"
testScriptPubKeyParseJSON :: Ctx -> Value -> Parser TestScriptPubKey
testScriptPubKeyParseJSON ctx = withObject "TestScriptPubKey" $ \obj -> do
given <- unSpkGiven <$> (spkGivenParseJSON ctx =<< obj .: "given")
inter <- spkIntermediaryParseJSON ctx =<< obj .: "intermediary"
expect <- spkExpectedParseJSON ctx =<< obj .: "expected"
return $ TestScriptPubKey given inter expect
newtype TestVector = TestVector
{ testScriptPubKey :: [TestScriptPubKey]
}
{ testScriptPubKey :: [TestScriptPubKey]
}
instance FromJSON TestVector where
parseJSON = withObject "TestVector" $ \obj ->
TestVector <$> obj .: "scriptPubKey"
testVectorParseJSON :: Ctx -> Value -> Parser TestVector
testVectorParseJSON ctx = withObject "TestVector" $ \obj ->
TestVector <$> (mapM (testScriptPubKeyParseJSON ctx) =<< obj .: "scriptPubKey")
jsonHex :: Text -> Parser ByteString
jsonHex = maybe (fail "Unable to decode hex") pure . decodeHex

534
test/Haskoin/TransactionSpec.hs
View File

@ -1,8 +1,14 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Haskoin.TransactionSpec (spec) where
import qualified Data.ByteString as B
import Control.Monad (unless)
import Data.ByteString qualified as B
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
@ -13,9 +19,9 @@ import Data.String.Conversions
import Data.Text (Text)
import Data.Word (Word32, Word64)
import Haskoin.Address
import Haskoin.Constants
import Haskoin.Data
import Haskoin.Keys
import Haskoin.Crypto
import Haskoin.Network.Constants
import Haskoin.Network.Data
import Haskoin.Script
import Haskoin.Transaction
import Haskoin.Util
@ -25,345 +31,317 @@ import Test.Hspec
import Test.Hspec.QuickCheck
import Test.QuickCheck
serialVals :: [SerialBox]
serialVals =
[ SerialBox $ arbitraryTx =<< arbitraryNetwork
, SerialBox $ arbitraryWitnessTx =<< arbitraryNetwork
, SerialBox $ arbitraryLegacyTx =<< arbitraryNetwork
, SerialBox $ arbitraryTxIn =<< arbitraryNetwork
, SerialBox $ arbitraryTxOut =<< arbitraryNetwork
, SerialBox arbitraryOutPoint
]
serialVals :: Ctx -> [SerialBox]
serialVals ctx =
[ SerialBox $ flip arbitraryTx ctx =<< arbitraryNetwork,
SerialBox $ flip arbitraryWitnessTx ctx =<< arbitraryNetwork,
SerialBox $ flip arbitraryLegacyTx ctx =<< arbitraryNetwork,
SerialBox $ flip arbitraryTxIn ctx =<< arbitraryNetwork,
SerialBox $ flip arbitraryTxOut ctx =<< arbitraryNetwork,
SerialBox arbitraryOutPoint
]
readVals :: [ReadBox]
readVals =
[ ReadBox arbitraryTxHash
, ReadBox $ arbitraryTx =<< arbitraryNetwork
, ReadBox $ arbitraryTxIn =<< arbitraryNetwork
, ReadBox $ arbitraryTxOut =<< arbitraryNetwork
, ReadBox arbitraryOutPoint
]
readVals :: Ctx -> [ReadBox]
readVals ctx =
[ ReadBox arbitraryTxHash,
ReadBox $ flip arbitraryTx ctx =<< arbitraryNetwork,
ReadBox $ flip arbitraryTxIn ctx =<< arbitraryNetwork,
ReadBox $ flip arbitraryTxOut ctx =<< arbitraryNetwork,
ReadBox arbitraryOutPoint
]
jsonVals :: [JsonBox]
jsonVals =
[ JsonBox arbitraryTxHash
, JsonBox $ arbitraryTx =<< arbitraryNetwork
, JsonBox $ arbitraryWitnessTx =<< arbitraryNetwork
, JsonBox $ arbitraryLegacyTx =<< arbitraryNetwork
, JsonBox $ arbitraryTxIn =<< arbitraryNetwork
, JsonBox $ arbitraryTxOut =<< arbitraryNetwork
, JsonBox arbitraryOutPoint
]
jsonVals :: Ctx -> [JsonBox]
jsonVals ctx =
[ JsonBox arbitraryTxHash,
JsonBox $ flip arbitraryTx ctx =<< arbitraryNetwork,
JsonBox $ flip arbitraryWitnessTx ctx =<< arbitraryNetwork,
JsonBox $ flip arbitraryLegacyTx ctx =<< arbitraryNetwork,
JsonBox $ flip arbitraryTxIn ctx =<< arbitraryNetwork,
JsonBox $ flip arbitraryTxOut ctx =<< arbitraryNetwork,
JsonBox arbitraryOutPoint
]
spec :: Spec
spec = do
testIdentity serialVals readVals jsonVals []
describe "Transaction properties" $ do
prop "decode and encode txid" $
forAll arbitraryTxHash $ \h -> hexToTxHash (txHashToHex h) == Just h
prop "from string transaction id" $
forAll arbitraryTxHash $ \h -> fromString (cs $ txHashToHex h) == h
prop "building address tx" $
forAll arbitraryNetwork $ \net ->
forAll arbitraryAddress $
forAll (arbitrarySatoshi net) . testBuildAddrTx net
prop "guess transaction size" $
forAll arbitraryNetwork $ \net ->
forAll (arbitraryAddrOnlyTxFull net) (testGuessSize net)
prop "choose coins" $
forAll arbitraryNetwork $ \net ->
forAll (listOf (arbitrarySatoshi net)) testChooseCoins
prop "choose multisig coins" $
forAll arbitraryNetwork $ \net ->
forAll arbitraryMSParam $
forAll (listOf (arbitrarySatoshi net)) . testChooseMSCoins
prop "sign and validate transaction" $
forAll arbitraryNetwork $ \net ->
forAll (arbitrarySigningData net) (testDetSignTx net)
prop "sign and validate (nested) transaction" $
forAll arbitraryNetwork $ \net ->
forAll (arbitrarySigningData net) (testDetSignNestedTx net)
prop "merge partially signed transactions" $
forAll arbitraryNetwork $ \net ->
property $ forAll (arbitraryPartialTxs net) (testMergeTx net)
describe "Transaction vectors" $ do
it "compute txid from tx" $ mapM_ testTxidVector txidVectors
it "build pkhash transaction (generated from bitcoind)" $
mapM_ testPKHashVector pkHashVectors
spec = prepareContext $ \ctx -> do
testIdentity (serialVals ctx) (readVals ctx) (jsonVals ctx) []
describe "Transaction properties" $ do
prop "decode and encode txid" $
forAll arbitraryTxHash $
\h -> hexToTxHash (txHashToHex h) == Just h
prop "from string transaction id" $
forAll arbitraryTxHash $
\h -> fromString (cs $ txHashToHex h) == h
prop "building address tx" $
forAll arbitraryNetwork $ \net ->
forAll arbitraryAddress $
forAll (arbitrarySatoshi net) . testBuildAddrTx net ctx
prop "guess transaction size" $
forAll arbitraryNetwork $ \net ->
forAll (arbitraryAddrOnlyTxFull net ctx) (testGuessSize net ctx)
prop "choose coins" $
forAll arbitraryNetwork $ \net ->
forAll (listOf (arbitrarySatoshi net)) testChooseCoins
prop "choose multisig coins" $
forAll arbitraryNetwork $ \net ->
forAll arbitraryMSParam $
forAll (listOf (arbitrarySatoshi net)) . testChooseMSCoins
prop "sign and validate transaction" $
forAll arbitraryNetwork $ \net ->
forAll (arbitrarySigningData net ctx) (testDetSignTx net ctx)
prop "sign and validate (nested) transaction" $
forAll arbitraryNetwork $ \net ->
forAll (arbitrarySigningData net ctx) (testDetSignNestedTx net ctx)
prop "merge partially signed transactions" $
forAll arbitraryNetwork $ \net ->
property $ forAll (arbitraryPartialTxs net ctx) (testMergeTx net ctx)
describe "Transaction vectors" $ do
it "compute txid from tx" $ mapM_ testTxidVector txidVectors
it "build pkhash transaction (generated from bitcoind)" $
mapM_ (testPKHashVector ctx) pkHashVectors
-- Txid Vectors
testTxidVector :: (Text, Text) -> Assertion
testTxidVector (tid, tx) =
assertEqual "txid" (Just tid) (txHashToHex . txHash <$> txM)
assertEqual "txid" (Just tid) (txHashToHex . txHash <$> txM)
where
txM = eitherToMaybe . runGetS deserialize =<< decodeHex tx
txidVectors :: [(Text, Text)]
txidVectors =
[
( "23b397edccd3740a74adb603c9756370fafcde9bcc4483eb271ecad09a94dd63"
, "0100000001b14bdcbc3e01bdaad36cc08e81e69c82e1060bc14e518db2b49aa4\
\3ad90ba26000000000490047304402203f16c6f40162ab686621ef3000b04e75\
\418a0c0cb2d8aebeac894ae360ac1e780220ddc15ecdfc3507ac48e1681a33eb\
\60996631bf6bf5bc0a0682c4db743ce7ca2b01ffffffff0140420f0000000000\
\1976a914660d4ef3a743e3e696ad990364e555c271ad504b88ac00000000"
)
,
( "c99c49da4c38af669dea436d3e73780dfdb6c1ecf9958baa52960e8baee30e73"
, "01000000010276b76b07f4935c70acf54fbf1f438a4c397a9fb7e633873c4dd3\
\bc062b6b40000000008c493046022100d23459d03ed7e9511a47d13292d3430a\
\04627de6235b6e51a40f9cd386f2abe3022100e7d25b080f0bb8d8d5f878bba7\
\d54ad2fda650ea8d158a33ee3cbd11768191fd004104b0e2c879e4daf7b9ab68\
\350228c159766676a14f5815084ba166432aab46198d4cca98fa3e9981d0a90b\
\2effc514b76279476550ba3663fdcaff94c38420e9d5000000000100093d0000\
\0000001976a9149a7b0f3b80c6baaeedce0a0842553800f832ba1f88ac000000\
\00"
)
,
( "f7fdd091fa6d8f5e7a8c2458f5c38faffff2d3f1406b6e4fe2c99dcc0d2d1cbb"
, "01000000023d6cf972d4dff9c519eff407ea800361dd0a121de1da8b6f4138a2\
\f25de864b4000000008a4730440220ffda47bfc776bcd269da4832626ac332ad\
\fca6dd835e8ecd83cd1ebe7d709b0e022049cffa1cdc102a0b56e0e04913606c\
\70af702a1149dc3b305ab9439288fee090014104266abb36d66eb4218a6dd31f\
\09bb92cf3cfa803c7ea72c1fc80a50f919273e613f895b855fb7465ccbc8919a\
\d1bd4a306c783f22cd3227327694c4fa4c1c439affffffff21ebc9ba20594737\
\864352e95b727f1a565756f9d365083eb1a8596ec98c97b7010000008a473044\
\0220503ff10e9f1e0de731407a4a245531c9ff17676eda461f8ceeb8c06049fa\
\2c810220c008ac34694510298fa60b3f000df01caa244f165b727d4896eb84f8\
\1e46bcc4014104266abb36d66eb4218a6dd31f09bb92cf3cfa803c7ea72c1fc8\
\0a50f919273e613f895b855fb7465ccbc8919ad1bd4a306c783f22cd32273276\
\94c4fa4c1c439affffffff01f0da5200000000001976a914857ccd42dded6df3\
\2949d4646dfa10a92458cfaa88ac00000000"
)
,
( "afd9c17f8913577ec3509520bd6e5d63e9c0fd2a5f70c787993b097ba6ca9fae"
, "010000000370ac0a1ae588aaf284c308d67ca92c69a39e2db81337e563bf40c5\
\9da0a5cf63000000006a4730440220360d20baff382059040ba9be98947fd678\
\fb08aab2bb0c172efa996fd8ece9b702201b4fb0de67f015c90e7ac8a193aeab\
\486a1f587e0f54d0fb9552ef7f5ce6caec032103579ca2e6d107522f012cd00b\
\52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff7d815b6447e35fbe\
\a097e00e028fb7dfbad4f3f0987b4734676c84f3fcd0e804010000006b483045\
\022100c714310be1e3a9ff1c5f7cacc65c2d8e781fc3a88ceb063c6153bf9506\
\50802102200b2d0979c76e12bb480da635f192cc8dc6f905380dd4ac1ff35a4f\
\68f462fffd032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e3\
\77c48f526a44741affffffff3f1f097333e4d46d51f5e77b53264db8f7f5d2e1\
\8217e1099957d0f5af7713ee010000006c493046022100b663499ef73273a378\
\8dea342717c2640ac43c5a1cf862c9e09b206fcb3f6bb8022100b09972e75972\
\d9148f2bdd462e5cb69b57c1214b88fc55ca638676c07cfc10d8032103579ca2\
\e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffff\
\ff0380841e00000000001976a914bfb282c70c4191f45b5a6665cad1682f2c9c\
\fdfb88ac80841e00000000001976a9149857cc07bed33a5cf12b9c5e0500b675\
\d500c81188ace0fd1c00000000001976a91443c52850606c872403c0601e69fa\
\34b26f62db4a88ac00000000"
)
]
[ ( "23b397edccd3740a74adb603c9756370fafcde9bcc4483eb271ecad09a94dd63",
"0100000001b14bdcbc3e01bdaad36cc08e81e69c82e1060bc14e518db2b49aa4\
\3ad90ba26000000000490047304402203f16c6f40162ab686621ef3000b04e75\
\418a0c0cb2d8aebeac894ae360ac1e780220ddc15ecdfc3507ac48e1681a33eb\
\60996631bf6bf5bc0a0682c4db743ce7ca2b01ffffffff0140420f0000000000\
\1976a914660d4ef3a743e3e696ad990364e555c271ad504b88ac00000000"
),
( "c99c49da4c38af669dea436d3e73780dfdb6c1ecf9958baa52960e8baee30e73",
"01000000010276b76b07f4935c70acf54fbf1f438a4c397a9fb7e633873c4dd3\
\bc062b6b40000000008c493046022100d23459d03ed7e9511a47d13292d3430a\
\04627de6235b6e51a40f9cd386f2abe3022100e7d25b080f0bb8d8d5f878bba7\
\d54ad2fda650ea8d158a33ee3cbd11768191fd004104b0e2c879e4daf7b9ab68\
\350228c159766676a14f5815084ba166432aab46198d4cca98fa3e9981d0a90b\
\2effc514b76279476550ba3663fdcaff94c38420e9d5000000000100093d0000\
\0000001976a9149a7b0f3b80c6baaeedce0a0842553800f832ba1f88ac000000\
\00"
),
( "f7fdd091fa6d8f5e7a8c2458f5c38faffff2d3f1406b6e4fe2c99dcc0d2d1cbb",
"01000000023d6cf972d4dff9c519eff407ea800361dd0a121de1da8b6f4138a2\
\f25de864b4000000008a4730440220ffda47bfc776bcd269da4832626ac332ad\
\fca6dd835e8ecd83cd1ebe7d709b0e022049cffa1cdc102a0b56e0e04913606c\
\70af702a1149dc3b305ab9439288fee090014104266abb36d66eb4218a6dd31f\
\09bb92cf3cfa803c7ea72c1fc80a50f919273e613f895b855fb7465ccbc8919a\
\d1bd4a306c783f22cd3227327694c4fa4c1c439affffffff21ebc9ba20594737\
\864352e95b727f1a565756f9d365083eb1a8596ec98c97b7010000008a473044\
\0220503ff10e9f1e0de731407a4a245531c9ff17676eda461f8ceeb8c06049fa\
\2c810220c008ac34694510298fa60b3f000df01caa244f165b727d4896eb84f8\
\1e46bcc4014104266abb36d66eb4218a6dd31f09bb92cf3cfa803c7ea72c1fc8\
\0a50f919273e613f895b855fb7465ccbc8919ad1bd4a306c783f22cd32273276\
\94c4fa4c1c439affffffff01f0da5200000000001976a914857ccd42dded6df3\
\2949d4646dfa10a92458cfaa88ac00000000"
),
( "afd9c17f8913577ec3509520bd6e5d63e9c0fd2a5f70c787993b097ba6ca9fae",
"010000000370ac0a1ae588aaf284c308d67ca92c69a39e2db81337e563bf40c5\
\9da0a5cf63000000006a4730440220360d20baff382059040ba9be98947fd678\
\fb08aab2bb0c172efa996fd8ece9b702201b4fb0de67f015c90e7ac8a193aeab\
\486a1f587e0f54d0fb9552ef7f5ce6caec032103579ca2e6d107522f012cd00b\
\52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff7d815b6447e35fbe\
\a097e00e028fb7dfbad4f3f0987b4734676c84f3fcd0e804010000006b483045\
\022100c714310be1e3a9ff1c5f7cacc65c2d8e781fc3a88ceb063c6153bf9506\
\50802102200b2d0979c76e12bb480da635f192cc8dc6f905380dd4ac1ff35a4f\
\68f462fffd032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e3\
\77c48f526a44741affffffff3f1f097333e4d46d51f5e77b53264db8f7f5d2e1\
\8217e1099957d0f5af7713ee010000006c493046022100b663499ef73273a378\
\8dea342717c2640ac43c5a1cf862c9e09b206fcb3f6bb8022100b09972e75972\
\d9148f2bdd462e5cb69b57c1214b88fc55ca638676c07cfc10d8032103579ca2\
\e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffff\
\ff0380841e00000000001976a914bfb282c70c4191f45b5a6665cad1682f2c9c\
\fdfb88ac80841e00000000001976a9149857cc07bed33a5cf12b9c5e0500b675\
\d500c81188ace0fd1c00000000001976a91443c52850606c872403c0601e69fa\
\34b26f62db4a88ac00000000"
)
]
-- Build address transactions vectors generated from bitcoin-core raw tx API
testPKHashVector :: ([(Text, Word32)], [(Text, Word64)], Text) -> Assertion
testPKHashVector (is, os, res) =
assertEqual
"Build PKHash Tx"
(Right res)
(encodeHex . runPutS . serialize <$> txE)
testPKHashVector :: Ctx -> ([(Text, Word32)], [(Text, Word64)], Text) -> Assertion
testPKHashVector ctx (is, os, res) =
assertEqual
"Build PKHash Tx"
(Right res)
(encodeHex . runPutS . serialize <$> txE)
where
txE = buildAddrTx btc (map f is) os
txE = buildAddrTx btc ctx (map f is) os
f (tid, ix) = OutPoint (fromJust $ hexToTxHash tid) ix
pkHashVectors :: [([(Text, Word32)], [(Text, Word64)], Text)]
pkHashVectors =
[
(
[
( "eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db"
, 14
)
]
, [("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb", 90000000)]
, "0100000001db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654\
\a1eb29eb0e00000000ffffffff01804a5d05000000001976a91424aa604689cc58\
\2292b97668bedd91dd5bf9374c88ac00000000"
[ ( [ ( "eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db",
14
)
,
(
[
( "eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db"
, 0
)
,
( "0001000000000000000000000000000000000000000000000000000000000000"
, 2147483647
)
]
,
[ ("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb", 1)
, ("19VCgS642vzEA1sdByoSn6GsWBwraV8D4n", 2100000000000000)
]
, "0100000002db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654\
\a1eb29eb0000000000ffffffff0000000000000000000000000000000000000000\
\000000000000000000000100ffffff7f00ffffffff0201000000000000001976a9\
\1424aa604689cc582292b97668bedd91dd5bf9374c88ac0040075af07507001976\
\a9145d16672f53981ff21c5f42b40d1954993cbca54f88ac00000000"
],
[("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb", 90000000)],
"0100000001db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654\
\a1eb29eb0e00000000ffffffff01804a5d05000000001976a91424aa604689cc58\
\2292b97668bedd91dd5bf9374c88ac00000000"
),
( [ ( "eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db",
0
),
( "0001000000000000000000000000000000000000000000000000000000000000",
2147483647
)
,
(
[
( "eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db"
, 0
)
,
( "0001000000000000000000000000000000000000000000000000000000000000"
, 2147483647
)
]
, []
, "0100000002db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654a\
\1eb29eb0000000000ffffffff000000000000000000000000000000000000000000\
\0000000000000000000100ffffff7f00ffffffff0000000000"
],
[ ("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb", 1),
("19VCgS642vzEA1sdByoSn6GsWBwraV8D4n", 2100000000000000)
],
"0100000002db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654\
\a1eb29eb0000000000ffffffff0000000000000000000000000000000000000000\
\000000000000000000000100ffffff7f00ffffffff0201000000000000001976a9\
\1424aa604689cc582292b97668bedd91dd5bf9374c88ac0040075af07507001976\
\a9145d16672f53981ff21c5f42b40d1954993cbca54f88ac00000000"
),
( [ ( "eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db",
0
),
( "0001000000000000000000000000000000000000000000000000000000000000",
2147483647
)
,
( []
,
[ ("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb", 1)
, ("19VCgS642vzEA1sdByoSn6GsWBwraV8D4n", 2100000000000000)
]
, "01000000000201000000000000001976a91424aa604689cc582292b97668bedd91d\
\d5bf9374c88ac0040075af07507001976a9145d16672f53981ff21c5f42b40d1954\
\993cbca54f88ac00000000"
)
]
],
[],
"0100000002db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654a\
\1eb29eb0000000000ffffffff000000000000000000000000000000000000000000\
\0000000000000000000100ffffff7f00ffffffff0000000000"
),
( [],
[ ("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb", 1),
("19VCgS642vzEA1sdByoSn6GsWBwraV8D4n", 2100000000000000)
],
"01000000000201000000000000001976a91424aa604689cc582292b97668bedd91d\
\d5bf9374c88ac0040075af07507001976a9145d16672f53981ff21c5f42b40d1954\
\993cbca54f88ac00000000"
)
]
-- Transaction Properties --
testBuildAddrTx :: Network -> Address -> TestCoin -> Bool
testBuildAddrTx net a (TestCoin v)
| isPubKeyAddress a = Right (PayPKHash (getAddrHash160 a)) == out
| isScriptAddress a = Right (PayScriptHash (getAddrHash160 a)) == out
| otherwise = undefined
testBuildAddrTx :: Network -> Ctx -> Address -> TestCoin -> Bool
testBuildAddrTx net ctx a (TestCoin v)
| isPubKeyAddress a = PayPKHash a.hash160 == out
| isScriptAddress a = PayScriptHash a.hash160 == out
| otherwise = undefined
where
tx = buildAddrTx net [] [(fromJust (addrToText net a), v)]
out =
decodeOutputBS $
scriptOutput $
head $ txOut (fromRight (error "Could not build transaction") tx)
out = either error id $ do
tx <- buildAddrTx net ctx [] [(fromJust (addrToText net a), v)]
unmarshal ctx (head tx.outputs).script
-- We compute an upper bound but it should be close enough to the real size
-- We give 2 bytes of slack on every signature (1 on r and 1 on s)
testGuessSize :: Network -> Tx -> Bool
testGuessSize net tx =
guess >= len && guess <= len + 2 * delta
testGuessSize :: Network -> Ctx -> Tx -> Bool
testGuessSize net ctx tx =
guess >= len && guess <= len + 2 * delta
where
delta = pki + sum (map fst msi)
guess = guessTxSize pki msi pkout msout
len = B.length $ runPutS $ serialize tx
ins = map f $ txIn tx
f i =
fromRight (error "Could not decode input") $
decodeInputBS net $ scriptInput i
ins = map f tx.inputs
f i = either error id $ unmarshal (net, ctx) i.script
pki = length $ filter isSpendPKHash ins
msi = concatMap shData ins
shData (ScriptHashInput _ (PayMulSig keys r)) = [(r, length keys)]
shData _ = []
out =
map
( fromRight (error "Could not decode transaction output")
. decodeOutputBS
. scriptOutput
)
$ txOut tx
out = map (either error id . unmarshal ctx . (.script)) tx.outputs
pkout = length $ filter isPayPKHash out
msout = length $ filter isPayScriptHash out
testChooseCoins :: [TestCoin] -> Word64 -> Word64 -> Int -> Property
testChooseCoins coins target byteFee nOut =
nOut >= 0
==> case chooseCoins target byteFee nOut True coins of
Right (chosen, change) ->
let outSum = sum $ map coinValue chosen
fee = guessTxFee byteFee nOut (length chosen)
in outSum == target + change + fee
Left _ ->
let fee = guessTxFee byteFee nOut (length coins)
in target == 0 || s < target + fee
nOut >= 0 ==>
case chooseCoins target byteFee nOut True coins of
Right (chosen, change) ->
let outSum = sum $ map coinValue chosen
fee = guessTxFee byteFee nOut (length chosen)
in outSum == target + change + fee
Left _ ->
let fee = guessTxFee byteFee nOut (length coins)
in target == 0 || s < target + fee
where
s = sum $ map coinValue coins
testChooseMSCoins ::
(Int, Int) ->
[TestCoin] ->
Word64 ->
Word64 ->
Int ->
Property
(Int, Int) ->
[TestCoin] ->
Word64 ->
Word64 ->
Int ->
Property
testChooseMSCoins (m, n) coins target byteFee nOut =
nOut >= 0
==> case chooseMSCoins target byteFee (m, n) nOut True coins of
Right (chosen, change) ->
let outSum = sum $ map coinValue chosen
fee = guessMSTxFee byteFee (m, n) nOut (length chosen)
in outSum == target + change + fee
Left _ ->
let fee = guessMSTxFee byteFee (m, n) nOut (length coins)
in target == 0 || s < target + fee
nOut >= 0 ==>
case chooseMSCoins target byteFee (m, n) nOut True coins of
Right (chosen, change) ->
let outSum = sum $ map coinValue chosen
fee = guessMSTxFee byteFee (m, n) nOut (length chosen)
in outSum == target + change + fee
Left _ ->
let fee = guessMSTxFee byteFee (m, n) nOut (length coins)
in target == 0 || s < target + fee
where
s = sum $ map coinValue coins
{- Signing Transactions -}
testDetSignTx :: Network -> (Tx, [SigInput], [SecKeyI]) -> Bool
testDetSignTx net (tx, sigis, prv) =
not (verifyStdTx net tx verData)
&& not (verifyStdTx net txSigP verData)
&& verifyStdTx net txSigC verData
testDetSignTx :: Network -> Ctx -> (Tx, [SigInput], [PrivateKey]) -> Bool
testDetSignTx net ctx (tx, sigis, prv) =
not verify1 && not verify2 && verify3
where
txSigP =
fromRight (error "Could not decode transaction") $
signTx net tx sigis (map secKeyData (tail prv))
txSigC =
fromRight (error "Could not decode transaction") $
signTx net txSigP sigis [secKeyData (head prv)]
verData = map (\(SigInput s v o _ _) -> (s, v, o)) sigis
verify1 = verifyStdTx net ctx tx verData
verify2 = verifyStdTx net ctx txSigP verData
verify3 = verifyStdTx net ctx txSigC verData
txSigP = either error id $ signTx net ctx tx sigis (map (.key) (tail prv))
txSigC = either error id $ signTx net ctx txSigP sigis [(head prv).key]
sigData SigInput {..} = (script, value, outpoint)
verData = map sigData sigis
testDetSignNestedTx :: Network -> (Tx, [SigInput], [SecKeyI]) -> Bool
testDetSignNestedTx net (tx, sigis, prv) =
not (verifyStdTx net tx verData)
&& not (verifyStdTx net txSigP verData)
&& verifyStdTx net txSigC verData
testDetSignNestedTx :: Network -> Ctx -> (Tx, [SigInput], [PrivateKey]) -> Bool
testDetSignNestedTx net ctx (tx, sigis, prv) =
not verify1 && not verify2 && verify3
where
verify1 = verifyStdTx net ctx tx verData
verify2 = verifyStdTx net ctx txSigP verData
verify3 = verifyStdTx net ctx txSigC verData
txSigP =
fromRight (error "Could not decode transaction") $
signNestedWitnessTx net tx sigis (secKeyData <$> tail prv)
either error id $
signNestedWitnessTx net ctx tx sigis ((.key) <$> tail prv)
txSigC =
fromRight (error "Could not decode transaction") $
signNestedWitnessTx net txSigP sigis [secKeyData (head prv)]
either error id $
signNestedWitnessTx net ctx txSigP sigis [(head prv).key]
verData = handleSegwit <$> sigis
handleSegwit (SigInput s v o _ _)
| isSegwit s = (toP2SH $ encodeOutput s, v, o)
| otherwise = (s, v, o)
| isSegwit s = (toP2SH (encodeOutput ctx s), v, o)
| otherwise = (s, v, o)
testMergeTx :: Network -> ([Tx], [(ScriptOutput, Word64, OutPoint, Int, Int)]) -> Bool
testMergeTx net (txs, os) =
and
[ isRight mergeRes
, length (txIn mergedTx) == length os
, if enoughSigs
then isValid
else not isValid
, -- Signature count == min (length txs) (sum required signatures)
sum (map snd sigMap) == min (length txs) (sum (map fst sigMap))
]
testMergeTx :: Network -> Ctx -> ([Tx], [(ScriptOutput, Word64, OutPoint, Int, Int)]) -> Bool
testMergeTx net ctx (txs, os) =
and
[ isRight mergeRes,
length mergedTx.inputs == length os,
if enoughSigs
then isValid
else not isValid,
-- Signature count == min (length txs) (sum required signatures)
sum (map snd sigMap) == min (length txs) (sum (map fst sigMap))
]
where
outs = map (\(so, val, op, _, _) -> (so, val, op)) os
mergeRes = mergeTxs net txs outs
mergeRes = mergeTxs net ctx txs outs
mergedTx = fromRight (error "Could not merge") mergeRes
isValid = verifyStdTx net mergedTx outs
isValid = verifyStdTx net ctx mergedTx outs
enoughSigs = all (\(m, c) -> c >= m) sigMap
sigMap =
map (\((_, _, _, m, _), inp) -> (m, sigCnt inp)) $
zip os $ txIn mergedTx
sigFun (_, _, _, m, _) inp = (m, sigCnt inp)
sigMap = zipWith sigFun os mergedTx.inputs
sigCnt inp =
case decodeInputBS net $ scriptInput inp of
Right (RegularInput (SpendMulSig sigs)) -> length sigs
Right (ScriptHashInput (SpendMulSig sigs) _) -> length sigs
_ -> error "Invalid input script type"
case unmarshal (net, ctx) inp.script of
Right (RegularInput (SpendMulSig sigs)) -> length sigs
Right (ScriptHashInput (SpendMulSig sigs) _) -> length sigs
_ -> error "Invalid input script type"

58
test/Haskoin/UtilSpec.hs
View File

@ -1,58 +1,57 @@
module Haskoin.UtilSpec (
spec,
customCerealID,
readTestFile,
) where
{-# LANGUAGE ImportQualifiedPost #-}
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as A
module Haskoin.UtilSpec (spec) where
import Data.Aeson
import Data.Aeson.Encoding (encodingToLazyByteString)
import Data.Aeson.Types (Parser, parseMaybe)
import qualified Data.ByteString as BS
import Data.Aeson.Types (Parser, parse)
import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.Either (fromLeft, fromRight, isLeft, isRight)
import Data.Foldable (toList)
import Data.List (permutations)
import Data.Map.Strict (singleton)
import Data.Maybe
import qualified Data.Sequence as Seq
import Data.Sequence qualified as Seq
import Data.Serialize as S
import Haskoin.Crypto
import Haskoin.Util
import Haskoin.Util.Arbitrary
import Test.Hspec
import Test.Hspec.QuickCheck
import Test.QuickCheck
import Test.QuickCheck (forAll)
spec :: Spec
spec =
describe "utility functions" $ do
prop "bsToInteger . integerToBS" getPutInteger
prop "decodeHex . encodeHex" $ forAll arbitraryBS fromToHex
prop "compare updateIndex with Data.Sequence" testUpdateIndex
prop "matchTemplate" testMatchTemplate
prop "testing matchTemplate with two lists" testMatchTemplateLen
prop "test eitherToMaybe" testEitherToMaybe
prop "test maybeToEither" testMaybeToEither
describe "utility functions" $ do
prop "bsToInteger . integerToBS" getPutInteger
prop "decodeHex . encodeHex" $ forAll arbitraryBS fromToHex
prop "compare updateIndex with Data.Sequence" testUpdateIndex
prop "matchTemplate" testMatchTemplate
prop "testing matchTemplate with two lists" testMatchTemplateLen
prop "test eitherToMaybe" testEitherToMaybe
prop "test maybeToEither" testMaybeToEither
{- Various utilities -}
getPutInteger :: Integer -> Bool
getPutInteger i = bsToInteger (integerToBS $ abs i) == abs i
fromToHex :: BS.ByteString -> Bool
fromToHex :: ByteString -> Bool
fromToHex bs = decodeHex (encodeHex bs) == Just bs
testUpdateIndex :: [Int] -> Int -> Int -> Bool
testUpdateIndex xs v i =
updateIndex i xs (const v) == toList (Seq.update i v $ Seq.fromList xs)
updateIndex i xs (const v) == toList (Seq.update i v $ Seq.fromList xs)
testMatchTemplate :: [Int] -> Int -> Bool
testMatchTemplate as i = catMaybes res == bs
where
res = matchTemplate as bs (==)
idx =
if null as
then 0
else i `mod` length as
if null as
then 0
else i `mod` length as
bs = permutations as !! idx
testMatchTemplateLen :: [Int] -> [Int] -> Bool
@ -67,14 +66,3 @@ testEitherToMaybe e = isNothing (eitherToMaybe e)
testMaybeToEither :: Maybe Int -> String -> Bool
testMaybeToEither (Just v) str = maybeToEither str (Just v) == Right v
testMaybeToEither m str = maybeToEither str m == Left str
{-- Test Utilities --}
customCerealID :: Eq a => Get a -> Putter a -> a -> Bool
customCerealID g p a = runGet g (runPut (p a)) == Right a
readTestFile :: A.FromJSON a => FilePath -> IO a
readTestFile fp =
A.eitherDecodeFileStrict ("data/" <> fp) >>= either (error . message) return
where
message aesonErr = "Could not read test file " <> fp <> ": " <> aesonErr