diff --git a/CHANGELOG.md b/CHANGELOG.md index 41245b30..5a64cb80 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,315 +1,13 @@ # 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 -### Changed -- Serialisation test now works for both strict and lazy bytestrings. - -## 0.21.1 -### Changed -- Make Base58 faster. - -## 0.21.0 -### 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. - -### 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 -### Added -- Support Bech32m address format for Taproot. - -## 0.20.4 -### Fixed -- Add missing case for witness version. - -## 0.20.3 -### Fixed -- Allow unknown inv types. - -## 0.20.2 -### Fixed -- Allow unknown messages of zero length. - -## 0.20.1 -### Fixed -- Correct case where binary search returned the wrong element. - -## 0.20.0 -### Chaged -- Use bytes instead of binary or cereal. - -## 0.19.0 -### Added -- Hashable instances for extended keys. - -### Changed -- Mnemonic passphrases now `Text` instead of `ByteString`. - -### Fixed -- Tests now pass for witness addresses. - -## 0.18.0 -### Added -- Support SegWit addresses with version other than 0. - -## 0.17.6 -### Added -- Serialize instances for `XPubKey` and `XPrvKey`. - -## 0.17.5 -### Fixed -- Handle special case in block header binary search function. - -## 0.17.4 -### Fixed -- Bounds check too restrictive in block header binary search function. - -## 0.17.3 -### Changed -- Reduce minimum version of text package dependency. - -## 0.17.2 -### 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.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 -### 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. -- Update to latest secp256k1 bindings. - -## 0.14.1 -### Fixed -- Correct some Bitcoin Cash Testnet3 seeds. -- Add helpers for writing Data.Serialize and Data.Aeson identity tests - -## 0.14.0 -### 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 -### Changed -- Expose the Arbitrary test instances under Haskoin.Util.Arbitrary - -## 0.13.5 -### Changed -- Provide meaningful JSON instances for most types. - -## 0.13.4 -### Added -- Support for Bitcoin Cash May 2020 hard fork. - -## 0.13.3 -### Changed -- Improve code and documentation organisation. - -## 0.13.2 -### Changed -- Move all packages from Network.Haskoin namespace to Haskoin namespace. -- Expose all top-level modules directly. - -## 0.13.1 -### Changed -- Faster JSON serialization. - -## 0.13.0 -### 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.11.0 -### Added -- High-level representation of segwit v0 data and auxilliary functions. - -### Changed -- Adds handling of segwit signing parameters to transaction signing code. - -## 0.10.1 -### Added -- Lower bound versions for some dependencies. - -## 0.10.0 -### Added -- DeepSeq instances for all data types. - -### Changed -- There is no `SockAddr` inside `NetworkAddress` anymore. - -## 0.9.8 -### Added -- Ord instance for `DerivPathI` - -## 0.9.7 -### Added -- JSON encoding/decoding for blocks. - -### Fixed -- Fix lowercase HRP test for Bech32. - -## 0.9.6 -### Added -- `bloomRelevantUpdate` implementation for Bloom filters (thanks to @IlyasRidhuan). - -### Fixed -- Fix for Bech32 encoding (thanks to @pavel-main). - -## 0.9.5 -### Added -- Expose functions added in 0.9.4. - -## 0.9.4 -### 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 -### Added -- Some support for P2WPKH-over-P2SH addresses. - -## 0.9.2 -### Removed -- Disable unnecessary `-O2` optimisation added in previous version. - -### Added -- Allow decoding unknown P2P messages. - -## 0.9.1 -### Added -- Add a function to produce a structured signature over a transaction. -- Enable `-O2` optimisations. - -## 0.9.0 -### 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.3 -### Added -- Add reward halving interval parameter to network constants. - -## 0.8.2 -### Added -- Recognize `OP_CHECKDATASIG` and `OP_CHECKDATASIGVERIFY` opcodes. - -## 0.8.1 -### Added -- Add instances of `Hashable` and `Generic` where possible. - -## 0.8.0 -### Removed -- Remove `deepseq` dependency. -- Remove network constant reference from address and extended keys. - -## 0.7.0 -### 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 -### Added -- Compatibility with latest GHC and base. - -### Changed -- Update minimum base to 4.9. - -## 0.6.0 -### 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 -### Changed -- Make dependencies more specific. - -## 0.5.1 -### Changed -- Remove some unneeded dependencies from `stack.yaml`. -- Change `secp256k1` dependency to `secp256k1-haskell`. - -## 0.5.0 -### Added -- Support for Bitcoin Cash network block sychronization. -- Support for Bitcoin Cash signatures. -- Initial work on SegWit support. -- New version of `secp256k1` bindings. -- Block header validation. -- Support for RegTest networks on Bitcoin and Bitcoin Cash. -- Support for Bitcoin Cash Testnet3 Network. -- Support for new Haskoin Wallet. -- Minikey decoding for Casascius coins. -- New tests for various networks and new features. -- Added `CHANGELOG.md` file. -- Support for SegWit addresses. -- Support for CashAddr addresses. +## 0.1.0 ### 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`. -- New documentation. -- Updated `.gitignore`. -- Renamed network constants to use same style for BTC and BCH. -- Network constants must be passed explicitly. -- 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. -- Removed script evaluator and related tests. +- Forked from `haskoin-core` 0.21.1 +- Removed Bitcoin Cash support diff --git a/LICENSE b/LICENSE index af376dd7..2f8b64cd 100644 --- a/LICENSE +++ b/LICENSE @@ -1,19 +1,12 @@ Copyright 2020 Haskoin Developers +Copyright 2022 Haskell-Bitcoin Developers -Permission is hereby granted, free of charge, to any person obtaining a copy of -this software and associated documentation files (the "Software"), to deal in -the Software without restriction, including without limitation the rights to -use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of -the Software, and to permit persons to whom the Software is furnished to do so, -subject to the following conditions: +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. +1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS -FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR -COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER -IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. +3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md index ef873d66..8363be73 100644 --- a/README.md +++ b/README.md @@ -1,20 +1,19 @@ # Haskoin Core -Haskoin Core is a library of Bitcoin and Bitcoin Cash functions written in Haskell featuring: +Haskoin Core is a library of Bitcoin functions written in Haskell featuring: - Hashing functions (SHA-256, RIPEMD-160) - Base58 support -- CashAddr support - Bech32 suport - BIP32 extended key derivation and parsing (m/1'/2/3) - BIP39 mnemonic keys - ECDSA secp256k1 cryptographic primitives - Script parsing - Building and signing of standard transactions (regular, multisig, p2sh, segwit) -- Parsing and manipulation of all Bitcoin and Bitcoin Cash protocol messages +- Parsing and manipulation of all Bitcoin protocol messages - Bloom filters and partial merkle trees (used in SPV wallets) - Comprehensive test suite ## Contributing -Please use `ormolu` (or `fourmolu`) to format code prior to submission. See `scripts/pre-commit.sh` for an example pre-commit hook. +Please use `fourmolu` to format code prior to submission. diff --git a/Setup.hs b/Setup.hs index 9a994af6..902b3873 100644 --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,4 @@ import Distribution.Simple + + main = defaultMain diff --git a/haskoin-core.cabal b/bitcoin.cabal similarity index 89% rename from haskoin-core.cabal rename to bitcoin.cabal index 9a6265cf..6d23c1f1 100644 --- a/haskoin-core.cabal +++ b/bitcoin.cabal @@ -4,18 +4,19 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -name: haskoin-core -version: 0.21.2 -synopsis: Bitcoin & Bitcoin Cash library for Haskell -description: Please see the README on GitHub at +name: bitcoin +version: 0.1.0 +synopsis: Bitcoin library for Haskell +description: Please see the README on GitHub at category: Bitcoin, Finance, Network -homepage: http://github.com/haskoin/haskoin#readme -bug-reports: http://github.com/haskoin/haskoin/issues +homepage: http://github.com/haskell-bitcoin/bitcoin#readme +bug-reports: http://github.com/haskell-bitcoin/bitcoin/issues author: Philippe Laprade, Jean-Pierre Rupp, - Matthew Wraith -maintainer: jprupp@protonmail.ch -license: MIT + Matthew Wraith, + Keagan McClelland +maintainer: keagan.mcclelland@gmail.com +license: BSD3 license-file: LICENSE build-type: Simple extra-source-files: @@ -38,7 +39,7 @@ extra-source-files: source-repository head type: git - location: git://github.com/haskoin/haskoin.git + location: git://github.com/haskell-bitcoin/bitcoin.git library exposed-modules: @@ -46,7 +47,6 @@ library Haskoin.Address Haskoin.Address.Base58 Haskoin.Address.Bech32 - Haskoin.Address.CashAddr Haskoin.Block Haskoin.Block.Common Haskoin.Block.Headers @@ -129,7 +129,6 @@ test-suite spec main-is: Spec.hs other-modules: Haskoin.Address.Bech32Spec - Haskoin.Address.CashAddrSpec Haskoin.AddressSpec Haskoin.BlockSpec Haskoin.Crypto.HashSpec @@ -143,7 +142,7 @@ test-suite spec Haskoin.Transaction.TaprootSpec Haskoin.TransactionSpec Haskoin.UtilSpec - Paths_haskoin_core + Paths_bitcoin hs-source-dirs: test build-depends: @@ -155,6 +154,7 @@ test-suite spec , base16 >=0.3.0.1 , base64 ==0.4.* , binary >=0.8.8 + , bitcoin , bytes >=0.17 , bytestring >=0.10.10.0 , cereal >=0.5.8 @@ -164,7 +164,6 @@ test-suite spec , deepseq >=1.4.4.0 , entropy >=0.4.1.5 , hashable >=1.3.0.0 - , haskoin-core , hspec >=2.7.1 , lens >=4.18.1 , lens-aeson >=1.1 diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 00000000..f4c53a55 --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,12 @@ +indentation: 4 +function-arrows: trailing +comma-style: leading +import-export-style: diff-friendly +indent-wheres: false +record-brace-space: false +newlines-between-decls: 2 +haddock-style: single-line +let-style: auto +in-style: right-align +respectful: false +fixities: [] diff --git a/package.yaml b/package.yaml index 84d7d563..df436eaf 100644 --- a/package.yaml +++ b/package.yaml @@ -1,18 +1,19 @@ -name: haskoin-core -version: 0.21.2 -synopsis: Bitcoin & Bitcoin Cash library for Haskell -description: Please see the README on GitHub at +name: bitcoin +version: 0.1.0 +synopsis: Bitcoin library for Haskell +description: Please see the README on GitHub at category: Bitcoin, Finance, Network author: - Philippe Laprade - Jean-Pierre Rupp - Matthew Wraith -maintainer: jprupp@protonmail.ch -license: MIT + - Keagan McClelland +maintainer: keagan.mcclelland@gmail.com +license: BSD3 license-file: LICENSE -homepage: http://github.com/haskoin/haskoin#readme -git: git://github.com/haskoin/haskoin.git -bug-reports: http://github.com/haskoin/haskoin/issues +homepage: http://github.com/haskell-bitcoin/bitcoin#readme +git: git://github.com/haskell-bitcoin/bitcoin.git +bug-reports: http://github.com/haskell-bitcoin/bitcoin/issues extra-source-files: - data/*.json - README.md @@ -50,21 +51,19 @@ dependencies: - vector >= 0.12.1.2 library: source-dirs: src - other-modules: - Haskoin.Keys.Extended.Internal + other-modules: Haskoin.Keys.Extended.Internal when: - condition: false - other-modules: Paths_haskoin_core + other-modules: Paths_bitcoin tests: spec: main: Spec.hs source-dirs: test verbatim: - build-tool-depends: - hspec-discover:hspec-discover + build-tool-depends: hspec-discover:hspec-discover dependencies: - base64 ^>= 0.4 - - haskoin-core + - bitcoin - hspec >= 2.7.1 - HUnit >= 1.6.0.0 - QuickCheck >= 2.13.2 diff --git a/scripts/PsbtSignTest.hs b/scripts/PsbtSignTest.hs index 54120215..e0eecdd6 100644 --- a/scripts/PsbtSignTest.hs +++ b/scripts/PsbtSignTest.hs @@ -8,11 +8,13 @@ import Haskoin (PartiallySignedTransaction, SecKey) import qualified Haskoin as H import System.Environment (getArgs) + main :: IO () main = do keyText <- pack . head <$> getArgs let key = maybe (error "Unable to decode key") H.secKeyData $ H.fromWif H.btcRegTest keyText BS.interact $ S.encode . either error (onPsbt key) . S.decode + onPsbt :: SecKey -> PartiallySignedTransaction -> PartiallySignedTransaction onPsbt key = H.signPSBT H.btcRegTest (H.secKeySigner key) diff --git a/src/Haskoin.hs b/src/Haskoin.hs index 6feb41b3..1b1ffc39 100644 --- a/src/Haskoin.hs +++ b/src/Haskoin.hs @@ -1,15 +1,9 @@ -{- | -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. --} +-- | +-- 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, @@ -33,3 +27,4 @@ import Haskoin.Network as Network import Haskoin.Script as Script import Haskoin.Transaction as Transaction import Haskoin.Util as Util + diff --git a/src/Haskoin/Address.hs b/src/Haskoin/Address.hs index c0ee8ed8..ab5f99ae 100644 --- a/src/Haskoin/Address.hs +++ b/src/Haskoin/Address.hs @@ -5,16 +5,11 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{- | -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. --} +-- | +-- Stability : experimental +-- Portability : POSIX +-- +-- Base58, Bech32 address and WIF private key serialization support. module Haskoin.Address ( -- * Addresses Address (..), @@ -26,7 +21,6 @@ module Haskoin.Address ( addrToText, textToAddr, bech32ToAddr, - cashToAddr, base58ToAddr, addrToJSON, addrToEncoding, @@ -50,7 +44,6 @@ module Haskoin.Address ( scriptToAddressBS, module Haskoin.Address.Base58, module Haskoin.Address.Bech32, - module Haskoin.Address.CashAddr, ) where import Control.Applicative @@ -75,34 +68,34 @@ 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.Util --- | Address format for Bitcoin and Bitcoin Cash. + +-- | Address format for Bitcoin data Address = -- | pay to public key hash (regular) PubKeyAddress - { -- | RIPEMD160 hash of public key's SHA256 hash - getAddrHash160 :: !Hash160 + { getAddrHash160 :: !Hash160 + -- ^ RIPEMD160 hash of public key's SHA256 hash } | -- | pay to script hash ScriptAddress - { -- | RIPEMD160 hash of script's SHA256 hash - getAddrHash160 :: !Hash160 + { getAddrHash160 :: !Hash160 + -- ^ RIPEMD160 hash of script's SHA256 hash } | -- | pay to witness public key hash WitnessPubKeyAddress - { -- | RIPEMD160 hash of public key's SHA256 hash - getAddrHash160 :: !Hash160 + { getAddrHash160 :: !Hash160 + -- ^ RIPEMD160 hash of public key's SHA256 hash } | -- | pay to witness script hash WitnessScriptAddress - { -- | HASH256 hash of script - getAddrHash256 :: !Hash256 + { getAddrHash256 :: !Hash256 + -- ^ HASH256 hash of script } | -- | other witness address WitnessAddress @@ -112,6 +105,7 @@ data Address deriving (Eq, Ord, Generic, Show, Read, Hashable, NFData) + instance Serial Address where serialize (PubKeyAddress k) = do putWord8 0x00 @@ -131,6 +125,7 @@ instance Serial Address where putWord64be (fromIntegral (B.length d)) putByteString d + deserialize = getWord8 >>= \case 0x00 -> PubKeyAddress <$> deserialize @@ -138,55 +133,64 @@ instance Serial Address where 0x02 -> WitnessPubKeyAddress <$> deserialize 0x03 -> WitnessScriptAddress <$> deserialize 0x04 -> - WitnessAddress <$> getWord8 + 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 + instance Binary Address where put = serialize get = deserialize + -- | 'Address' pays to a public key hash. isPubKeyAddress :: Address -> Bool isPubKeyAddress PubKeyAddress{} = True isPubKeyAddress _ = False + -- | 'Address' pays to a script hash. isScriptAddress :: Address -> Bool 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 _ = False + isWitnessScriptAddress :: Address -> Bool isWitnessScriptAddress WitnessScriptAddress{} = True isWitnessScriptAddress _ = False + isWitnessAddress :: Address -> Bool 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'. --} + +-- | JSON parsing for Bitcoin addresses. Works with 'Base58', and +-- 'Bech32'. addrFromJSON :: Network -> Value -> Parser Address addrFromJSON net = withText "address" $ \t -> @@ -194,19 +198,12 @@ addrFromJSON net = 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', or 'Bech32' +-- 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 a@PubKeyAddress{} = Just . encodeBase58Check . runPutS $ base58put net a +addrToText net a@ScriptAddress{} = Just . encodeBase58Check . runPutS $ base58put net a addrToText net WitnessPubKeyAddress{getAddrHash160 = h} = do hrp <- getBech32Prefix net segwitEncode hrp 0 (B.unpack (runPutS $ serialize h)) @@ -217,18 +214,12 @@ addrToText net WitnessAddress{getAddrVersion = v, getAddrData = d} = do hrp <- getBech32Prefix net segwitEncode hrp v (B.unpack d) --- | Parse 'Base58', 'Bech32' or 'CashAddr' address, depending on network. + +-- | Parse 'Base58', or 'Bech32' address, depending on network. textToAddr :: Network -> Text -> Maybe Address textToAddr net txt = - cashToAddr net txt <|> bech32ToAddr net txt <|> base58ToAddr 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 bech32ToAddr :: Network -> Text -> Maybe Address bech32ToAddr net txt = do @@ -241,10 +232,12 @@ bech32ToAddr net txt = do _ -> Nothing _ -> Just $ WitnessAddress ver bs + base58ToAddr :: Network -> Text -> Maybe Address base58ToAddr net txt = eitherToMaybe . runGetS (base58get net) =<< decodeBase58Check txt + base58get :: MonadGet m => Network -> m Address base58get net = do pfx <- getWord8 @@ -256,6 +249,7 @@ base58get net = do | x == getScriptPrefix net = return $ ScriptAddress a | otherwise = fail "Does not recognize address prefix" + base58put :: MonadPut m => Network -> Address -> m () base58put net (PubKeyAddress h) = do putWord8 (getAddrPrefix net) @@ -265,20 +259,23 @@ base58put net (ScriptAddress h) = do 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 + -- | 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. --} + +-- | 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 backwards-compatible SegWit P2SH-P2WPKH address from a public key. pubKeyCompatWitnessAddr :: PubKeyI -> Address pubKeyCompatWitnessAddr = @@ -290,38 +287,42 @@ pubKeyCompatWitnessAddr = . runPutS . serialize -{- | 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 + -- | Obtain a standard pay-to-script-hash (P2SH) address from a 'Hash160'. p2shAddr :: Hash160 -> Address p2shAddr = ScriptAddress + -- | Obtain a SegWit pay-to-witness-script-hash (P2WSH) address from a 'Hash256' 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 -{- | Compute a SegWit pay-to-witness-script-hash (P2WSH) address for an output - script. --} + +-- | Compute a SegWit pay-to-witness-script-hash (P2WSH) address for an output +-- script. payToWitnessScriptAddress :: ScriptOutput -> Address payToWitnessScriptAddress = p2wshAddr . sha256 . encodeOutputBS + -- | Compute a backwards-compatible SegWit P2SH-P2WSH address. payToNestedScriptAddress :: ScriptOutput -> Address payToNestedScriptAddress = p2shAddr . addressHash . encodeOutputBS . toP2WSH . encodeOutput -{- | 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 @@ -331,24 +332,29 @@ addressToOutput = WitnessScriptAddress h -> PayWitnessScriptHash h WitnessAddress v d -> PayWitness v d + -- | Get output script AST for an 'Address'. addressToScript :: Address -> Script addressToScript = encodeOutput . addressToOutput + -- | Encode address as output script in 'ByteString' form. addressToScriptBS :: Address -> ByteString addressToScriptBS = runPutS . serialize . addressToScript + -- | 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 + -- | Decode a serialized script into an 'Address'. scriptToAddressBS :: ByteString -> Either String Address scriptToAddressBS = maybeToEither "Could not decode address" . outputAddress <=< decodeOutputBS + -- | Get the 'Address' of a 'ScriptOutput'. outputAddress :: ScriptOutput -> Maybe Address outputAddress = @@ -361,6 +367,7 @@ outputAddress = PayWitness v d -> Just $ WitnessAddress v d _ -> Nothing + -- | Infer the 'Address' of a 'ScriptInput'. inputAddress :: ScriptInput -> Maybe Address inputAddress = diff --git a/src/Haskoin/Address/Base58.hs b/src/Haskoin/Address/Base58.hs index 951aa128..b4162e32 100644 --- a/src/Haskoin/Address/Base58.hs +++ b/src/Haskoin/Address/Base58.hs @@ -1,16 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} -{- | -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). --} +-- | +-- Stability : experimental +-- Portability : POSIX +-- +-- Support for legacy 'Base58' addresses. Superseded by Bech32 for Bitcoin module Haskoin.Address.Base58 ( -- * Base58 Base58, @@ -38,37 +32,43 @@ import Haskoin.Crypto.Hash import Haskoin.Util import Numeric (readInt, showIntAtBase) + -- | 'Base58' classic Bitcoin address format. type Base58 = Text + -- | Symbols for Base58 encoding. b58Data :: ByteString b58Data = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz" + b58Array :: Array Int Word8 b58Array = listArray (0, 57) (BS.unpack b58Data) + b58InvArray :: Array Word8 (Maybe Int) 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 !) + -- | Convert a 'Base58' character into the number it represents. 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 = @@ -81,9 +81,9 @@ decodeBase58I s = 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 @@ -94,6 +94,7 @@ encodeBase58 bs = | BS.null b = T.empty | otherwise = encodeBase58I $ bsToInteger b + -- | Decode a 'Base58'-encoded 'Text' to a 'ByteString'. decodeBase58 :: Base58 -> Maybe ByteString decodeBase58 t = @@ -105,17 +106,17 @@ decodeBase58 t = | BS.null b = Just BS.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 -{- | 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 diff --git a/src/Haskoin/Address/Bech32.hs b/src/Haskoin/Address/Bech32.hs index 021da7f5..98793648 100644 --- a/src/Haskoin/Address/Bech32.hs +++ b/src/Haskoin/Address/Bech32.hs @@ -1,17 +1,12 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} -{- | -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. --} +-- | +-- 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, @@ -58,49 +53,60 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as E import Data.Word (Word8) + data Bech32Encoding = Bech32 | Bech32m deriving (Eq, Show, Ord, Enum) + -- | Bech32 human-readable string. type Bech32 = Text + -- | Human-readable part of 'Bech32' address. type HRP = Text + -- | Data part of 'Bech32' address. type Data = [Word8] + (.>>.), (.<<.) :: Bits a => a -> Int -> a (.>>.) = unsafeShiftR (.<<.) = unsafeShiftL + -- | Five-bit word for Bech32. newtype Word5 = 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 + -- | Convert an integer number into a five-bit word. 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 (UnsafeWord5 x) = fromIntegral x {-# INLINE fromWord5 #-} {-# SPECIALIZE INLINE fromWord5 :: Word5 -> Word8 #-} + -- | 'Bech32' character map as array of five-bit integers to character. charset :: Array Word5 Char charset = listArray (UnsafeWord5 0, UnsafeWord5 31) "qpzry9x8gf2tvdw0s3jn54khce6mua7l" + -- | Convert a character to its five-bit value from 'Bech32' 'charset'. charsetMap :: Char -> Maybe Word5 charsetMap c @@ -111,6 +117,7 @@ charsetMap c inv = listArray ('0', 'Z') (repeat Nothing) // map swap (assocs charset) swap (a, b) = (toUpper b, Just a) + -- | Calculate or validate 'Bech32' checksum. bech32Polymod :: [Word5] -> Word bech32Polymod values = foldl' go 1 values .&. 0x3fffffff @@ -121,9 +128,9 @@ bech32Polymod values = foldl' go 1 values .&. 0x3fffffff 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 @@ -132,10 +139,12 @@ bech32HRPExpand hrp = where hrpBytes = B.unpack $ E.encodeUtf8 hrp + bech32Const :: Bech32Encoding -> Word bech32Const Bech32 = 0x00000001 bech32Const Bech32m = 0x2bc830a3 + -- | Calculate Bech32 checksum for a string of five-bit words. bech32CreateChecksum :: Bech32Encoding -> HRP -> [Word5] -> [Word5] bech32CreateChecksum enc hrp dat = [word5 (polymod .>>. i) | i <- [25, 20 .. 0]] @@ -144,6 +153,7 @@ bech32CreateChecksum enc hrp dat = [word5 (polymod .>>. i) | i <- [25, 20 .. 0]] w5 = values ++ map UnsafeWord5 [0, 0, 0, 0, 0, 0] polymod = bech32Polymod w5 `xor` bech32Const enc + -- | Verify Bech32 checksum for a human-readable part and string of five-bit words. bech32VerifyChecksum :: HRP -> [Word5] -> Maybe Bech32Encoding bech32VerifyChecksum hrp dat = @@ -153,14 +163,15 @@ bech32VerifyChecksum hrp dat = | 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 @@ -170,15 +181,16 @@ bech32Encode enc hrp dat = do 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 -{- | 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 @@ -193,24 +205,27 @@ bech32Decode bech32 = do where lowerBech32 = T.toLower bech32 + type Pad f = Int -> Int -> Word -> [[Word]] -> f [[Word]] + yesPadding :: Pad Identity yesPadding _ 0 _ result = return result yesPadding _ _ padValue result = return $ [padValue] : result {-# INLINE yesPadding #-} + noPadding :: Pad Maybe noPadding frombits bits padValue result = do 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}\). --} + +-- | 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 @@ -229,16 +244,19 @@ convertBits dat frombits tobits pad = concat . reverse <$> go dat 0 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 + -- | 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 + -- | Check if witness version and program are valid. segwitCheck :: Bech32Encoding -> Word8 -> Data -> Bool segwitCheck enc witver witprog = @@ -247,6 +265,7 @@ segwitCheck enc witver witprog = 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 @@ -257,9 +276,9 @@ segwitDecode hrp addr = do 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 diff --git a/src/Haskoin/Address/CashAddr.hs b/src/Haskoin/Address/CashAddr.hs deleted file mode 100644 index 4b01ba5e..00000000 --- a/src/Haskoin/Address/CashAddr.hs +++ /dev/null @@ -1,219 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{- | -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, - Cash32, - cashAddrDecode, - cashAddrEncode, - cash32decodeType, - cash32encodeType, - cash32decode, - cash32encode, -) where - -import Control.Monad -import Data.Bits -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.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as E -import Data.Word -import Haskoin.Data -import Haskoin.Util - -{- | '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. -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. --} -type Cash32 = Text - --- | Symbols for encoding 'Cash32' data in human-readable strings. -charset :: String -charset = "qpzry9x8gf2tvdw0s3jn54khce6mua7l" - --- | Get the 32-bit number associated with this 'Cash32' character. -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. --} -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) - -{- | 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 - -{- | 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) - where - ca = T.toLower ca' - -{- | 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) - -{- | 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) - where - bs' = E.encodeUtf8 text - -{- | 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 - -{- | 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 - -{- | 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 - --- | Obtain 'CashVersion' and payload length from 'CashAddr' version byte. -decodeVersionByte :: Word8 -> Maybe (CashVersion, Int) -decodeVersionByte vb = do - 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. --} -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) - --- | 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]] - 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) - generator = - [0x98f2bc8e61, 0x79b76d99e2, 0xf33e5fb3c4, 0xae2eabe2a8, 0x1e4f43e470] - inner c0 c (b, g) - | c0 `testBit` b = c `xor` g - | otherwise = c - --- | Validate that polymod 'ByteString' (eight bytes) is equal to zero. -verifyCash32Polymod :: ByteString -> Bool -verifyCash32Polymod = (== B.replicate 8 0) diff --git a/src/Haskoin/Block.hs b/src/Haskoin/Block.hs index cce67912..1a74eb77 100644 --- a/src/Haskoin/Block.hs +++ b/src/Haskoin/Block.hs @@ -1,13 +1,8 @@ -{- | -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. --} +-- | +-- 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, @@ -17,3 +12,4 @@ module Haskoin.Block ( import Haskoin.Block.Common import Haskoin.Block.Headers import Haskoin.Block.Merkle + diff --git a/src/Haskoin/Block/Common.hs b/src/Haskoin/Block/Common.hs index 6c7d56cc..3b852d49 100644 --- a/src/Haskoin/Block/Common.hs +++ b/src/Haskoin/Block/Common.hs @@ -2,16 +2,11 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{- | -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. --} +-- | +-- Stability : experimental +-- Portability : POSIX +-- +-- Common data types and functions to handle blocks from the block chain. module Haskoin.Block.Common ( -- * Blocks Block (..), @@ -77,12 +72,15 @@ import Haskoin.Transaction.Common import Haskoin.Util import qualified Text.Read as R + -- | Height of a block in the block chain, starting at 0 for Genesis. type BlockHeight = Word32 + -- | Block timestamp as Unix time (seconds since 1970-01-01 00:00 UTC). type Timestamp = Word32 + -- | Block header and transactions. data Block = Block { blockHeader :: !BlockHeader @@ -90,6 +88,7 @@ data Block = Block } deriving (Eq, Show, Read, Generic, Hashable, NFData) + instance Serial Block where deserialize = do header <- deserialize @@ -101,55 +100,67 @@ instance Serial Block where putVarInt $ length txs forM_ txs serialize + instance Serialize Block where get = deserialize put = serialize + instance Binary Block where 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 + instance FromJSON Block where 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) + instance Serialize BlockHash where put = serialize get = deserialize + instance Binary BlockHash where put = serialize get = deserialize + instance Show BlockHash where showsPrec _ = shows . blockHashToHex + instance Read BlockHash where 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 + instance FromJSON BlockHash where parseJSON = withText "BlockHash" $ maybe mzero return . hexToBlockHash + instance ToJSON BlockHash where toJSON = String . blockHashToHex toEncoding h = @@ -158,43 +169,49 @@ instance ToJSON BlockHash where <> hexBuilder (BL.reverse (runPutL (serialize h))) <> char7 '"' -{- | 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 -{- | 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 + , prevBlock :: !BlockHash -- 32 bytes + + -- ^ hash of the previous block (parent) + , merkleRoot :: !Hash256 -- 32 bytes + + -- ^ root of the merkle tree of transactions + , blockTimestamp :: !Timestamp -- 4 bytes + + -- ^ unix timestamp + , blockBits :: !Word32 -- 4 bytes + + -- ^ difficulty target + , bhNonce :: !Word32 -- 4 bytes + + -- ^ random nonce } deriving (Eq, Ord, Show, Read, Generic, Hashable, NFData) + -- 80 bytes instance ToJSON BlockHeader where @@ -217,10 +234,12 @@ instance ToJSON BlockHeader where <> "nonce" .= n ) + instance FromJSON BlockHeader where parseJSON = withObject "BlockHeader" $ \o -> - BlockHeader <$> o .: "version" + BlockHeader + <$> o .: "version" <*> o .: "prevblock" <*> (f =<< o .: "merkleroot") <*> o .: "timestamp" @@ -229,6 +248,7 @@ instance FromJSON BlockHeader where where f = maybe mzero return . (eitherToMaybe . runGetS deserialize <=< decodeHex) + instance Serial BlockHeader where deserialize = do v <- getWord32le @@ -254,43 +274,47 @@ instance Serial BlockHeader where putWord32le bb putWord32le n + instance Binary BlockHeader where put = serialize get = deserialize + instance Serialize BlockHeader where 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 + , getBlocksLocator :: !BlockLocator + -- ^ block locator object + , getBlocksHashStop :: !BlockHash + -- ^ hash of the last desired block } deriving (Eq, Show, Read, Generic, NFData) + instance Serial GetBlocks where deserialize = GetBlocks @@ -301,10 +325,12 @@ instance Serial GetBlocks 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 putWord32le v @@ -312,21 +338,22 @@ putGetBlockMsg v xs h = do 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. --} + +-- | 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 + , getHeadersBL :: !BlockLocator + -- ^ block locator object + , getHeadersHashStop :: !BlockHash + -- ^ hash of the last desired block header } deriving (Eq, Show, Read, Generic, NFData) + instance Serial GetHeaders where deserialize = GetHeaders @@ -337,26 +364,30 @@ instance Serial GetHeaders where repList (VarInt c) = replicateM (fromIntegral c) deserialize serialize (GetHeaders v xs h) = putGetBlockMsg v xs h + instance Serialize GetHeaders where put = serialize get = deserialize + instance Binary GetHeaders where 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] + { headersList :: [BlockHeaderCount] + -- ^ list of block headers with transaction count } deriving (Eq, Show, Read, Generic, NFData) + instance Serial Headers where deserialize = Headers <$> (repList =<< deserialize) where @@ -366,26 +397,28 @@ instance Serial Headers where putVarInt $ length xs forM_ xs $ \(a, b) -> serialize a >> serialize b + instance Serialize Headers where put = serialize get = deserialize + instance Binary Headers where 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 @@ -412,9 +445,9 @@ decodeCompact nCompact = (if neg then res * (-1) else res, over) || 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 diff --git a/src/Haskoin/Block/Headers.hs b/src/Haskoin/Block/Headers.hs index 3d2e8c7e..0577b174 100644 --- a/src/Haskoin/Block/Headers.hs +++ b/src/Haskoin/Block/Headers.hs @@ -5,16 +5,11 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} -{- | -Module : Haskoin.Block.Headers -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Block chain header synchronization and proof-of-work consensus functions. --} +-- | +-- Stability : experimental +-- Portability : POSIX +-- +-- Block chain header synchronization and proof-of-work consensus functions. module Haskoin.Block.Headers ( -- * Block Headers BlockNode (..), @@ -50,13 +45,7 @@ module Haskoin.Block.Headers ( bip34, validVersion, lastNoMinDiff, - nextWorkRequired, - nextEdaWorkRequired, - nextDaaWorkRequired, - nextAsertWorkRequired, computeAsertBits, - computeTarget, - getSuitableBlock, nextPowWorkRequired, calcNextWork, isValidPOW, @@ -114,33 +103,35 @@ import Haskoin.Data import Haskoin.Transaction.Genesis import Haskoin.Util -{- | Short version of the block hash. Uses the good end of the hash (the part - that doesn't have a long string of zeroes). --} + +-- | Short version of the block hash. Uses the good end of the hash (the part +-- that doesn't have a long string of zeroes). type ShortBlockHash = Word64 -{- | Memory-based map to a serialized 'BlockNode' data structure. - 'ShortByteString' is used to avoid memory fragmentation and make the data - structure compact. --} + +-- | Memory-based map to a serialized 'BlockNode' data structure. +-- 'ShortByteString' is used to avoid memory fragmentation and make the data +-- structure compact. type BlockMap = HashMap ShortBlockHash ShortByteString + -- | Represents accumulated work in the block chain so far. type BlockWork = Integer -{- | Data structure representing a block header and its position in the - block chain. --} + +-- | Data structure representing a block header and its position in the +-- block chain. data BlockNode = BlockNode { nodeHeader :: !BlockHeader , nodeHeight :: !BlockHeight - , -- | accumulated work so far - nodeWork :: !BlockWork - , -- | skip magic block hash - nodeSkip :: !BlockHash + , nodeWork :: !BlockWork + -- ^ accumulated work so far + , nodeSkip :: !BlockHash + -- ^ skip magic block hash } deriving (Show, Read, Generic, Hashable, NFData) + instance Serial BlockNode where deserialize = do nodeHeader <- deserialize @@ -161,20 +152,25 @@ instance Serial BlockNode where 0 -> return () _ -> serialize $ nodeSkip bn + instance Serialize BlockNode where put = serialize get = deserialize + instance Binary BlockNode where put = serialize get = deserialize + instance Eq BlockNode where (==) = (==) `on` nodeHeader + instance Ord BlockNode where compare = compare `on` nodeHeight + -- | Memory-based header tree. data HeaderMemory = HeaderMemory { memoryHeaderMap :: !BlockMap @@ -182,30 +178,37 @@ data HeaderMemory = HeaderMemory } deriving (Eq, Typeable, Show, Read, Generic, Hashable, NFData) + -- | Typeclass for block header chain storage monad. class Monad m => BlockHeaders m where -- | Add a new 'BlockNode' to the chain. Does not validate. addBlockHeader :: BlockNode -> m () + -- | Get a 'BlockNode' associated with a 'BlockHash'. getBlockHeader :: BlockHash -> m (Maybe BlockNode) + -- | Locate the 'BlockNode' for the highest block in the chain getBestBlockHeader :: m BlockNode + -- | Set the highest block in the chain. setBestBlockHeader :: BlockNode -> m () + -- | Add a continuous bunch of block headers the chain. Does not validate. addBlockHeaders :: [BlockNode] -> m () addBlockHeaders = mapM_ addBlockHeader + instance Monad m => BlockHeaders (StateT HeaderMemory m) where addBlockHeader = modify . addBlockHeaderMemory getBlockHeader bh = getBlockHeaderMemory bh <$> State.get getBestBlockHeader = gets memoryBestHeader setBestBlockHeader bn = modify $ \s -> s{memoryBestHeader = bn} + -- | Initialize memory-based chain. initialChain :: Network -> HeaderMemory initialChain net = @@ -214,6 +217,7 @@ initialChain net = , memoryBestHeader = genesisNode net } + -- | Initialize map for memory-based chain. genesisMap :: Network -> BlockMap genesisMap net = @@ -221,26 +225,29 @@ genesisMap net = (shortBlockHash (headerHash (getGenesisHeader net))) (toShort (runPutS (serialize (genesisNode net)))) + -- | Add block header to memory block map. addBlockHeaderMemory :: BlockNode -> HeaderMemory -> HeaderMemory addBlockHeaderMemory bn s@HeaderMemory{..} = let bm' = addBlockToMap bn memoryHeaderMap in s{memoryHeaderMap = bm'} + -- | Get block header from memory block map. getBlockHeaderMemory :: BlockHash -> HeaderMemory -> Maybe BlockNode getBlockHeaderMemory bh HeaderMemory{..} = do bs <- shortBlockHash bh `HashMap.lookup` memoryHeaderMap eitherToMaybe . runGetS deserialize $ fromShort bs -{- | Calculate short block hash taking eight non-zero bytes from the 16-byte - hash. This function will take the bytes that are not on the zero-side of the - hash, making colissions between short block hashes difficult. --} + +-- | Calculate short block hash taking eight non-zero bytes from the 16-byte +-- hash. This function will take the bytes that are not on the zero-side of the +-- hash, making colissions between short block hashes difficult. shortBlockHash :: BlockHash -> ShortBlockHash shortBlockHash = either error id . runGetS deserialize . B.take 8 . runPutS . serialize + -- | Add a block to memory-based block map. addBlockToMap :: BlockNode -> BlockMap -> BlockMap addBlockToMap node = @@ -248,9 +255,9 @@ addBlockToMap node = (shortBlockHash $ headerHash $ nodeHeader node) (toShort $ runPutS $ serialize node) -{- | Get the ancestor of the provided 'BlockNode' at the specified - 'BlockHeight'. --} + +-- | Get the ancestor of the provided 'BlockNode' at the specified +-- 'BlockHeight'. getAncestor :: BlockHeaders m => BlockHeight -> @@ -285,11 +292,13 @@ getAncestor height node go walk' | otherwise = return $ Just walk + -- | Is the provided 'BlockNode' the Genesis block? isGenesis :: BlockNode -> Bool isGenesis BlockNode{nodeHeight = 0} = True isGenesis _ = False + -- | Build the genesis 'BlockNode' for the supplied 'Network'. genesisNode :: Network -> BlockNode genesisNode net = @@ -300,9 +309,9 @@ genesisNode net = , nodeSkip = headerHash (getGenesisHeader net) } -{- | Validate a list of continuous block headers and import them to the - block chain. Return 'Left' on failure with error information. --} + +-- | Validate a list of continuous block headers and import them to the +-- block chain. Return 'Left' on failure with error information. connectBlocks :: BlockHeaders m => Network -> @@ -354,18 +363,18 @@ connectBlocks net t bhs@(bh : _) = bn <- ExceptT . return $ validBlock net t bb par pars h sk go lbh (bn : acc) (chooseBest bn bb) bn (take 10 $ par : pars) hs -{- | Block's parent. If the block header is in the store, its parent must also - be there. No block header get deleted or pruned from the store. --} + +-- | Block's parent. If the block header is in the store, its parent must also +-- be there. No block header get deleted or pruned from the store. parentBlock :: BlockHeaders m => BlockHeader -> m (Maybe BlockNode) parentBlock bh = getBlockHeader (prevBlock bh) -{- | Validate and connect single block header to the block chain. Return 'Left' - if fails to be validated. --} + +-- | Validate and connect single block header to the block chain. Return 'Left' +-- if fails to be validated. connectBlock :: BlockHeaders m => Network -> @@ -395,6 +404,7 @@ connectBlock net t bh = when (bb /= bb') . lift $ setBestBlockHeader bb' return bn + -- | Validate this block header. Build a 'BlockNode' if successful. validBlock :: Network -> @@ -419,19 +429,26 @@ validBlock net t bb par pars bh sk = do ng = nodeHeight par + 1 aw = nodeWork par + headerWork bh unless (isValidPOW net bh) $ - Left $ "Proof of work failed: " ++ show (headerHash bh) + Left $ + "Proof of work failed: " ++ show (headerHash bh) unless (nt <= t + 2 * 60 * 60) $ - Left $ "Invalid header timestamp: " ++ show nt + Left $ + "Invalid header timestamp: " ++ show nt unless (nt >= mt) $ - Left $ "Block timestamp too early: " ++ show nt + Left $ + "Block timestamp too early: " ++ show nt unless (afterLastCP net (nodeHeight bb) ng) $ - Left $ "Rewriting pre-checkpoint chain: " ++ show ng + Left $ + "Rewriting pre-checkpoint chain: " ++ show ng unless (validCP net ng hh) $ - Left $ "Rejected checkpoint: " ++ show ng + Left $ + "Rejected checkpoint: " ++ show ng unless (bip34 net ng hh) $ - Left $ "Rejected BIP-34 block: " ++ show hh + Left $ + "Rejected BIP-34 block: " ++ show hh unless (validVersion net ng nv) $ - Left $ "Invalid block version: " ++ show nv + Left $ + "Invalid block version: " ++ show nv return BlockNode { nodeHeader = bh @@ -440,28 +457,30 @@ validBlock net t bb par pars bh sk = do , nodeSkip = headerHash $ nodeHeader sk } -{- | Return the median of all provided timestamps. Can be unsorted. Error on - empty list. --} + +-- | Return the median of all provided timestamps. Can be unsorted. Error on +-- empty list. medianTime :: [Timestamp] -> Timestamp medianTime ts | null ts = error "Cannot compute median time of empty header list" | otherwise = sort ts !! (length ts `div` 2) -{- | Calculate the height of the skip (magic) block that corresponds to the - given height. The block hash of the ancestor at that height will be placed on - the 'BlockNode' structure to help locate ancestors at any height quickly. --} + +-- | Calculate the height of the skip (magic) block that corresponds to the +-- given height. The block hash of the ancestor at that height will be placed on +-- the 'BlockNode' structure to help locate ancestors at any height quickly. skipHeight :: BlockHeight -> BlockHeight skipHeight height | height < 2 = 0 | height .&. 1 /= 0 = invertLowestOne (invertLowestOne $ height - 1) + 1 | otherwise = invertLowestOne height + -- | Part of the skip black magic calculation. invertLowestOne :: BlockHeight -> BlockHeight invertLowestOne height = height .&. (height - 1) + -- | Get a number of parents for the provided block. getParents :: BlockHeaders m => @@ -480,6 +499,7 @@ getParents = getpars [] Just bn -> getpars (bn : acc) (n - 1) bn Nothing -> error "BUG: All non-genesis blocks should have a parent" + -- | Verify that checkpoint location is valid. validCP :: Network -> @@ -493,9 +513,9 @@ validCP net height newChildHash = Just cpHash -> cpHash == newChildHash Nothing -> True -{- | New block height above the last checkpoint imported. Used to prevent a - reorg below the highest checkpoint that was already imported. --} + +-- | New block height above the last checkpoint imported. Used to prevent a +-- reorg below the highest checkpoint that was already imported. afterLastCP :: Network -> -- | best height @@ -512,10 +532,10 @@ afterLastCP net bestHeight newChildHeight = listToMaybe . reverse $ [c | (c, _) <- getCheckpoints net, c <= bestHeight] -{- | This block should be at least version 2 (BIP34). Block height must be - included in the coinbase transaction to prevent non-unique transaction - hashes. --} + +-- | This block should be at least version 2 (BIP34). Block height must be +-- included in the coinbase transaction to prevent non-unique transaction +-- hashes. bip34 :: Network -> -- | new child height @@ -528,6 +548,7 @@ bip34 net height hsh | fst (getBip34Block net) == height = snd (getBip34Block net) == hsh | otherwise = True + -- | Check if the provided block height and version are valid. validVersion :: Network -> @@ -542,9 +563,9 @@ validVersion net height version | version < 4 = height < getBip65Height net | otherwise = True -{- | Find last block with normal, as opposed to minimum difficulty (for test - networks). --} + +-- | Find last block with normal, as opposed to minimum difficulty (for test +-- networks). lastNoMinDiff :: BlockHeaders m => Network -> BlockNode -> m BlockNode lastNoMinDiff _ bn@BlockNode{nodeHeight = 0} = return bn lastNoMinDiff net bn@BlockNode{..} = do @@ -561,92 +582,6 @@ lastNoMinDiff net bn@BlockNode{..} = do lastNoMinDiff net bn' else return bn -{- | Returns the work required on a block header given the previous block. This - coresponds to @bitcoind@ function @GetNextWorkRequired@ in @main.cpp@. --} -nextWorkRequired :: - BlockHeaders m => - Network -> - BlockNode -> - BlockHeader -> - m Word32 -nextWorkRequired net par bh = do - ma <- getAsertAnchor net - case asert ma <|> daa <|> eda <|> pow of - Just f -> f par bh - Nothing -> error "Could not determine difficulty algorithm" - where - asert ma = do - anchor <- ma - guard (nodeHeight par > nodeHeight anchor) - return $ nextAsertWorkRequired net anchor - daa = do - daa_height <- getDaaBlockHeight net - guard (nodeHeight par + 1 >= daa_height) - return $ nextDaaWorkRequired net - eda = do - eda_height <- getEdaBlockHeight net - guard (nodeHeight par + 1 >= eda_height) - return $ nextEdaWorkRequired net - pow = return $ nextPowWorkRequired net - -{- | Find out the next amount of work required according to the Emergency - Difficulty Adjustment (EDA) algorithm from Bitcoin Cash. --} -nextEdaWorkRequired :: - BlockHeaders m => Network -> BlockNode -> BlockHeader -> m Word32 -nextEdaWorkRequired net par bh - | nodeHeight par + 1 `mod` diffInterval net == 0 = - nextWorkRequired net par bh - | minDifficulty = return (encodeCompact (getPowLimit net)) - | blockBits (nodeHeader par) == encodeCompact (getPowLimit net) = - return (encodeCompact (getPowLimit net)) - | otherwise = do - par6 <- fromMaybe e1 <$> getAncestor (nodeHeight par - 6) par - pars <- getParents 10 par - pars6 <- getParents 10 par6 - let par6med = - medianTime $ map (blockTimestamp . nodeHeader) (par6 : pars6) - parmed = medianTime $ map (blockTimestamp . nodeHeader) (par : pars) - mtp6 = parmed - par6med - if mtp6 < 12 * 3600 - then return $ blockBits (nodeHeader par) - else - return $ - let (diff, _) = decodeCompact (blockBits (nodeHeader par)) - ndiff = diff + (diff `shiftR` 2) - in if getPowLimit net > ndiff - then encodeCompact (getPowLimit net) - else encodeCompact ndiff - where - minDifficulty = - blockTimestamp bh - > blockTimestamp (nodeHeader par) + getTargetSpacing net * 2 - e1 = error "Could not get seventh ancestor of block" - -{- | Find the next amount of work required according to the Difficulty - Adjustment Algorithm (DAA) from Bitcoin Cash. --} -nextDaaWorkRequired :: - BlockHeaders m => Network -> BlockNode -> BlockHeader -> m Word32 -nextDaaWorkRequired net par bh - | minDifficulty = return (encodeCompact (getPowLimit net)) - | otherwise = do - unless (height >= diffInterval net) $ - error "Block height below difficulty interval" - l <- getSuitableBlock par - par144 <- fromMaybe e1 <$> getAncestor (height - 144) par - f <- getSuitableBlock par144 - let nextTarget = computeTarget net f l - if nextTarget > getPowLimit net - then return $ encodeCompact (getPowLimit net) - else return $ encodeCompact nextTarget - where - height = nodeHeight par - e1 = error "Cannot get ancestor at parent - 144 height" - minDifficulty = - blockTimestamp bh - > blockTimestamp (nodeHeader par) + getTargetSpacing net * 2 mtp :: BlockHeaders m => BlockNode -> m Timestamp mtp bn @@ -655,6 +590,7 @@ mtp bn pars <- getParents 11 bn return $ medianTime (map (blockTimestamp . nodeHeader) pars) + firstGreaterOrEqual :: BlockHeaders m => Network -> @@ -662,6 +598,7 @@ firstGreaterOrEqual :: m (Maybe BlockNode) firstGreaterOrEqual = binSearch False + lastSmallerOrEqual :: BlockHeaders m => Network -> @@ -669,6 +606,7 @@ lastSmallerOrEqual :: m (Maybe BlockNode) lastSmallerOrEqual = binSearch True + binSearch :: BlockHeaders m => Bool -> @@ -708,11 +646,13 @@ binSearch top net f = runMaybeT $ do | top = return a | otherwise = return b + extremes :: BlockHeaders m => Network -> m (BlockNode, BlockNode) extremes net = do b <- getBestBlockHeader return (genesisNode net, b) + middleBlock :: BlockHeaders m => BlockNode -> BlockNode -> m BlockNode middleBlock a b = getAncestor h b >>= \case @@ -721,59 +661,31 @@ middleBlock a b = where h = middleOf (nodeHeight a) (nodeHeight b) + middleOf :: Integral a => a -> a -> a middleOf a b = a + ((b - a) `div` 2) --- TODO: Use known anchor after fork -getAsertAnchor :: BlockHeaders m => Network -> m (Maybe BlockNode) -getAsertAnchor net = - case getAsertActivationTime net of - Nothing -> return Nothing - Just act -> firstGreaterOrEqual net (f act) - where - f act bn = do - m <- mtp bn - return $ compare m act - --- | Find the next amount of work required according to the aserti3-2d algorithm. -nextAsertWorkRequired :: - BlockHeaders m => - Network -> - BlockNode -> - BlockNode -> - BlockHeader -> - m Word32 -nextAsertWorkRequired net anchor par bh = do - anchor_parent <- - fromMaybe e_fork - <$> getBlockHeader (prevBlock (nodeHeader anchor)) - let anchor_parent_time = toInteger $ blockTimestamp $ nodeHeader anchor_parent - time_diff = current_time - anchor_parent_time - return $ computeAsertBits halflife anchor_bits time_diff height_diff - where - halflife = getAsertHalfLife net - anchor_height = toInteger $ nodeHeight anchor - anchor_bits = blockBits $ nodeHeader anchor - current_height = toInteger (nodeHeight par) + 1 - height_diff = current_height - anchor_height - current_time = toInteger $ blockTimestamp bh - e_fork = error "Could not get fork block header" idealBlockTime :: Integer idealBlockTime = 10 * 60 + rBits :: Int rBits = 16 + radix :: Integer radix = 1 `shiftL` rBits + maxBits :: Word32 maxBits = 0x1d00ffff + maxTarget :: Integer maxTarget = fst $ decodeCompact maxBits + computeAsertBits :: Integer -> Word32 -> @@ -810,31 +722,9 @@ computeAsertBits halflife anchor_bits time_diff height_diff = else g2 `shiftL` fromIntegral s g4 = g3 `shiftR` rBits --- | Compute Bitcoin Cash DAA target for a new block. -computeTarget :: Network -> BlockNode -> BlockNode -> Integer -computeTarget net f l = - let work = (nodeWork l - nodeWork f) * fromIntegral (getTargetSpacing net) - actualTimespan = - blockTimestamp (nodeHeader l) - blockTimestamp (nodeHeader f) - actualTimespan' - | actualTimespan > 288 * getTargetSpacing net = - 288 * getTargetSpacing net - | actualTimespan < 72 * getTargetSpacing net = - 72 * getTargetSpacing net - | otherwise = actualTimespan - work' = work `div` fromIntegral actualTimespan' - in 2 ^ (256 :: Integer) `div` work' - --- | Get suitable block for Bitcoin Cash DAA computation. -getSuitableBlock :: BlockHeaders m => BlockNode -> m BlockNode -getSuitableBlock par = do - unless (nodeHeight par >= 3) $ error "Block height is less than three" - blocks <- (par :) <$> getParents 2 par - return $ sortBy (compare `on` blockTimestamp . nodeHeader) blocks !! 1 - -{- | Returns the work required on a block header given the previous block. This - coresponds to bitcoind function GetNextWorkRequired in main.cpp. --} + +-- | Returns the work required on a block header given the previous block. This +-- coresponds to bitcoind function GetNextWorkRequired in main.cpp. nextPowWorkRequired :: BlockHeaders m => Network -> BlockNode -> BlockHeader -> m Word32 nextPowWorkRequired net par bh @@ -858,6 +748,7 @@ nextPowWorkRequired net par bh ht = blockTimestamp bh delta = getTargetSpacing net * 2 + -- | Computes the work required for the first block in a new retarget period. calcNextWork :: Network -> @@ -879,11 +770,11 @@ calcNextWork net header time l = fst $ decodeCompact $ blockBits header new = l * fromIntegral n `div` fromIntegral (getTargetTimespan net) -{- | Returns True if the difficulty target (bits) of the header is valid and the - proof of work of the header matches the advertised difficulty target. This - function corresponds to the function @CheckProofOfWork@ from @bitcoind@ in - @main.cpp@. --} + +-- | Returns True if the difficulty target (bits) of the header is valid and the +-- proof of work of the header matches the advertised difficulty target. This +-- function corresponds to the function @CheckProofOfWork@ from @bitcoind@ in +-- @main.cpp@. isValidPOW :: Network -> BlockHeader -> Bool isValidPOW net h | target <= 0 || over || target > getPowLimit net = False @@ -891,24 +782,27 @@ isValidPOW net h where (target, over) = decodeCompact $ blockBits h + -- | Returns the proof of work of a block header hash as an 'Integer' number. blockPOW :: BlockHash -> Integer blockPOW = bsToInteger . B.reverse . runPutS . serialize -{- | Returns the work represented by this block. Work is defined as the number - of tries needed to solve a block in the average case with respect to the - target. --} + +-- | Returns the work represented by this block. Work is defined as the number +-- of tries needed to solve a block in the average case with respect to the +-- target. headerWork :: BlockHeader -> Integer headerWork bh = largestHash `div` (target + 1) where target = fst $ decodeCompact $ blockBits bh largestHash = 1 `shiftL` 256 + -- | Number of blocks on average between difficulty cycles (2016 blocks). diffInterval :: Network -> Word32 diffInterval net = getTargetTimespan net `div` getTargetSpacing net + -- | Compare two blocks to get the best. chooseBest :: BlockNode -> BlockNode -> BlockNode chooseBest b1 b2 @@ -919,6 +813,7 @@ chooseBest b1 b2 | nodeWork b1 > nodeWork b2 = b1 | otherwise = b2 + -- | Get list of blocks for a block locator. blockLocatorNodes :: BlockHeaders m => BlockNode -> m [BlockNode] blockLocatorNodes best = @@ -940,10 +835,12 @@ blockLocatorNodes best = bn' <- fromMaybe e1 <$> getAncestor h bn go loc' bn' n' + -- | Get block locator. blockLocator :: BlockHeaders m => BlockNode -> m BlockLocator blockLocator bn = map (headerHash . nodeHeader) <$> blockLocatorNodes bn + -- | Become rich beyond your wildest dreams. mineBlock :: Network -> Word32 -> BlockHeader -> BlockHeader mineBlock net seed h = @@ -954,6 +851,7 @@ mineBlock net seed h = , isValidPOW net j ] + -- | Generate and append new blocks (mining). Only practical in regtest network. appendBlocks :: Network -> @@ -976,6 +874,7 @@ appendBlocks net seed bh i = merkleRoot = sha256 $ runPutS $ serialize seed } + -- | Find the last common block ancestor between provided block headers. splitPoint :: BlockHeaders m => BlockNode -> BlockNode -> m BlockNode splitPoint l r = do @@ -994,10 +893,12 @@ splitPoint l r = do pr <- fromMaybe e <$> getAncestor h lr f pl pr + -- | Generate the entire Genesis block for 'Network'. genesisBlock :: Network -> Block genesisBlock net = Block (getGenesisHeader net) [genesisTx] + -- | Compute block subsidy at particular height. computeSubsidy :: Network -> BlockHeight -> Word64 computeSubsidy net height = diff --git a/src/Haskoin/Block/Merkle.hs b/src/Haskoin/Block/Merkle.hs index e4e0ec92..d5b1b6b9 100644 --- a/src/Haskoin/Block/Merkle.hs +++ b/src/Haskoin/Block/Merkle.hs @@ -1,16 +1,11 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} -{- | -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. --} +-- | +-- Stability : experimental +-- Portability : POSIX +-- +-- Function to deal with Merkle trees inside blocks. module Haskoin.Block.Merkle ( -- * Merkle Blocks MerkleBlock (..), @@ -54,30 +49,34 @@ import Haskoin.Data import Haskoin.Network.Common import Haskoin.Transaction.Common + -- | Hash of the block's Merkle root. type MerkleRoot = Hash256 + -- | Bits that are used to rebuild partial merkle tree transaction hash list. 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 + { merkleHeader :: !BlockHeader + -- ^ block header + , merkleTotalTxns :: !Word32 + -- ^ total number of transactions in block + , mHashes :: !PartialMerkleTree + -- ^ hashes in depth-first order + , mFlags :: !FlagBits + -- ^ bits to rebuild partial merkle tree } deriving (Eq, Show, Read, Generic, Hashable, NFData) + instance Serial MerkleBlock where deserialize = do header <- deserialize @@ -88,6 +87,7 @@ instance Serial MerkleBlock where ws <- replicateM (fromIntegral flagLen) getWord8 return $ MerkleBlock header ntx hashes (decodeMerkleFlags ws) + serialize (MerkleBlock h ntx hashes flags) = do serialize h putWord32le ntx @@ -97,24 +97,29 @@ instance Serial MerkleBlock where putVarInt $ length ws forM_ ws putWord8 + instance Binary MerkleBlock where put = serialize get = deserialize + instance Serialize MerkleBlock where 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)] ] + -- | Pack Merkle flags from 'FlagBits'. encodeMerkleFlags :: FlagBits -> [Word8] encodeMerkleFlags bs = map boolsToWord8 $ splitIn 8 bs + -- | Computes the height of a Merkle tree. calcTreeHeight :: -- | number of transactions (leaf nodes) @@ -126,9 +131,9 @@ calcTreeHeight ntx | 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 -> @@ -138,6 +143,7 @@ calcTreeWidth :: 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) @@ -146,10 +152,12 @@ buildMerkleRoot :: MerkleRoot buildMerkleRoot txs = calcHash (calcTreeHeight $ length txs) 0 txs + -- | Concatenate and compute double SHA256. hash2 :: Hash256 -> Hash256 -> Hash256 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 @@ -171,11 +179,11 @@ calcHash height pos txs 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)] -> @@ -183,9 +191,9 @@ buildPartialMerkle :: (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) traverseAndBuild height pos txs @@ -203,6 +211,7 @@ traverseAndBuild height pos txs traverseAndBuild (height - 1) (pos * 2 + 1) txs | otherwise = ([], []) + -- | Helper function to extract transaction hashes from partial Merkle tree. traverseAndExtract :: Int -> @@ -238,10 +247,10 @@ traverseAndExtract height pos ntx flags 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 -> @@ -278,20 +287,22 @@ extractMatches net flags hashes ntx (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 where (xs1, xs2) = splitAt c xs + -- | Pack up to eight bools in a byte. boolsToWord8 :: [Bool] -> Word8 boolsToWord8 [] = 0 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 = @@ -304,6 +315,7 @@ merkleBlockTxs net b = when (root /= merkle) $ Left "merkleBlockTxs: Merkle root incorrect" return ths + -- | Check if Merkle block root is valid against the block header. testMerkleRoot :: Network -> MerkleBlock -> Bool testMerkleRoot net = isRight . merkleBlockTxs net diff --git a/src/Haskoin/Constants.hs b/src/Haskoin/Constants.hs index ee627cd0..4c17ca7c 100644 --- a/src/Haskoin/Constants.hs +++ b/src/Haskoin/Constants.hs @@ -1,17 +1,11 @@ {-# LANGUAGE CPP #-} {-# 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. --} +-- | +-- Stability : experimental +-- Portability : POSIX +-- +-- Network constants for main, test and private regression test networks. module Haskoin.Constants ( Network (..), @@ -19,10 +13,6 @@ module Haskoin.Constants ( btc, btcTest, btcRegTest, - bch, - bchTest, - bchTest4, - bchRegTest, allNets, netByName, ) where @@ -46,6 +36,7 @@ import Haskoin.Network.Common import Haskoin.Transaction import Text.Read + -- | Version of Haskoin Core package. versionString :: IsString a => a @@ -55,10 +46,12 @@ versionString = CURRENT_PACKAGE_VERSION 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 = @@ -162,18 +155,15 @@ btc = , "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 = @@ -223,18 +213,15 @@ btcTest = , "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 = @@ -274,340 +261,15 @@ btcRegTest = , 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] +allNets = [btc, btcTest, btcRegTest] diff --git a/src/Haskoin/Crypto.hs b/src/Haskoin/Crypto.hs index 99fc5f91..2541d5e9 100644 --- a/src/Haskoin/Crypto.hs +++ b/src/Haskoin/Crypto.hs @@ -1,13 +1,8 @@ -{- | -Module : Haskoin.Crypto -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Hashing functions and ECDSA signatures. --} +-- | +-- Stability : experimental +-- Portability : POSIX +-- +-- Hashing functions and ECDSA signatures. module Haskoin.Crypto ( module Hash, module Signature, @@ -17,3 +12,4 @@ module Haskoin.Crypto ( import Crypto.Secp256k1 as Secp256k1 import Haskoin.Crypto.Hash as Hash import Haskoin.Crypto.Signature as Signature + diff --git a/src/Haskoin/Crypto/Hash.hs b/src/Haskoin/Crypto/Hash.hs index 4c76b60f..af75967a 100644 --- a/src/Haskoin/Crypto/Hash.hs +++ b/src/Haskoin/Crypto/Hash.hs @@ -2,17 +2,12 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeApplications #-} -{- | -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. --} +-- | +-- Stability : experimental +-- Portability : POSIX +-- +-- Hashing functions and corresponding data types. Uses functions from the +-- cryptonite library. module Haskoin.Crypto.Hash ( -- * Hashes Hash512 (getHash512), @@ -65,56 +60,69 @@ import GHC.Generics (Generic) import Haskoin.Util 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) + instance Serialize CheckSum32 where put = serialize get = deserialize + instance Binary CheckSum32 where put = serialize get = deserialize + -- | Type for 512-bit hashes. newtype Hash512 = Hash512 {getHash512 :: ShortByteString} deriving (Eq, Ord, Hashable, Generic, NFData) + -- | Type for 256-bit hashes. newtype Hash256 = Hash256 {getHash256 :: ShortByteString} deriving (Eq, Ord, Hashable, Generic, NFData) + -- | Type for 160-bit hashes. newtype Hash160 = Hash160 {getHash160 :: ShortByteString} deriving (Eq, Ord, Hashable, Generic, NFData) + instance Show Hash512 where showsPrec _ = shows . encodeHex . BSS.fromShort . getHash512 + instance Read Hash512 where readPrec = do R.String str <- lexP maybe pfail (return . Hash512 . BSS.toShort) (decodeHex (cs str)) + instance Show Hash256 where showsPrec _ = shows . encodeHex . BSS.fromShort . getHash256 + instance Read Hash256 where readPrec = do R.String str <- lexP maybe pfail (return . Hash256 . BSS.toShort) (decodeHex (cs str)) + instance Show Hash160 where showsPrec _ = shows . encodeHex . BSS.fromShort . getHash160 + instance Read Hash160 where readPrec = do R.String str <- lexP maybe pfail (return . Hash160 . BSS.toShort) (decodeHex (cs str)) + instance IsString Hash512 where fromString str = case decodeHex $ cs str of @@ -126,18 +134,22 @@ instance IsString Hash512 where 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 + instance Serialize Hash512 where put = serialize get = deserialize + instance Binary Hash512 where put = serialize get = deserialize + instance IsString Hash256 where fromString str = case decodeHex $ cs str of @@ -149,18 +161,22 @@ instance IsString Hash256 where 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 + instance Serialize Hash256 where put = serialize get = deserialize + instance Binary Hash256 where put = serialize get = deserialize + instance IsString Hash160 where fromString str = case decodeHex $ cs str of @@ -172,44 +188,54 @@ instance IsString Hash160 where 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 + instance Serialize Hash160 where put = serialize get = deserialize + instance Binary Hash160 where put = serialize get = deserialize + -- | Calculate SHA512 hash. sha512 :: ByteArrayAccess b => b -> Hash512 sha512 = Hash512 . BSS.toShort . BA.convert . hashWith SHA512 + -- | Calculate SHA256 hash. sha256 :: ByteArrayAccess b => b -> Hash256 sha256 = Hash256 . BSS.toShort . BA.convert . hashWith SHA256 + -- | Calculate RIPEMD160 hash. ripemd160 :: ByteArrayAccess b => b -> Hash160 ripemd160 = Hash160 . BSS.toShort . BA.convert . hashWith RIPEMD160 + -- | Claculate SHA1 hash. sha1 :: ByteArrayAccess b => b -> Hash160 sha1 = Hash160 . BSS.toShort . BA.convert . hashWith SHA1 + -- | Compute two rounds of SHA-256. doubleSHA256 :: ByteArrayAccess b => b -> Hash256 doubleSHA256 = Hash256 . BSS.toShort . BA.convert . hashWith SHA256 . hashWith SHA256 + -- | Compute SHA-256 followed by RIPMED-160. addressHash :: ByteArrayAccess b => b -> Hash160 addressHash = Hash160 . BSS.toShort . BA.convert . hashWith RIPEMD160 . hashWith SHA256 + {- CheckSum -} -- | Computes a 32 bit checksum. @@ -222,6 +248,7 @@ checkSum32 = . hashWith SHA256 . hashWith SHA256 + {- HMAC -} -- | Computes HMAC over SHA-512. @@ -229,11 +256,13 @@ hmac512 :: ByteString -> ByteString -> Hash512 hmac512 key msg = Hash512 $ BSS.toShort $ BA.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) + -- | Split a 'Hash512' into a pair of 'Hash256'. split512 :: Hash512 -> (Hash256, Hash256) split512 h = @@ -241,6 +270,7 @@ split512 h = where (a, b) = BS.splitAt 32 . BSS.fromShort $ getHash512 h + -- | Join a pair of 'Hash256' into a 'Hash512'. join512 :: (Hash256, Hash256) -> Hash512 join512 (a, b) = @@ -248,10 +278,10 @@ join512 (a, b) = . BSS.toShort $ BSS.fromShort (getHash256 a) `BS.append` BSS.fromShort (getHash256 b) -{- | Initialize tagged hash specified in BIP340 -@since 0.21.0 --} +-- | Initialize tagged hash specified in BIP340 +-- +-- @since 0.21.0 initTaggedHash :: -- | Hash tag ByteString -> diff --git a/src/Haskoin/Crypto/Signature.hs b/src/Haskoin/Crypto/Signature.hs index 31e24047..eea30b29 100644 --- a/src/Haskoin/Crypto/Signature.hs +++ b/src/Haskoin/Crypto/Signature.hs @@ -1,16 +1,11 @@ {-# 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. --} +-- | +-- Stability : experimental +-- Portability : POSIX +-- +-- ECDSA signatures using secp256k1 curve. Uses functions from upstream secp256k1 +-- library. module Haskoin.Crypto.Signature ( -- * Signatures putSig, @@ -35,6 +30,7 @@ import Data.Serialize (Serialize (..)) import Haskoin.Crypto.Hash import Numeric (showHex) + -- | Convert 256-bit hash into a 'Msg' for signing or verification. hashToMsg :: Hash256 -> Msg hashToMsg = @@ -42,16 +38,19 @@ hashToMsg = 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 + -- | Verify an ECDSA signature for a 256-bit hash. verifyHashSig :: Hash256 -> Sig -> PubKey -> Bool verifyHashSig h s p = verifySig p norm (hashToMsg h) where norm = fromMaybe s (normalizeSig s) + -- | Deserialize an ECDSA signature as commonly encoded in Bitcoin. getSig :: MonadGet m => m Sig getSig = do @@ -71,14 +70,17 @@ getSig = do 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 + -- | Is canonical half order. isCanonicalHalfOrder :: Sig -> Bool isCanonicalHalfOrder = isNothing . normalizeSig + -- | Decode signature strictly. decodeStrictSig :: ByteString -> Maybe Sig decodeStrictSig bs = do diff --git a/src/Haskoin/Data.hs b/src/Haskoin/Data.hs index bb03fdcb..500bf3f7 100644 --- a/src/Haskoin/Data.hs +++ b/src/Haskoin/Data.hs @@ -20,74 +20,66 @@ 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 + { getNetworkName :: !String + -- ^ lowercase alphanumeric and dashes + , getAddrPrefix :: !Word8 + -- ^ prefix for 'Base58' P2PKH addresses + , getScriptPrefix :: !Word8 + -- ^ prefix for 'Base58' P2SH addresses + , getSecretPrefix :: !Word8 + -- ^ prefix for WIF private key + , getExtPubKeyPrefix :: !Word32 + -- ^ prefix for extended public key + , getExtSecretPrefix :: !Word32 + -- ^ prefix for extended private key + , getNetworkMagic :: !Word32 + -- ^ network magic + , getGenesisHeader :: !BlockHeader + -- ^ genesis block header + , getMaxBlockSize :: !Int + -- ^ maximum block size in bytes + , getMaxSatoshi :: !Word64 + -- ^ maximum amount of satoshi + , getHaskoinUserAgent :: !ByteString + -- ^ user agent string + , getDefaultPort :: !Int + -- ^ default port for P2P connections + , getAllowMinDifficultyBlocks :: !Bool + -- ^ allow min difficulty blocks (testnet) + , getPowNoRetargetting :: !Bool + -- ^ do not retarget difficulty (regtest) + , getPowLimit :: !Integer + -- ^ proof-of-work target higest possible value + , getBip34Block :: !(BlockHeight, BlockHash) + -- ^ block at which BIP34 activates + , getBip65Height :: !BlockHeight + -- ^ block at which BIP65 activates + , getBip66Height :: !BlockHeight + -- ^ block at which BIP66 activates + , getTargetTimespan :: !Word32 + -- ^ time between difficulty retargets + , getTargetSpacing :: !Word32 + -- ^ time between blocks + , getCheckpoints :: ![(BlockHeight, BlockHash)] + -- ^ checkpoints + , getBip44Coin :: !Word32 + -- ^ BIP44 derivation path root + , getSeeds :: ![String] + -- ^ peer-to-peer network seeds + , getEdaBlockHeight :: !(Maybe Word32) + -- ^ EDA start block height + , getDaaBlockHeight :: !(Maybe Word32) + -- ^ DAA start block height + , getSegWit :: !Bool + -- ^ segregated witness active + , getBech32Prefix :: !(Maybe Text) + -- ^ 'Bech32' prefix (for SegWit network) + , getReplaceByFee :: !Bool + -- ^ Replace-By-Fee (BIP-125) + , getHalvingInterval :: !Word32 + -- ^ Subsidy halving interval } deriving (Eq, Show, Read, Generic, NFData) diff --git a/src/Haskoin/Keys.hs b/src/Haskoin/Keys.hs index fcc49713..7787d87d 100644 --- a/src/Haskoin/Keys.hs +++ b/src/Haskoin/Keys.hs @@ -1,14 +1,9 @@ -{- | -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). --} +-- | +-- 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, @@ -18,3 +13,4 @@ module Haskoin.Keys ( import Haskoin.Keys.Common import Haskoin.Keys.Extended import Haskoin.Keys.Mnemonic + diff --git a/src/Haskoin/Keys/Common.hs b/src/Haskoin/Keys/Common.hs index c88c0f97..fd945a9f 100644 --- a/src/Haskoin/Keys/Common.hs +++ b/src/Haskoin/Keys/Common.hs @@ -6,16 +6,11 @@ {-# 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. --} +-- | +-- Stability : experimental +-- Portability : POSIX +-- +-- ECDSA private and public key functions. module Haskoin.Keys.Common ( -- * Public & Private Keys PubKeyI (..), @@ -65,6 +60,7 @@ 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 @@ -72,12 +68,14 @@ data PubKeyI = PubKeyI } 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 = @@ -86,11 +84,13 @@ instance ToJSON PubKeyI where <> 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 @@ -113,49 +113,57 @@ instance Serial PubKeyI where 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. --} + +-- | 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. --} + +-- | 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 @@ -165,6 +173,7 @@ fromMiniKey bs = do 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 @@ -181,6 +190,7 @@ fromWif net wif = do -- Bad length _ -> Nothing + -- | Encode private key into a WIF string. toWif :: Network -> SecKeyI -> Base58 toWif net (SecKeyI k c) = diff --git a/src/Haskoin/Keys/Extended.hs b/src/Haskoin/Keys/Extended.hs index b50964dd..a1fa082e 100644 --- a/src/Haskoin/Keys/Extended.hs +++ b/src/Haskoin/Keys/Extended.hs @@ -4,16 +4,11 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{- | -Module : Haskoin.Keys.Extended -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -BIP-32 extended keys. --} +-- | +-- Stability : experimental +-- Portability : POSIX +-- +-- BIP-32 extended keys. module Haskoin.Keys.Extended ( -- * Extended Keys XPubKey (..), @@ -154,24 +149,27 @@ import Haskoin.Util import Text.Read as R import Text.Read.Lex -{- | A derivation exception is thrown in the very unlikely event that a - derivation is invalid. --} + +-- | A derivation exception is thrown in the very unlikely event that a +-- derivation is invalid. newtype DerivationException = DerivationException String deriving (Eq, Read, Show, Typeable, Generic, NFData) + instance Exception DerivationException + -- | Chain code as specified in BIP-32. type ChainCode = Hash256 + -- | Index of key as specified in BIP-32. type KeyIndex = Word32 -{- | Data type representing an extended BIP32 private key. An extended key - is a node in a tree of key derivations. It has a depth in the tree, a - parent node and an index to differentiate it from other siblings. --} + +-- | Data type representing an extended BIP32 private key. An extended key +-- is a node in a tree of key derivations. It has a depth in the tree, a +-- parent node and an index to differentiate it from other siblings. data XPrvKey = XPrvKey { xPrvDepth :: !Word8 -- ^ depth in the tree @@ -186,6 +184,7 @@ data XPrvKey = XPrvKey } deriving (Generic, Eq, Show, Read, NFData, Hashable) + instance Serial XPrvKey where serialize k = do putWord8 $ xPrvDepth k @@ -201,20 +200,25 @@ instance Serial XPrvKey where <*> deserialize <*> getPadPrvKey + instance Binary XPrvKey where put = serialize get = deserialize + instance Serialize XPrvKey where put = serialize get = deserialize + xPrvToJSON :: Network -> XPrvKey -> Value xPrvToJSON net = A.String . xPrvExport net + xPrvToEncoding :: Network -> XPrvKey -> Encoding xPrvToEncoding net = text . xPrvExport net + -- | Decode an extended private key from a JSON string xPrvFromJSON :: Network -> Value -> Parser XPrvKey xPrvFromJSON net = @@ -223,6 +227,7 @@ xPrvFromJSON net = Nothing -> fail "could not read xprv" Just x -> return x + -- | Data type representing an extended BIP32 public key. data XPubKey = XPubKey { xPubDepth :: !Word8 @@ -238,6 +243,7 @@ data XPubKey = XPubKey } deriving (Generic, Eq, Show, Read, NFData, Hashable) + instance Serial XPubKey where serialize k = do putWord8 $ xPubDepth k @@ -253,14 +259,17 @@ instance Serial XPubKey where <*> deserialize <*> (pubKeyPoint <$> deserialize) + instance Serialize XPubKey where put = serialize get = deserialize + instance Binary XPubKey where put = serialize get = deserialize + -- | Decode an extended public key from a JSON string xPubFromJSON :: Network -> Value -> Parser XPubKey xPubFromJSON net = @@ -269,16 +278,18 @@ xPubFromJSON net = Nothing -> fail "could not read xpub" Just x -> return x + -- | Get JSON 'Value' from 'XPubKey'. xPubToJSON :: Network -> XPubKey -> Value xPubToJSON net = A.String . xPubExport net + xPubToEncoding :: Network -> XPubKey -> Encoding xPubToEncoding net = text . xPubExport net -{- | Build a BIP32 compatible extended private key from a bytestring. This will - produce a root node (@depth=0@ and @parent=0@). --} + +-- | Build a BIP32 compatible extended private key from a bytestring. This will +-- produce a root node (@depth=0@ and @parent=0@). makeXPrvKey :: ByteString -> XPrvKey makeXPrvKey bs = XPrvKey 0 (Fingerprint 0) 0 c k @@ -287,23 +298,23 @@ makeXPrvKey bs = k = fromMaybe err (secKey (runPutS (serialize p))) err = throw $ DerivationException "Invalid seed" -{- | Derive an extended public key from an extended private key. This function - will preserve the depth, parent, index and chaincode fields of the extended - private keys. --} + +-- | Derive an extended public key from an extended private key. This function +-- will preserve the depth, parent, index and chaincode fields of the extended +-- private keys. deriveXPubKey :: XPrvKey -> XPubKey deriveXPubKey (XPrvKey d p i c k) = XPubKey d p i c (derivePubKey k) -{- | Compute a private, soft child key derivation. A private soft derivation - will allow the equivalent extended public key to derive the public key for - this child. Given a parent key /m/ and a derivation index /i/, this function - will compute /m\/i/. - Soft derivations allow for more flexibility such as read-only wallets. - However, care must be taken not the leak both the parent extended public key - and one of the extended child private keys as this would compromise the - extended parent private key. --} +-- | Compute a private, soft child key derivation. A private soft derivation +-- will allow the equivalent extended public key to derive the public key for +-- this child. Given a parent key /m/ and a derivation index /i/, this function +-- will compute /m\/i/. +-- +-- Soft derivations allow for more flexibility such as read-only wallets. +-- However, care must be taken not the leak both the parent extended public key +-- and one of the extended child private keys as this would compromise the +-- extended parent private key. prvSubKey :: -- | extended parent private key XPrvKey -> @@ -322,9 +333,9 @@ prvSubKey xkey child k = fromMaybe err $ tweakSecKey (xPrvKey xkey) a err = throw $ DerivationException "Invalid prvSubKey derivation" -{- | Compute a public, soft child key derivation. Given a parent key /M/ - and a derivation index /i/, this function will compute /M\/i/. --} + +-- | Compute a public, soft child key derivation. Given a parent key /M/ +-- and a derivation index /i/, this function will compute /M\/i/. pubSubKey :: -- | extended parent public key XPubKey -> @@ -342,13 +353,13 @@ pubSubKey xKey child pK = fromMaybe err $ tweakPubKey (xPubKey xKey) a err = throw $ DerivationException "Invalid pubSubKey derivation" -{- | Compute a hard child key derivation. Hard derivations can only be computed - for private keys. Hard derivations do not allow the parent public key to - derive the child public keys. However, they are safer as a breach of the - parent public key and child private keys does not lead to a breach of the - parent private key. Given a parent key /m/ and a derivation index /i/, this - function will compute /m\/i'/. --} + +-- | Compute a hard child key derivation. Hard derivations can only be computed +-- for private keys. Hard derivations do not allow the parent public key to +-- derive the child public keys. However, they are safer as a breach of the +-- parent public key and child private keys does not lead to a breach of the +-- parent private key. Given a parent key /m/ and a derivation index /i/, this +-- function will compute /m\/i'/. hardSubKey :: -- | extended parent private key XPrvKey -> @@ -367,38 +378,41 @@ hardSubKey xkey child k = fromMaybe err $ tweakSecKey (xPrvKey xkey) a err = throw $ DerivationException "Invalid hardSubKey derivation" -{- | Returns true if the extended private key was derived through a hard - derivation. --} + +-- | Returns true if the extended private key was derived through a hard +-- derivation. xPrvIsHard :: XPrvKey -> Bool xPrvIsHard k = testBit (xPrvIndex k) 31 -{- | Returns true if the extended public key was derived through a hard - derivation. --} + +-- | Returns true if the extended public key was derived through a hard +-- derivation. xPubIsHard :: XPubKey -> Bool xPubIsHard k = testBit (xPubIndex k) 31 -{- | Returns the derivation index of this extended private key without the hard - bit set. --} + +-- | Returns the derivation index of this extended private key without the hard +-- bit set. xPrvChild :: XPrvKey -> KeyIndex xPrvChild k = clearBit (xPrvIndex k) 31 -{- | Returns the derivation index of this extended public key without the hard - bit set. --} + +-- | Returns the derivation index of this extended public key without the hard +-- bit set. xPubChild :: XPubKey -> KeyIndex xPubChild k = clearBit (xPubIndex k) 31 + -- | Computes the key identifier of an extended private key. xPrvID :: XPrvKey -> Hash160 xPrvID = xPubID . deriveXPubKey + -- | Computes the key identifier of an extended public key. xPubID :: XPubKey -> Hash160 xPubID = ripemd160 . runPutS . serialize . sha256 . exportPubKey True . xPubKey + -- | Computes the key fingerprint of an extended private key. xPrvFP :: XPrvKey -> Fingerprint xPrvFP = @@ -406,6 +420,7 @@ xPrvFP = where err = error "Could not decode xPrvFP" + -- | Computes the key fingerprint of an extended public key. xPubFP :: XPubKey -> Fingerprint xPubFP = @@ -413,45 +428,51 @@ xPubFP = where err = error "Could not decode xPubFP" + -- | Compute a standard P2PKH address for an extended public key. xPubAddr :: XPubKey -> Address xPubAddr xkey = pubKeyAddr (wrapPubKey True (xPubKey xkey)) + -- | Compute a SegWit P2WPKH address for an extended public key. xPubWitnessAddr :: XPubKey -> Address xPubWitnessAddr xkey = pubKeyWitnessAddr (wrapPubKey True (xPubKey xkey)) -{- | Compute a backwards-compatible SegWit P2SH-P2WPKH address for an extended - public key. --} + +-- | Compute a backwards-compatible SegWit P2SH-P2WPKH address for an extended +-- public key. xPubCompatWitnessAddr :: XPubKey -> Address xPubCompatWitnessAddr xkey = pubKeyCompatWitnessAddr (wrapPubKey True (xPubKey xkey)) + -- | Exports an extended private key to the BIP32 key export format ('Base58'). xPrvExport :: Network -> XPrvKey -> Base58 xPrvExport net = encodeBase58Check . runPutS . putXPrvKey net + -- | Exports an extended public key to the BIP32 key export format ('Base58'). xPubExport :: Network -> XPubKey -> Base58 xPubExport net = encodeBase58Check . runPutS . putXPubKey net -{- | Decodes a BIP32 encoded extended private key. This function will fail if - invalid base 58 characters are detected or if the checksum fails. --} + +-- | Decodes a BIP32 encoded extended private key. This function will fail if +-- invalid base 58 characters are detected or if the checksum fails. xPrvImport :: Network -> Base58 -> Maybe XPrvKey xPrvImport net = eitherToMaybe . runGetS (getXPrvKey net) <=< decodeBase58Check -{- | Decodes a BIP32 encoded extended public key. This function will fail if - invalid base 58 characters are detected or if the checksum fails. --} + +-- | Decodes a BIP32 encoded extended public key. This function will fail if +-- invalid base 58 characters are detected or if the checksum fails. xPubImport :: Network -> Base58 -> Maybe XPubKey xPubImport net = eitherToMaybe . runGetS (getXPubKey net) <=< decodeBase58Check + -- | Export an extended private key to WIF (Wallet Import Format). xPrvWif :: Network -> XPrvKey -> Base58 xPrvWif net xkey = toWif net (wrapSecKey True (xPrvKey xkey)) + -- | Parse a binary extended private key. getXPrvKey :: MonadGet m => Network -> m XPrvKey getXPrvKey net = do @@ -461,12 +482,14 @@ getXPrvKey net = do "Get: Invalid version for extended private key" deserialize + -- | Serialize an extended private key. putXPrvKey :: MonadPut m => Network -> XPrvKey -> m () putXPrvKey net k = do putWord32be $ getExtSecretPrefix net serialize k + -- | Parse a binary extended public key. getXPubKey :: MonadGet m => Network -> m XPubKey getXPubKey net = do @@ -476,32 +499,34 @@ getXPubKey net = do "Get: Invalid version for extended public key" deserialize + -- | Serialize an extended public key. putXPubKey :: MonadPut m => Network -> XPubKey -> m () putXPubKey net k = do putWord32be $ getExtPubKeyPrefix net serialize k + {- Derivation helpers -} -{- | Cyclic list of all private soft child key derivations of a parent key - starting from an offset index. --} +-- | Cyclic list of all private soft child key derivations of a parent key +-- starting from an offset index. prvSubKeys :: XPrvKey -> KeyIndex -> [(XPrvKey, KeyIndex)] prvSubKeys k = map (\i -> (prvSubKey k i, i)) . cycleIndex -{- | Cyclic list of all public soft child key derivations of a parent key - starting from an offset index. --} + +-- | Cyclic list of all public soft child key derivations of a parent key +-- starting from an offset index. pubSubKeys :: XPubKey -> KeyIndex -> [(XPubKey, KeyIndex)] pubSubKeys k = map (\i -> (pubSubKey k i, i)) . cycleIndex -{- | Cyclic list of all hard child key derivations of a parent key starting - from an offset index. --} + +-- | Cyclic list of all hard child key derivations of a parent key starting +-- from an offset index. hardSubKeys :: XPrvKey -> KeyIndex -> [(XPrvKey, KeyIndex)] hardSubKeys k = map (\i -> (hardSubKey k i, i)) . cycleIndex + -- | Derive a standard address from an extended public key and an index. deriveAddr :: XPubKey -> KeyIndex -> (Address, PubKey) deriveAddr k i = @@ -509,6 +534,7 @@ deriveAddr k i = where key = pubSubKey k i + -- | Derive a SegWit P2WPKH address from an extended public key and an index. deriveWitnessAddr :: XPubKey -> KeyIndex -> (Address, PubKey) deriveWitnessAddr k i = @@ -516,56 +542,56 @@ deriveWitnessAddr k i = where key = pubSubKey k i -{- | Derive a backwards-compatible SegWit P2SH-P2WPKH address from an extended - public key and an index. --} + +-- | Derive a backwards-compatible SegWit P2SH-P2WPKH address from an extended +-- public key and an index. deriveCompatWitnessAddr :: XPubKey -> KeyIndex -> (Address, PubKey) deriveCompatWitnessAddr k i = (xPubCompatWitnessAddr key, xPubKey key) where key = pubSubKey k i -{- | Cyclic list of all addresses derived from a public key starting from an - offset index. --} + +-- | Cyclic list of all addresses derived from a public key starting from an +-- offset index. deriveAddrs :: XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)] deriveAddrs k = map f . cycleIndex where f i = let (a, key) = deriveAddr k i in (a, key, i) -{- | Cyclic list of all SegWit P2WPKH addresses derived from a public key - starting from an offset index. --} + +-- | Cyclic list of all SegWit P2WPKH addresses derived from a public key +-- starting from an offset index. deriveWitnessAddrs :: XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)] deriveWitnessAddrs k = map f . cycleIndex where f i = let (a, key) = deriveWitnessAddr k i in (a, key, i) -{- | Cyclic list of all backwards-compatible SegWit P2SH-P2WPKH addresses - derived from a public key starting from an offset index. --} + +-- | Cyclic list of all backwards-compatible SegWit P2SH-P2WPKH addresses +-- derived from a public key starting from an offset index. deriveCompatWitnessAddrs :: XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)] deriveCompatWitnessAddrs k = map f . cycleIndex where f i = let (a, key) = deriveCompatWitnessAddr k i in (a, key, i) -{- | Derive a multisig address from a list of public keys, the number of - required signatures /m/ and a derivation index. The derivation type is a - public, soft derivation. --} + +-- | Derive a multisig address from a list of public keys, the number of +-- required signatures /m/ and a derivation index. The derivation type is a +-- public, soft derivation. deriveMSAddr :: [XPubKey] -> Int -> KeyIndex -> (Address, RedeemScript) deriveMSAddr keys m i = (payToScriptAddress rdm, rdm) where rdm = sortMulSig $ PayMulSig k m k = map (wrapPubKey True . xPubKey . flip pubSubKey i) keys -{- | Cyclic list of all multisig addresses derived from a list of public keys, - a number of required signatures /m/ and starting from an offset index. The - derivation type is a public, soft derivation. --} + +-- | Cyclic list of all multisig addresses derived from a list of public keys, +-- a number of required signatures /m/ and starting from an offset index. The +-- derivation type is a public, soft derivation. deriveMSAddrs :: [XPubKey] -> Int -> @@ -577,6 +603,7 @@ deriveMSAddrs keys m = map f . cycleIndex let (a, rdm) = deriveMSAddr keys m i in (a, rdm, i) + -- | Helper function to go through derivation indices. cycleIndex :: KeyIndex -> [KeyIndex] cycleIndex i @@ -584,73 +611,88 @@ cycleIndex i | i < 0x80000000 = cycle $ [i .. 0x7fffffff] ++ [0 .. (i - 1)] | otherwise = error $ "cycleIndex: invalid index " ++ show i + {- Derivation Paths -} -{- | Phantom type signaling a hardened derivation path that can only be computed - from private extended key. --} +-- | Phantom type signaling a hardened derivation path that can only be computed +-- from private extended key. data HardDeriv deriving (Generic, NFData) + -- | Phantom type signaling no knowledge about derivation path: can be hardened or not. data AnyDeriv deriving (Generic, NFData) -{- | Phantom type signaling derivation path including only non-hardened paths - that can be computed from an extended public key. --} + +-- | Phantom type signaling derivation path including only non-hardened paths +-- that can be computed from an extended public key. data SoftDeriv deriving (Generic, NFData) + -- | Hardened derivation path. Can be computed from extended private key only. type HardPath = DerivPathI HardDeriv + -- | Any derivation path. type DerivPath = DerivPathI AnyDeriv + -- | Non-hardened derivation path can be computed from extended public key. type SoftPath = DerivPathI SoftDeriv + -- | Helper class to perform validations on a hardened derivation path. class HardOrAny a + instance HardOrAny HardDeriv + + instance HardOrAny AnyDeriv + -- | Helper class to perform validations on a non-hardened derivation path. class AnyOrSoft a + instance AnyOrSoft AnyDeriv + + instance AnyOrSoft SoftDeriv -{- | Data type representing a derivation path. Two constructors are provided - for specifying soft or hard derivations. The path /\/0\/1'\/2/ for example can be - expressed as @'Deriv' :\/ 0 :| 1 :\/ 2@. The 'HardOrAny' and 'AnyOrSoft' type - classes are used to constrain the valid values for the phantom type /t/. If - you mix hard '(:|)' and soft '(:\/)' paths, the only valid type for /t/ is 'AnyDeriv'. - Otherwise, /t/ can be 'HardDeriv' if you only have hard derivation or 'SoftDeriv' - if you only have soft derivations. - - Using this type is as easy as writing the required derivation like in these - example: - - > Deriv :/ 0 :/ 1 :/ 2 :: SoftPath - > Deriv :| 0 :| 1 :| 2 :: HardPath - > Deriv :| 0 :/ 1 :/ 2 :: DerivPath --} + +-- | Data type representing a derivation path. Two constructors are provided +-- for specifying soft or hard derivations. The path /\/0\/1'\/2/ for example can be +-- expressed as @'Deriv' :\/ 0 :| 1 :\/ 2@. The 'HardOrAny' and 'AnyOrSoft' type +-- classes are used to constrain the valid values for the phantom type /t/. If +-- you mix hard '(:|)' and soft '(:\/)' paths, the only valid type for /t/ is 'AnyDeriv'. +-- Otherwise, /t/ can be 'HardDeriv' if you only have hard derivation or 'SoftDeriv' +-- if you only have soft derivations. +-- +-- Using this type is as easy as writing the required derivation like in these +-- example: +-- +-- > Deriv :/ 0 :/ 1 :/ 2 :: SoftPath +-- > Deriv :| 0 :| 1 :| 2 :: HardPath +-- > Deriv :| 0 :/ 1 :/ 2 :: DerivPath data DerivPathI t where (:|) :: HardOrAny t => !(DerivPathI t) -> !KeyIndex -> DerivPathI t (:/) :: AnyOrSoft t => !(DerivPathI t) -> !KeyIndex -> DerivPathI t Deriv :: DerivPathI t + instance NFData (DerivPathI t) where rnf (a :| b) = rnf a `seq` rnf b rnf (a :/ b) = rnf a `seq` rnf b rnf Deriv = () + instance Eq (DerivPathI t) where (nextA :| iA) == (nextB :| iB) = iA == iB && nextA == nextB (nextA :/ iA) == (nextB :/ iB) = iA == iB && nextA == nextB Deriv == Deriv = True _ == _ = False + instance Ord (DerivPathI t) where -- Same hardness on each side (nextA :| iA) `compare` (nextB :| iB) = @@ -666,18 +708,22 @@ instance Ord (DerivPathI t) where Deriv `compare` _ = LT _ `compare` Deriv = GT + instance Serial DerivPath where deserialize = listToPath <$> getList getWord32be serialize = putList putWord32be . pathToList + instance Serialize DerivPath where put = serialize get = deserialize + instance Binary DerivPath where put = serialize get = deserialize + instance Serial HardPath where deserialize = maybe @@ -688,14 +734,17 @@ instance Serial HardPath where =<< getList getWord32be serialize = putList putWord32be . pathToList + instance Serialize HardPath where put = serialize get = deserialize + instance Binary HardPath where put = serialize get = deserialize + instance Serial SoftPath where deserialize = maybe @@ -706,14 +755,17 @@ instance Serial SoftPath where =<< getList getWord32be serialize = putList putWord32be . pathToList + instance Serialize SoftPath where put = serialize get = deserialize + instance Binary SoftPath where put = serialize get = deserialize + -- | Get a list of derivation indices from a derivation path. pathToList :: DerivPathI t -> [KeyIndex] pathToList = @@ -723,6 +775,7 @@ pathToList = go (next :/ i) = i : go next go _ = [] + -- | Convert a list of derivation indices to a derivation path. listToPath :: [KeyIndex] -> DerivPath listToPath = @@ -733,6 +786,7 @@ listToPath = | otherwise = go is :/ i go [] = Deriv + -- | Convert a derivation path to a human-readable string. pathToStr :: DerivPathI t -> String pathToStr p = @@ -741,24 +795,25 @@ pathToStr p = next :/ i -> concat [pathToStr next, "/", show i] Deriv -> "" -{- | Turn a derivation path into a hard derivation path. Will fail if the path - contains soft derivations. --} + +-- | Turn a derivation path into a hard derivation path. Will fail if the path +-- contains soft derivations. toHard :: DerivPathI t -> Maybe HardPath toHard p = case p of next :| i -> (:| i) <$> toHard next Deriv -> Just Deriv _ -> Nothing -{- | Turn a derivation path into a soft derivation path. Will fail if the path - has hard derivations. --} + +-- | Turn a derivation path into a soft derivation path. Will fail if the path +-- has hard derivations. toSoft :: DerivPathI t -> Maybe SoftPath toSoft p = case p of next :/ i -> (:/ i) <$> toSoft next Deriv -> Just Deriv _ -> Nothing + -- | Make a derivation path generic. toGeneric :: DerivPathI t -> DerivPath toGeneric p = case p of @@ -766,9 +821,9 @@ toGeneric p = case p of next :| i -> toGeneric next :| i Deriv -> Deriv -{- | Append two derivation paths together. The result will be a mixed - derivation path. --} + +-- | Append two derivation paths together. The result will be a mixed +-- derivation path. (++/) :: DerivPathI t1 -> DerivPathI t2 -> DerivPath (++/) p1 p2 = go id (toGeneric p2) $ toGeneric p1 @@ -778,6 +833,7 @@ toGeneric p = case p of next :| i -> go (f . (:| i)) $ toGeneric next _ -> f + -- | Derive a private key from a derivation path derivePath :: DerivPathI t -> XPrvKey -> XPrvKey derivePath = go id @@ -788,6 +844,7 @@ derivePath = go id next :/ i -> go (f . flip prvSubKey i) next _ -> f + -- | Derive a public key from a soft derivation path derivePubPath :: SoftPath -> XPubKey -> XPubKey derivePubPath = go id @@ -797,87 +854,103 @@ derivePubPath = go id next :/ i -> go (f . flip pubSubKey i) next _ -> f + instance Show DerivPath where showsPrec d p = showParen (d > 10) $ showString "DerivPath " . shows (pathToStr p) + instance Read DerivPath where readPrec = parens $ do R.Ident "DerivPath" <- lexP R.String str <- lexP maybe pfail (return . getParsedPath) (parsePath str) + instance Show HardPath where showsPrec d p = showParen (d > 10) $ showString "HardPath " . shows (pathToStr p) + instance Read HardPath where readPrec = parens $ do R.Ident "HardPath" <- lexP R.String str <- lexP maybe pfail return $ parseHard str + instance Show SoftPath where showsPrec d p = showParen (d > 10) $ showString "SoftPath " . shows (pathToStr p) + instance Read SoftPath where readPrec = parens $ do R.Ident "SoftPath" <- lexP R.String str <- lexP maybe pfail return $ parseSoft str + instance IsString ParsedPath where fromString = fromMaybe e . parsePath where e = error "Could not parse derivation path" + instance IsString DerivPath where fromString = getParsedPath . fromMaybe e . parsePath where e = error "Could not parse derivation path" + instance IsString HardPath where fromString = fromMaybe e . parseHard where e = error "Could not parse hard derivation path" + instance IsString SoftPath where fromString = fromMaybe e . parseSoft where e = error "Could not parse soft derivation path" + instance FromJSON ParsedPath where parseJSON = withText "ParsedPath" $ \str -> case parsePath $ cs str of Just p -> return p _ -> mzero + instance FromJSON DerivPath where parseJSON = withText "DerivPath" $ \str -> case parsePath $ cs str of Just p -> return $ getParsedPath p _ -> mzero + instance FromJSON HardPath where parseJSON = withText "HardPath" $ \str -> case parseHard $ cs str of Just p -> return p _ -> mzero + instance FromJSON SoftPath where parseJSON = withText "SoftPath" $ \str -> case parseSoft $ cs str of Just p -> return p _ -> mzero + instance ToJSON (DerivPathI t) where toJSON = A.String . cs . pathToStr toEncoding = text . cs . pathToStr + instance ToJSON ParsedPath where toJSON (ParsedPrv p) = A.String . cs . ("m" ++) . pathToStr $ p toJSON (ParsedPub p) = A.String . cs . ("M" ++) . pathToStr $ p @@ -886,17 +959,18 @@ instance ToJSON ParsedPath where toEncoding (ParsedPub p) = text . cs . ("M" ++) . pathToStr $ p toEncoding (ParsedEmpty p) = text . cs . ("" ++) . pathToStr $ p + {- Parsing derivation paths of the form m/1/2'/3 or M/1/2'/3 -} -{- | Type for parsing derivation paths of the form /m\/1\/2'\/3/ or - /M\/1\/2'\/3/. --} +-- | Type for parsing derivation paths of the form /m\/1\/2'\/3/ or +-- /M\/1\/2'\/3/. data ParsedPath = ParsedPrv {getParsedPath :: !DerivPath} | ParsedPub {getParsedPath :: !DerivPath} | ParsedEmpty {getParsedPath :: !DerivPath} deriving (Eq, Generic, NFData) + instance Show ParsedPath where showsPrec d p = showParen (d > 10) $ showString "ParsedPath " . shows f where @@ -906,15 +980,16 @@ instance Show ParsedPath where ParsedPub d' -> "M" <> pathToStr d' ParsedEmpty d' -> pathToStr d' + instance Read ParsedPath where readPrec = parens $ do R.Ident "ParsedPath" <- lexP R.String str <- lexP maybe pfail return $ parsePath str -{- | Parse derivation path string for extended key. - Forms: /m\/0'\/2/, /M\/2\/3\/4/. --} + +-- | Parse derivation path string for extended key. +-- Forms: /m\/0'\/2/, /M\/2\/3\/4/. parsePath :: String -> Maybe ParsedPath parsePath str = do res <- concatBip32Segments <$> mapM parseBip32PathIndex xs @@ -926,15 +1001,18 @@ parsePath str = do where (x : xs) = splitOn "/" str + -- | Concatenate derivation path indices into a derivation path. concatBip32Segments :: [Bip32PathIndex] -> DerivPath concatBip32Segments = foldl' appendBip32Segment Deriv + -- | Append an extra derivation path index element into an existing path. appendBip32Segment :: DerivPath -> Bip32PathIndex -> DerivPath appendBip32Segment d (Bip32SoftIndex i) = d :/ i appendBip32Segment d (Bip32HardIndex i) = d :| i + -- | Parse a BIP32 derivation path index element from a string. parseBip32PathIndex :: String -> Maybe Bip32PathIndex parseBip32PathIndex segment = case reads segment of @@ -942,12 +1020,14 @@ parseBip32PathIndex segment = case reads segment of [(i, "'")] -> guard (is31Bit i) >> return (Bip32HardIndex i) _ -> Nothing + -- | Type for BIP32 path index element. data Bip32PathIndex = Bip32HardIndex KeyIndex | Bip32SoftIndex KeyIndex deriving (Eq, Generic, NFData) + instance Show Bip32PathIndex where showsPrec d (Bip32HardIndex i) = showParen (d > 10) $ @@ -956,6 +1036,7 @@ instance Show Bip32PathIndex where showParen (d > 10) $ showString "Bip32SoftIndex " . shows i + instance Read Bip32PathIndex where readPrec = h <|> s where @@ -970,18 +1051,22 @@ instance Read Bip32PathIndex where R.Number n <- lexP maybe pfail (return . Bip32SoftIndex . fromIntegral) (numberToInteger n) + -- | Test whether the number could be a valid BIP32 derivation index. is31Bit :: (Integral a) => a -> Bool is31Bit i = i >= 0 && i < 0x80000000 + -- | Helper function to parse a hard path. parseHard :: String -> Maybe HardPath parseHard = toHard . getParsedPath <=< parsePath + -- | Helper function to parse a soft path. parseSoft :: String -> Maybe SoftPath parseSoft = toSoft . getParsedPath <=< parsePath + -- | Data type representing a private or public key with its respective network. data XKey = XPrv @@ -994,12 +1079,12 @@ data XKey } deriving (Eq, Show, Generic, NFData) -{- | Apply a parsed path to an extended key to derive the new key defined in the - path. If the path starts with /m/, a private key will be returned and if the - path starts with /M/, a public key will be returned. Private derivations on a - public key, and public derivations with a hard segment, return an error - value. --} + +-- | Apply a parsed path to an extended key to derive the new key defined in the +-- path. If the path starts with /m/, a private key will be returned and if the +-- path starts with /M/, a public key will be returned. Private derivations on a +-- public key, and public derivations with a hard segment, return an error +-- value. applyPath :: ParsedPath -> XKey -> Either String XKey applyPath path key = case (path, key) of @@ -1026,22 +1111,23 @@ applyPath path key = Deriv -> Right f _ -> Left "applyPath: Invalid hard derivation" + {- Helpers for derivation paths and addresses -} -- | Derive an address from a given parent path. derivePathAddr :: XPubKey -> SoftPath -> KeyIndex -> (Address, PubKey) derivePathAddr key path = deriveAddr (derivePubPath path key) -{- | Cyclic list of all addresses derived from a given parent path and starting - from the given offset index. --} + +-- | Cyclic list of all addresses derived from a given parent path and starting +-- from the given offset index. derivePathAddrs :: XPubKey -> SoftPath -> KeyIndex -> [(Address, PubKey, KeyIndex)] derivePathAddrs key path = deriveAddrs (derivePubPath path key) -{- | Derive a multisig address from a given parent path. The number of required - signatures (m in m of n) is also needed. --} + +-- | Derive a multisig address from a given parent path. The number of required +-- signatures (m in m of n) is also needed. derivePathMSAddr :: [XPubKey] -> SoftPath -> @@ -1051,10 +1137,10 @@ derivePathMSAddr :: derivePathMSAddr keys path = deriveMSAddr $ map (derivePubPath path) keys -{- | Cyclic list of all multisig addresses derived from a given parent path and - starting from the given offset index. The number of required signatures - (m in m of n) is also needed. --} + +-- | Cyclic list of all multisig addresses derived from a given parent path and +-- starting from the given offset index. The number of required signatures +-- (m in m of n) is also needed. derivePathMSAddrs :: [XPubKey] -> SoftPath -> @@ -1064,6 +1150,7 @@ derivePathMSAddrs :: derivePathMSAddrs keys path = deriveMSAddrs $ map (derivePubPath path) keys + {- Utilities for extended keys -} -- | De-serialize HDW-specific private key. @@ -1076,9 +1163,11 @@ getPadPrvKey = do Left e -> fail e Right x -> return x + -- | Serialize HDW-specific private key. putPadPrvKey :: MonadPut m => SecKey -> m () putPadPrvKey p = putWord8 0x00 >> putByteString (runPutS (S.put p)) + bsPadPrvKey :: SecKey -> ByteString bsPadPrvKey = runPutS . putPadPrvKey diff --git a/src/Haskoin/Keys/Extended/Internal.hs b/src/Haskoin/Keys/Extended/Internal.hs index 57d539cb..21b37dd0 100644 --- a/src/Haskoin/Keys/Extended/Internal.hs +++ b/src/Haskoin/Keys/Extended/Internal.hs @@ -34,25 +34,31 @@ 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 @@ -64,20 +70,25 @@ instance IsString Fingerprint where decodeError = error "Fingerprint literal: Unable to decode" hexError = error "Fingerprint literal: Invalid hex" + instance Serial Fingerprint where serialize = putWord32be . unFingerprint deserialize = Fingerprint <$> getWord32be + instance Binary Fingerprint where put = serialize get = deserialize + instance Serialize Fingerprint where put = serialize get = deserialize + instance FromJSON Fingerprint where parseJSON = withText "Fingerprint" $ either fail pure . textToFingerprint + instance ToJSON Fingerprint where toJSON = toJSON . fingerprintToText diff --git a/src/Haskoin/Keys/Mnemonic.hs b/src/Haskoin/Keys/Mnemonic.hs index 34ee3929..4477c952 100644 --- a/src/Haskoin/Keys/Mnemonic.hs +++ b/src/Haskoin/Keys/Mnemonic.hs @@ -1,15 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} -{- | -Module : Haskoin.Keys.Mnemonic -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Mnemonic keys (BIP-39). Only English dictionary. --} +-- | +-- Stability : experimental +-- Portability : POSIX +-- +-- Mnemonic keys (BIP-39). Only English dictionary. module Haskoin.Keys.Mnemonic ( -- * Mnemonic Sentences Entropy, @@ -39,30 +34,35 @@ import Data.Vector (Vector, (!)) import qualified Data.Vector as V import Haskoin.Util -{- | Random data used to create a mnemonic sentence. Use a good entropy source. - You will get your coins stolen if you don't. You have been warned. --} + +-- | Random data used to create a mnemonic sentence. Use a good entropy source. +-- You will get your coins stolen if you don't. You have been warned. type Entropy = ByteString + -- | Human-readable mnemonic sentence. type Mnemonic = Text + -- | Optional passphrase for mnemnoic sentence. type Passphrase = Text + -- | Seed for a private key from a mnemonic sentence. type Seed = ByteString + -- | Mnemonic key checksum. type Checksum = ByteString + -- | Paremeters for PBKDF2 function. pbkdfParams :: Parameters pbkdfParams = Parameters{iterCounts = 2048, outputLength = 64} -{- | Provide intial 'Entropy' as a 'ByteString' of length multiple of 4 bytes. - Output a 'Mnemonic' sentence. --} + +-- | Provide intial 'Entropy' as a 'ByteString' of length multiple of 4 bytes. +-- Output a 'Mnemonic' sentence. toMnemonic :: Entropy -> Either String Mnemonic toMnemonic ent = do when (BS.null ent) $ @@ -78,24 +78,27 @@ toMnemonic ent = do indices = bsToIndices $ ent `BS.append` c ms = T.unwords $ map (wl !) indices -{- | Revert 'toMnemonic'. Do not use this to generate a 'Seed'. Instead use - 'mnemonicToSeed'. This outputs the original 'Entropy' used to generate a - 'Mnemonic' sentence. --} + +-- | Revert 'toMnemonic'. Do not use this to generate a 'Seed'. Instead use +-- 'mnemonicToSeed'. This outputs the original 'Entropy' used to generate a +-- 'Mnemonic' sentence. fromMnemonic :: Mnemonic -> Either String Entropy fromMnemonic ms = do when (T.null ms) $ Left "fromMnemonic: empty mnemonic" when (word_count > 48) $ - Left $ "fromMnemonic: too many words: " ++ show word_count + Left $ + "fromMnemonic: too many words: " ++ show word_count when (word_count `mod` 3 /= 0) $ - Left $ "fromMnemonic: wrong number of words:" ++ show word_count + Left $ + "fromMnemonic: wrong number of words:" ++ show word_count ms_bs <- indicesToBS =<< getIndices ms_words let (ms_ent, ms_cs) = BS.splitAt (ent_len * 4) ms_bs ms_cs_num = numCS cs_len ms_cs ent_cs_num = numCS cs_len $ calcCS cs_len ms_ent when (ent_cs_num /= ms_cs_num) $ - Left $ "fromMnemonic: checksum failed: " ++ sh ent_cs_num ms_cs_num + Left $ + "fromMnemonic: checksum failed: " ++ sh ent_cs_num ms_cs_num return ms_ent where ms_words = T.words ms @@ -103,10 +106,12 @@ fromMnemonic ms = do (ent_len, cs_len) = (word_count * 11) `quotRem` 32 sh cs_a cs_b = show cs_a ++ " /= " ++ show cs_b + -- | Compute 'Checksum'. calcCS :: Int -> Entropy -> Checksum calcCS len = getBits len . BA.convert . hashWith SHA256 + numCS :: Int -> Entropy -> Integer numCS len = shiftCS . bsToInteger @@ -115,10 +120,10 @@ numCS len = 8 -> id x -> flip shiftR x -{- | Turn an arbitrary sequence of characters into a 512-bit 'Seed'. Use - 'mnemonicToSeed' to get a seed from a 'Mnemonic' sentence. Warning: Does not - perform NFKD normalization. --} + +-- | Turn an arbitrary sequence of characters into a 512-bit 'Seed'. Use +-- 'mnemonicToSeed' to get a seed from a 'Mnemonic' sentence. Warning: Does not +-- perform NFKD normalization. anyToSeed :: Passphrase -> Mnemonic -> Seed anyToSeed pf ms = fastPBKDF2_SHA512 @@ -126,16 +131,17 @@ anyToSeed pf ms = (E.encodeUtf8 ms) ("mnemonic" `mappend` E.encodeUtf8 pf) -{- | Get a 512-bit 'Seed' from a 'Mnemonic' sentence. Will validate checksum. - 'Passphrase' can be used to protect the 'Mnemonic'. Use an empty string as - 'Passphrase' if none is required. --} + +-- | Get a 512-bit 'Seed' from a 'Mnemonic' sentence. Will validate checksum. +-- 'Passphrase' can be used to protect the 'Mnemonic'. Use an empty string as +-- 'Passphrase' if none is required. mnemonicToSeed :: Passphrase -> Mnemonic -> Either String Seed mnemonicToSeed pf ms = do ent <- fromMnemonic ms mnm <- toMnemonic ent return $ anyToSeed pf mnm + -- | Get indices of words in word list. getIndices :: [Text] -> Either String [Int] getIndices ws @@ -146,6 +152,7 @@ getIndices ws n = elemIndices Nothing i w = T.unwords $ map (ws !!) n + -- | Turn a list of 11-bit numbers into a 'ByteString' indicesToBS :: [Int] -> Either String ByteString indicesToBS is = do @@ -165,6 +172,7 @@ indicesToBS is = do pad bs = BS.append (BS.replicate (bl - BS.length bs) 0x00) bs f acc x = (acc `shiftL` 11) + fromIntegral x + -- | Turn a 'ByteString' into a list of 11-bit numbers. bsToIndices :: ByteString -> [Int] bsToIndices bs = @@ -174,9 +182,11 @@ bsToIndices bs = go 0 _ = [] go n i = fromIntegral (i `mod` 2048) : go (n - 1) (i `shiftR` 11) + wl' :: M.Map Text Int wl' = V.ifoldr' (flip M.insert) M.empty wl + -- | Standard English dictionary from BIP-39 specification. wl :: Vector Text wl = diff --git a/src/Haskoin/Network.hs b/src/Haskoin/Network.hs index fbe1a200..ad2fd6eb 100644 --- a/src/Haskoin/Network.hs +++ b/src/Haskoin/Network.hs @@ -1,15 +1,10 @@ -{- | -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. --} +-- | +-- 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 Common, module Message, @@ -19,3 +14,4 @@ module Haskoin.Network ( import Haskoin.Network.Bloom as Bloom import Haskoin.Network.Common as Common import Haskoin.Network.Message as Message + diff --git a/src/Haskoin/Network/Bloom.hs b/src/Haskoin/Network/Bloom.hs index 047add34..8ec80b5e 100644 --- a/src/Haskoin/Network/Bloom.hs +++ b/src/Haskoin/Network/Bloom.hs @@ -1,19 +1,14 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} -{- | -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. --} +-- | +-- 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 (..), @@ -50,25 +45,30 @@ import Haskoin.Network.Common import Haskoin.Script.Standard import Haskoin.Transaction.Common + -- | 20,000 items with fp rate < 0.1% or 10,000 items and <0.0001% maxBloomSize :: Int maxBloomSize = 36000 + maxHashFuncs :: Word32 maxHashFuncs = 50 + ln2Squared :: Double ln2Squared = 0.4804530139182014246671025263266649717305529515945455 + ln2 :: Double 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 @@ -78,6 +78,7 @@ data BloomFlags BloomUpdateP2PubKeyOnly deriving (Eq, Show, Read, Generic, NFData) + instance Serial BloomFlags where deserialize = go =<< getWord8 where @@ -86,38 +87,42 @@ instance Serial BloomFlags where go 2 = return BloomUpdateP2PubKeyOnly go _ = fail "BloomFlags get: Invalid bloom flag" + serialize f = putWord8 $ case f of BloomUpdateNone -> 0 BloomUpdateAll -> 1 BloomUpdateP2PubKeyOnly -> 2 + instance Binary BloomFlags where get = deserialize put = serialize + instance Serialize BloomFlags where 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 + { bloomData :: !(S.Seq Word8) + -- ^ bloom filter data + , bloomHashFuncs :: !Word32 + -- ^ number of hash functions for this filter + , bloomTweak :: !Word32 + -- ^ hash function random nonce + , bloomFlags :: !BloomFlags + -- ^ bloom filter auto-update flags } deriving (Eq, Show, Read, Generic, NFData) + instance Serial BloomFilter where deserialize = BloomFilter @@ -128,6 +133,7 @@ instance Serial BloomFilter where where readDat (VarInt len) = replicateM (fromIntegral len) getWord8 + serialize (BloomFilter dat hashFuncs tweak flags) = do putVarInt $ S.length dat forM_ (F.toList dat) putWord8 @@ -135,57 +141,67 @@ instance Serial BloomFilter where putWord32le tweak serialize flags + instance Binary BloomFilter where put = serialize get = deserialize + instance Serialize BloomFilter where put = serialize get = deserialize + -- | Set a new bloom filter on the peer connection. newtype FilterLoad = FilterLoad {filterLoadBloomFilter :: BloomFilter} deriving (Eq, Show, Read, Generic, NFData) + instance Serial FilterLoad where deserialize = FilterLoad <$> deserialize serialize (FilterLoad f) = serialize f + instance Binary FilterLoad where put = serialize get = deserialize + instance Serialize FilterLoad where put = serialize get = deserialize -{- | Add the given data element to the connections current filter without - requiring a completely new one to be set. --} + +-- | 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) + instance Serial FilterAdd where deserialize = do (VarInt len) <- deserialize dat <- getByteString $ fromIntegral len return $ FilterAdd dat + serialize (FilterAdd bs) = do putVarInt $ BS.length bs putByteString bs + instance Binary FilterAdd where put = serialize get = deserialize + instance Serialize FilterAdd where 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 -> @@ -210,15 +226,16 @@ bloomCreate numElem fpRate = -- Suggested number of hash functions 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) where seed = hashNum * 0xfba4c795 + bloomTweak bfilter -{- | 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 -> @@ -238,9 +255,9 @@ bloomInsert bfilter bs s newData = foldl upd (bloomData bfilter) 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 -> @@ -257,12 +274,13 @@ bloomContains bfilter bs idxs = map (\i -> bloomHash bfilter i bs) [0 .. bloomHashFuncs bfilter - 1] isSet i = S.index s (fromIntegral $ i `shiftR` 3) - .&. (bitMask !! fromIntegral (7 .&. i)) /= 0 + .&. (bitMask !! fromIntegral (7 .&. i)) + /= 0 + -{- | Checks if any of the outputs of a tx is in the current bloom filter. - 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 -> @@ -305,14 +323,17 @@ bloomRelevantUpdate bfilter tx encodeScriptOut (DataCarrier getOutputDat) = runPutS $ serialize getOutputDat encodeScriptOut outputHash = (runPutS . serialize . getOutputHash) outputHash + -- | Returns True if the filter is empty (all bytes set to 0x00) isBloomEmpty :: BloomFilter -> Bool isBloomEmpty bfilter = all (== 0x00) $ F.toList $ bloomData bfilter + -- | Returns True if the filter is full (all bytes set to 0xff) isBloomFull :: BloomFilter -> Bool isBloomFull bfilter = all (== 0xff) $ F.toList $ bloomData bfilter + -- | Tests if a given bloom filter is valid. isBloomValid :: -- | Bloom filter to test @@ -323,6 +344,7 @@ isBloomValid bfilter = S.length (bloomData bfilter) <= maxBloomSize && bloomHashFuncs bfilter <= maxHashFuncs + -- | Does the peer with these version services accept bloom filters? acceptsFilters :: Word64 -> Bool acceptsFilters srv = srv .&. (1 `shiftL` 2) /= 0 diff --git a/src/Haskoin/Network/Common.hs b/src/Haskoin/Network/Common.hs index f1d942bc..04d8e1de 100644 --- a/src/Haskoin/Network/Common.hs +++ b/src/Haskoin/Network/Common.hs @@ -2,16 +2,11 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{- | -Module : Haskoin.Network.Common -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Common functions and data types related to peer-to-peer network. --} +-- | +-- Stability : experimental +-- Portability : POSIX +-- +-- Common functions and data types related to peer-to-peer network. module Haskoin.Network.Common ( -- * Network Data Types Addr (..), @@ -65,121 +60,137 @@ import Haskoin.Crypto.Hash import Network.Socket (SockAddr (..)) import Text.Read as R + -- | Network address with a timestamp. type NetworkAddressTime = (Word32, NetworkAddress) -{- | Provides information about known nodes in the bitcoin network. An 'Addr' - type is sent inside a 'Message' as a response to a 'GetAddr' message. --} + +-- | Provides information about known nodes in the bitcoin network. An 'Addr' +-- type is sent inside a 'Message' as a response to a 'GetAddr' message. newtype Addr = Addr { -- List of addresses of other nodes on the network with timestamps. addrList :: [NetworkAddressTime] } deriving (Eq, Show, Generic, NFData) + instance Serial Addr where deserialize = Addr <$> (repList =<< deserialize) where repList (VarInt c) = replicateM (fromIntegral c) action action = liftM2 (,) getWord32le deserialize + serialize (Addr xs) = do putVarInt $ length xs forM_ xs $ \(a, b) -> putWord32le a >> serialize b + instance Binary Addr where get = deserialize put = serialize + instance Serialize Addr where get = deserialize put = serialize -{- | Data type describing signed messages that can be sent between bitcoin - nodes to display important notifications to end users about the health of - the network. --} + +-- | Data type describing signed messages that can be sent between bitcoin +-- nodes to display important notifications to end users about the health of +-- the network. data Alert = Alert - { -- | Alert payload. - alertPayload :: !VarString - , -- | ECDSA signature of the payload - alertSignature :: !VarString + { alertPayload :: !VarString + -- ^ Alert payload. + , alertSignature :: !VarString + -- ^ ECDSA signature of the payload } deriving (Eq, Show, Read, Generic, NFData) + instance Serial Alert where deserialize = Alert <$> deserialize <*> deserialize serialize (Alert p s) = serialize p >> serialize s + instance Binary Alert where put = serialize get = deserialize + instance Serialize Alert where put = serialize get = deserialize -{- | The 'GetData' type is used to retrieve information on a specific object - ('Block' or 'Tx') identified by the objects hash. The payload of a 'GetData' - request is a list of 'InvVector' which represent all the hashes of objects - that a node wants. The response to a 'GetBlock' message will be either a - 'Block' or a 'Tx' message depending on the type of the object referenced by - the hash. Usually, 'GetData' messages are sent after a node receives an 'Inv' - message that contains unknown object hashes. --} + +-- | The 'GetData' type is used to retrieve information on a specific object +-- ('Block' or 'Tx') identified by the objects hash. The payload of a 'GetData' +-- request is a list of 'InvVector' which represent all the hashes of objects +-- that a node wants. The response to a 'GetBlock' message will be either a +-- 'Block' or a 'Tx' message depending on the type of the object referenced by +-- the hash. Usually, 'GetData' messages are sent after a node receives an 'Inv' +-- message that contains unknown object hashes. newtype GetData = GetData - { -- | list of object hashes - getDataList :: [InvVector] + { getDataList :: [InvVector] + -- ^ list of object hashes } deriving (Eq, Show, Generic, NFData) + instance Serial GetData where deserialize = GetData <$> (repList =<< deserialize) where repList (VarInt c) = replicateM (fromIntegral c) deserialize + serialize (GetData xs) = do putVarInt $ length xs forM_ xs serialize + instance Binary GetData where get = deserialize put = serialize + instance Serialize GetData where get = deserialize put = serialize -{- | 'Inv' messages are used by nodes to advertise their knowledge of new - objects by publishing a list of hashes to a peer. 'Inv' messages can be sent - unsolicited or in response to a 'GetBlocks' message. --} + +-- | 'Inv' messages are used by nodes to advertise their knowledge of new +-- objects by publishing a list of hashes to a peer. 'Inv' messages can be sent +-- unsolicited or in response to a 'GetBlocks' message. newtype Inv = Inv - { -- | inventory - invList :: [InvVector] + { invList :: [InvVector] + -- ^ inventory } deriving (Eq, Show, Generic, NFData) + instance Serial Inv where deserialize = Inv <$> (repList =<< deserialize) where repList (VarInt c) = replicateM (fromIntegral c) deserialize + serialize (Inv xs) = do putVarInt $ length xs forM_ xs serialize + instance Binary Inv where get = deserialize put = serialize + instance Serialize Inv where get = deserialize put = serialize -{- | Data type identifying the type of an inventory vector. SegWit types are - only used in 'GetData' messages, not 'Inv'. --} + +-- | Data type identifying the type of an inventory vector. SegWit types are +-- only used in 'GetData' messages, not 'Inv'. data InvType = -- | error InvError @@ -199,6 +210,7 @@ data InvType InvType Word32 deriving (Eq, Show, Read, Generic, NFData) + instance Serial InvType where deserialize = go =<< getWord32le where @@ -225,75 +237,87 @@ instance Serial InvType where InvWitnessMerkleBlock -> 1 `shiftL` 30 + 3 InvType w -> w + instance Binary InvType where get = deserialize put = serialize + instance Serialize InvType where get = deserialize put = serialize -{- | Invectory vectors represent hashes identifying objects such as a 'Block' or - a 'Tx'. They notify other peers about new data or data they have otherwise - requested. --} + +-- | Invectory vectors represent hashes identifying objects such as a 'Block' or +-- a 'Tx'. They notify other peers about new data or data they have otherwise +-- requested. data InvVector = InvVector - { -- | type of object - invType :: !InvType - , -- | 256-bit hash of object - invHash :: !Hash256 + { invType :: !InvType + -- ^ type of object + , invHash :: !Hash256 + -- ^ 256-bit hash of object } deriving (Eq, Show, Generic, NFData) + instance Serial InvVector where deserialize = InvVector <$> deserialize <*> deserialize serialize (InvVector t h) = serialize t >> serialize h + instance Binary InvVector where get = deserialize put = serialize + instance Serialize InvVector where get = deserialize put = serialize + newtype HostAddress = HostAddress ByteString deriving (Eq, Show, Ord, Generic, NFData) + instance Serial HostAddress where serialize (HostAddress bs) = putByteString bs deserialize = HostAddress <$> getByteString 18 + instance Binary HostAddress where get = deserialize put = serialize + instance Serialize HostAddress where get = deserialize put = serialize -{- | Data type describing a bitcoin network address. Addresses are stored in - IPv6 format. IPv4 addresses are mapped to IPv6 using IPv4 mapped IPv6 - addresses: . --} + +-- | Data type describing a bitcoin network address. Addresses are stored in +-- IPv6 format. IPv4 addresses are mapped to IPv6 using IPv4 mapped IPv6 +-- addresses: . data NetworkAddress = NetworkAddress - { -- | bitmask of services available for this address - naServices :: !Word64 - , -- | address and port information - naAddress :: !HostAddress + { naServices :: !Word64 + -- ^ bitmask of services available for this address + , naAddress :: !HostAddress + -- ^ address and port information } deriving (Eq, Show, Generic, NFData) + hostToSockAddr :: HostAddress -> SockAddr hostToSockAddr (HostAddress bs) = case runGetS getSockAddr bs of Left e -> error e Right x -> x + sockToHostAddress :: SockAddr -> HostAddress sockToHostAddress = HostAddress . runPutS . putSockAddr + putSockAddr :: MonadPut m => SockAddr -> m () putSockAddr (SockAddrInet6 p _ (a, b, c, d) _) = do putWord32be a @@ -309,6 +333,7 @@ putSockAddr (SockAddrInet p a) = do putWord16be (fromIntegral p) putSockAddr _ = error "Invalid address type" + getSockAddr :: MonadGet m => m SockAddr getSockAddr = do a <- getWord32be @@ -324,100 +349,116 @@ getSockAddr = do p <- getWord16be return $ SockAddrInet6 (fromIntegral p) 0 (a, b, c, d) 0 + instance Serial NetworkAddress where deserialize = NetworkAddress <$> getWord64le <*> deserialize serialize (NetworkAddress s a) = putWord64le s >> serialize a + instance Binary NetworkAddress where get = deserialize put = serialize + instance Serialize NetworkAddress where get = deserialize put = serialize -{- | A 'NotFound' message is returned as a response to a 'GetData' message - whe one of the requested objects could not be retrieved. This could happen, - for example, if a tranasaction was requested and was not available in the - memory pool of the receiving node. --} + +-- | A 'NotFound' message is returned as a response to a 'GetData' message +-- whe one of the requested objects could not be retrieved. This could happen, +-- for example, if a tranasaction was requested and was not available in the +-- memory pool of the receiving node. newtype NotFound = NotFound - { -- | Inventory vectors related to this request - notFoundList :: [InvVector] + { notFoundList :: [InvVector] + -- ^ Inventory vectors related to this request } deriving (Eq, Show, Generic, NFData) + instance Serial NotFound where deserialize = NotFound <$> (repList =<< deserialize) where repList (VarInt c) = replicateM (fromIntegral c) deserialize + serialize (NotFound xs) = do putVarInt $ length xs forM_ xs serialize + instance Binary NotFound where get = deserialize put = serialize + instance Serialize NotFound where get = deserialize put = serialize -{- | A 'Ping' message is sent to bitcoin peers to check if a connection is still - open. --} + +-- | A 'Ping' message is sent to bitcoin peers to check if a connection is still +-- open. newtype Ping = Ping - { -- | A random nonce used to identify the recipient of the ping - -- request once a Pong response is received. - pingNonce :: Word64 + { pingNonce :: Word64 + -- ^ A random nonce used to identify the recipient of the ping + -- request once a Pong response is received. } deriving (Eq, Show, Read, Generic, NFData) + -- | A Pong message is sent as a response to a ping message. newtype Pong = Pong - { -- | nonce from corresponding 'Ping' - pongNonce :: Word64 + { pongNonce :: Word64 + -- ^ nonce from corresponding 'Ping' } deriving (Eq, Show, Read, Generic, NFData) + instance Serial Ping where deserialize = Ping <$> getWord64le serialize (Ping n) = putWord64le n + instance Serial Pong where deserialize = Pong <$> getWord64le serialize (Pong n) = putWord64le n + instance Binary Ping where get = deserialize put = serialize + instance Binary Pong where get = deserialize put = serialize + instance Serialize Ping where get = deserialize put = serialize + instance Serialize Pong where get = deserialize put = serialize + -- | The 'Reject' message is sent when messages are rejected by a peer. data Reject = Reject - { -- | type of message rejected - rejectMessage :: !MessageCommand - , -- | rejection code - rejectCode :: !RejectCode - , -- | text reason for rejection - rejectReason :: !VarString - , -- | extra data such as block or tx hash - rejectData :: !ByteString + { rejectMessage :: !MessageCommand + -- ^ type of message rejected + , rejectCode :: !RejectCode + -- ^ rejection code + , rejectReason :: !VarString + -- ^ text reason for rejection + , rejectData :: !ByteString + -- ^ extra data such as block or tx hash } deriving (Eq, Show, Read, Generic, NFData) + -- | Rejection code associated to the 'Reject' message. data RejectCode = RejectMalformed @@ -430,6 +471,7 @@ data RejectCode | RejectCheckpoint deriving (Eq, Show, Read, Generic, NFData) + instance Serial RejectCode where deserialize = getWord8 >>= \code -> case code of @@ -448,6 +490,7 @@ instance Serial RejectCode where , show code ] + serialize code = putWord8 $ case code of RejectMalformed -> 0x01 RejectInvalid -> 0x10 @@ -458,19 +501,23 @@ instance Serial RejectCode where RejectInsufficientFee -> 0x42 RejectCheckpoint -> 0x43 + instance Binary RejectCode where put = serialize get = deserialize + instance Serialize RejectCode where put = serialize get = deserialize + -- | Convenience function to build a 'Reject' message. reject :: MessageCommand -> RejectCode -> ByteString -> Reject reject cmd code reason = Reject cmd code (VarString reason) B.empty + instance Serial Reject where deserialize = deserialize >>= \(VarString bs) -> @@ -490,20 +537,23 @@ instance Serial Reject where serialize reason unless (B.null dat) $ putByteString dat + instance Binary Reject where put = serialize get = deserialize + instance Serialize Reject where put = serialize get = deserialize -{- | Data type representing a variable-length integer. The 'VarInt' type - usually precedes an array or a string that can vary in length. --} + +-- | Data type representing a variable-length integer. The 'VarInt' type +-- usually precedes an array or a string that can vary in length. newtype VarInt = VarInt {getVarInt :: Word64} deriving (Eq, Show, Read, Generic, NFData) + instance Serial VarInt where deserialize = VarInt <$> (getWord8 >>= go) where @@ -512,6 +562,7 @@ instance Serial VarInt where go 0xfd = fromIntegral <$> getWord16le go x = return $ fromIntegral x + serialize (VarInt x) | x < 0xfd = putWord8 $ fromIntegral x @@ -525,67 +576,77 @@ instance Serial VarInt where putWord8 0xff putWord64le x + instance Binary VarInt where put = serialize get = deserialize + instance Serialize VarInt where put = serialize get = deserialize + putVarInt :: (MonadPut m, Integral a) => a -> m () putVarInt = serialize . VarInt . fromIntegral + -- | Data type for serialization of variable-length strings. newtype VarString = VarString {getVarString :: ByteString} deriving (Eq, Show, Read, Generic, NFData) + instance Serial VarString where deserialize = VarString <$> (readBS =<< deserialize) where readBS (VarInt len) = getByteString (fromIntegral len) + serialize (VarString bs) = do putVarInt $ B.length bs putByteString bs + instance Binary VarString where put = serialize get = deserialize + instance Serialize VarString where put = serialize get = deserialize -{- | When a bitcoin node creates an outgoing connection to another node, - the first message it will send is a 'Version' message. The other node - will similarly respond with it's own 'Version' message. --} + +-- | When a bitcoin node creates an outgoing connection to another node, +-- the first message it will send is a 'Version' message. The other node +-- will similarly respond with it's own 'Version' message. data Version = Version - { -- | protocol version - version :: !Word32 - , -- | features supported by this connection - services :: !Word64 - , -- | unix timestamp - timestamp :: !Word64 - , -- | network address of remote node - addrRecv :: !NetworkAddress - , -- | network address of sending node - addrSend :: !NetworkAddress - , -- | random nonce to detect connection to self - verNonce :: !Word64 - , -- | user agent string - userAgent :: !VarString - , -- | height of the last block in sending node - startHeight :: !Word32 - , -- | relay transactions flag (BIP-37) - relay :: !Bool + { version :: !Word32 + -- ^ protocol version + , services :: !Word64 + -- ^ features supported by this connection + , timestamp :: !Word64 + -- ^ unix timestamp + , addrRecv :: !NetworkAddress + -- ^ network address of remote node + , addrSend :: !NetworkAddress + -- ^ network address of sending node + , verNonce :: !Word64 + -- ^ random nonce to detect connection to self + , userAgent :: !VarString + -- ^ user agent string + , startHeight :: !Word32 + -- ^ height of the last block in sending node + , relay :: !Bool + -- ^ relay transactions flag (BIP-37) } deriving (Eq, Show, Generic, NFData) + instance Serial Version where deserialize = - Version <$> getWord32le + Version + <$> getWord32le <*> getWord64le <*> getWord64le <*> deserialize @@ -598,6 +659,7 @@ instance Serial Version where go True = return True go False = getBool + serialize (Version v s t ar as n ua sh r) = do putWord32le v putWord64le s @@ -609,14 +671,17 @@ instance Serial Version where putWord32le sh putBool r + instance Binary Version where put = serialize get = deserialize + instance Serialize Version where put = serialize get = deserialize + -- | 0x00 is 'False', anything else is 'True'. getBool :: MonadGet m => m Bool getBool = go =<< getWord8 @@ -624,16 +689,17 @@ getBool = go =<< getWord8 go 0 = return False go _ = return True + putBool :: MonadPut m => Bool -> m () putBool True = putWord8 1 putBool False = putWord8 0 -{- | A 'MessageCommand' is included in a 'MessageHeader' in order to identify - the type of message present in the payload. This allows the message - de-serialization code to know how to decode a particular message payload. - Every valid 'Message' constructor has a corresponding 'MessageCommand' - constructor. --} + +-- | A 'MessageCommand' is included in a 'MessageHeader' in order to identify +-- the type of message present in the payload. This allows the message +-- de-serialization code to know how to decode a particular message payload. +-- Every valid 'Message' constructor has a corresponding 'MessageCommand' +-- constructor. data MessageCommand = MCVersion | MCVerAck @@ -660,14 +726,17 @@ data MessageCommand | MCOther ByteString deriving (Eq, Generic, NFData) + instance Show MessageCommand where showsPrec _ = shows . commandToString + instance Read MessageCommand where readPrec = do String str <- lexP return (stringToCommand (cs str)) + instance Serial MessageCommand where deserialize = go <$> getByteString 12 where @@ -676,17 +745,21 @@ instance Serial MessageCommand where in stringToCommand str serialize mc = putByteString $ packCommand $ commandToString mc + instance Binary MessageCommand where put = serialize get = deserialize + instance Serialize MessageCommand where put = serialize get = deserialize + instance IsString MessageCommand where fromString str = stringToCommand (cs str) + -- | Read a 'MessageCommand' from its string representation. stringToCommand :: ByteString -> MessageCommand stringToCommand str = case str of @@ -714,6 +787,7 @@ stringToCommand str = case str of "sendheaders" -> MCSendHeaders _ -> MCOther str + -- | Convert a 'MessageCommand' to its string representation. commandToString :: MessageCommand -> ByteString commandToString mc = case mc of @@ -741,36 +815,44 @@ commandToString mc = case mc of MCSendHeaders -> "sendheaders" MCOther c -> c + -- | Pack a string 'MessageCommand' so that it is exactly 12-bytes long. packCommand :: ByteString -> ByteString packCommand s = B.take 12 $ s `mappend` C.replicate 12 '\NUL' + -- | Undo packing done by 'packCommand'. unpackCommand :: ByteString -> ByteString unpackCommand = B.takeWhile (/= 0) + -- | Node offers no services. nodeNone :: Word64 nodeNone = 0 + -- | Services indicate node is a full node that can serve full blocks. nodeNetwork :: Word64 nodeNetwork = 1 + -- | Services indicate node allows to request 'UTXO' set. nodeGetUTXO :: Word64 nodeGetUTXO = 1 `shiftL` 1 + -- | Services indicate node accepts bloom filters. nodeBloom :: Word64 nodeBloom = 1 `shiftL` 2 + -- | Services indicate SegWit-capable node. nodeWitness :: Word64 nodeWitness = 1 `shiftL` 3 + -- | Services indicate Xtreme Thinblocks compatibility. nodeXThin :: Word64 nodeXThin = 1 `shiftL` 4 diff --git a/src/Haskoin/Network/Message.hs b/src/Haskoin/Network/Message.hs index ba26b84c..dfbc525f 100644 --- a/src/Haskoin/Network/Message.hs +++ b/src/Haskoin/Network/Message.hs @@ -1,16 +1,11 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} -{- | -Module : Haskoin.Network.Message -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Peer-to-peer network message serialization. --} +-- | +-- Stability : experimental +-- Portability : POSIX +-- +-- Peer-to-peer network message serialization. module Haskoin.Network.Message ( -- * Network Message Message (..), @@ -39,21 +34,22 @@ import Haskoin.Network.Bloom import Haskoin.Network.Common 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 + { headMagic :: !Word32 + -- ^ magic bytes identify network + , headCmd :: !MessageCommand + -- ^ message type + , headPayloadSize :: !Word32 + -- ^ length of payload + , headChecksum :: !CheckSum32 + -- ^ checksum of payload } deriving (Eq, Show, Generic, NFData) + instance Serial MessageHeader where deserialize = MessageHeader @@ -62,27 +58,30 @@ instance Serial MessageHeader where <*> getWord32le <*> deserialize + serialize (MessageHeader m c l chk) = do putWord32be m serialize c putWord32le l serialize chk + instance Binary MessageHeader where put = serialize get = deserialize + instance Serialize MessageHeader where 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 @@ -109,6 +108,7 @@ data Message | MOther !ByteString !ByteString deriving (Eq, Show, Generic, NFData) + -- | Get 'MessageCommand' assocated with a message. msgType :: Message -> MessageCommand msgType (MVersion _) = MCVersion @@ -135,6 +135,7 @@ msgType MSendHeaders = MCSendHeaders msgType MGetAddr = MCGetAddr msgType (MOther c _) = MCOther c + -- | Deserializer for network messages. getMessage :: MonadGet m => Network -> m Message getMessage net = do @@ -170,7 +171,8 @@ getMessage net = do MCOther c -> MOther c <$> getByteString (fromIntegral len) _ -> fail $ - "get: command " ++ show cmd + "get: command " + ++ show cmd ++ " should not carry a payload" either fail return (runGetS f bs) else case cmd of @@ -182,9 +184,11 @@ getMessage net = do MCOther c -> return (MOther c BS.empty) _ -> fail $ - "get: command " ++ show cmd + "get: command " + ++ show cmd ++ " is expected to carry a payload" + -- | Serializer for network messages. putMessage :: MonadPut m => Network -> Message -> m () putMessage net msg = do diff --git a/src/Haskoin/Script.hs b/src/Haskoin/Script.hs index ebda3302..f2617d4f 100644 --- a/src/Haskoin/Script.hs +++ b/src/Haskoin/Script.hs @@ -1,15 +1,10 @@ -{- | -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. --} +-- | +-- 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, @@ -19,3 +14,4 @@ module Haskoin.Script ( import Haskoin.Script.Common as Common import Haskoin.Script.SigHash as SigHash import Haskoin.Script.Standard as Standard + diff --git a/src/Haskoin/Script/Common.hs b/src/Haskoin/Script/Common.hs index 9e3b0cb5..5b6b44bd 100644 --- a/src/Haskoin/Script/Common.hs +++ b/src/Haskoin/Script/Common.hs @@ -2,16 +2,11 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{- | -Module : Haskoin.Script.Common -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Common script-related functions and data types. --} +-- | +-- Stability : experimental +-- Portability : POSIX +-- +-- Common script-related functions and data types. module Haskoin.Script.Common ( -- * Scripts ScriptOp (..), @@ -37,22 +32,23 @@ import Data.Serialize (Serialize (..)) import Data.Word (Word8) import GHC.Generics (Generic) -{- | Data type representing a transaction script. Scripts are defined as lists - of script operators 'ScriptOp'. Scripts are used to: - * Define the spending conditions in the output of a transaction. - * Provide signatures in the input of a transaction (except SegWit). - - SigWit only: the segregated witness data structure, and not the input script, - contains signatures and redeem script for pay-to-witness-script and - pay-to-witness-public-key-hash transactions. --} +-- | Data type representing a transaction script. Scripts are defined as lists +-- of script operators 'ScriptOp'. Scripts are used to: +-- +-- * Define the spending conditions in the output of a transaction. +-- * Provide signatures in the input of a transaction (except SegWit). +-- +-- SigWit only: the segregated witness data structure, and not the input script, +-- contains signatures and redeem script for pay-to-witness-script and +-- pay-to-witness-public-key-hash transactions. newtype Script = Script - { -- | script operators defining this script - scriptOps :: [ScriptOp] + { scriptOps :: [ScriptOp] + -- ^ script operators defining this script } deriving (Eq, Show, Read, Generic, Hashable, NFData) + instance Serial Script where deserialize = Script <$> getScriptOps @@ -63,16 +59,20 @@ instance Serial Script where then return [] else (:) <$> deserialize <*> getScriptOps + serialize (Script ops) = forM_ ops serialize + instance Binary Script where put = serialize get = deserialize + instance Serialize Script where put = serialize get = deserialize + -- | Data type representing the type of an OP_PUSHDATA opcode. data PushDataType = -- | next opcode bytes is data to be pushed @@ -85,6 +85,7 @@ data PushDataType OPDATA4 deriving (Show, Read, Eq, Generic, Hashable, NFData) + -- | Data type representing an operator allowed inside a 'Script'. data ScriptOp = -- Pushing Data @@ -206,17 +207,13 @@ data ScriptOp | OP_NOP8 | OP_NOP9 | OP_NOP10 - | -- Bitcoin Cash Nov 2018 hard fork - OP_CHECKDATASIG - | OP_CHECKDATASIGVERIFY - | -- Bitcoin Cash May 2020 hard fork - OP_REVERSEBYTES | -- Other OP_PUBKEYHASH | OP_PUBKEY | OP_INVALIDOPCODE !Word8 deriving (Show, Read, Eq, Generic, Hashable, NFData) + instance Serial ScriptOp where deserialize = go . fromIntegral =<< getWord8 where @@ -351,16 +348,12 @@ instance Serial ScriptOp where | op == 0xb7 = return OP_NOP8 | op == 0xb8 = return OP_NOP9 | op == 0xb9 = return OP_NOP10 - -- Bitcoin Cash Nov 2018 hard fork - | op == 0xba = return OP_CHECKDATASIG - | op == 0xbb = return OP_CHECKDATASIGVERIFY - -- Bitcoin Cash May 2020 hard fork - | op == 0xbc = return OP_REVERSEBYTES -- Constants | op == 0xfd = return OP_PUBKEYHASH | op == 0xfe = return OP_PUBKEY | otherwise = return $ OP_INVALIDOPCODE op + serialize op = case op of (OP_PUSHDATA payload optype) -> do let len = B.length payload @@ -507,20 +500,18 @@ instance Serial ScriptOp where OP_NOP8 -> putWord8 0xb7 OP_NOP9 -> putWord8 0xb8 OP_NOP10 -> putWord8 0xb9 - -- Bitcoin Cash Nov 2018 hard fork - OP_CHECKDATASIG -> putWord8 0xba - OP_CHECKDATASIGVERIFY -> putWord8 0xbb - -- Bitcoin Cash May 2020 hard fork - OP_REVERSEBYTES -> putWord8 0xbc + instance Binary ScriptOp where put = serialize get = deserialize + instance Serialize ScriptOp where put = serialize get = deserialize + -- | Check whether opcode is only data. isPushOp :: ScriptOp -> Bool isPushOp op = case op of @@ -545,6 +536,7 @@ isPushOp op = case op of OP_16 -> True _ -> False + -- | Optimally encode data using one of the 4 types of data pushing opcodes. opPushData :: ByteString -> ScriptOp opPushData bs @@ -556,6 +548,7 @@ opPushData bs where len = B.length bs + -- | Transforms integers @[1 .. 16]@ to 'ScriptOp' @[OP_1 .. OP_16]@. intToScriptOp :: Int -> ScriptOp intToScriptOp i @@ -570,9 +563,9 @@ intToScriptOp i $ i + 0x50 err = error $ "intToScriptOp: Invalid integer " ++ show i -{- | Decode 'ScriptOp' @[OP_1 .. OP_16]@ to integers @[1 .. 16]@. This functions - fails for other values of 'ScriptOp' --} + +-- | Decode 'ScriptOp' @[OP_1 .. OP_16]@ to integers @[1 .. 16]@. This functions +-- fails for other values of 'ScriptOp' scriptOpToInt :: ScriptOp -> Either String Int scriptOpToInt s | res `elem` [1 .. 16] = return res diff --git a/src/Haskoin/Script/SigHash.hs b/src/Haskoin/Script/SigHash.hs index 867a5a92..1dbd5e7d 100644 --- a/src/Haskoin/Script/SigHash.hs +++ b/src/Haskoin/Script/SigHash.hs @@ -2,16 +2,11 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -{- | -Module : Haskoin.Script.SigHash -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Transaction signatures and related functions. --} +-- | +-- Stability : experimental +-- Portability : POSIX +-- +-- Transaction signatures and related functions. module Haskoin.Script.SigHash ( -- * Script Signatures SigHash (..), @@ -20,18 +15,13 @@ module Haskoin.Script.SigHash ( sigHashNone, sigHashSingle, hasAnyoneCanPayFlag, - hasForkIdFlag, setAnyoneCanPayFlag, - setForkIdFlag, isSigHashAll, isSigHashNone, isSigHashSingle, isSigHashUnknown, - sigHashAddForkId, - sigHashGetForkId, - sigHashAddNetworkId, txSigHash, - txSigHashForkId, + txSigHashSegwitV0, TxSignature (..), encodeTxSig, decodeTxSig, @@ -58,6 +48,7 @@ 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 @@ -66,41 +57,40 @@ data SigHashFlag 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" -{- | 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 @@ -118,80 +108,68 @@ newtype SigHash , NFData ) + instance J.FromJSON SigHash where parseJSON = J.withScientific "sighash" $ maybe mzero (return . SigHash) . toBoundedInteger + instance J.ToJSON SigHash where toJSON = J.Number . fromIntegral toEncoding (SigHash n) = J.toEncoding n + -- | SIGHASH_NONE as a byte. sigHashNone :: SigHash sigHashNone = fromIntegral $ fromEnum SIGHASH_NONE + -- | SIGHASH_ALL as a byte. sigHashAll :: SigHash sigHashAll = fromIntegral $ fromEnum SIGHASH_ALL + -- | SIGHASH_SINGLE as a byte. sigHashSingle :: SigHash sigHashSingle = fromIntegral $ fromEnum SIGHASH_SINGLE --- | SIGHASH_FORKID as a byte. -sigHashForkId :: SigHash -sigHashForkId = fromIntegral $ fromEnum SIGHASH_FORKID -- | SIGHASH_ANYONECANPAY as a byte. sigHashAnyoneCanPay :: SigHash sigHashAnyoneCanPay = fromIntegral $ fromEnum SIGHASH_ANYONECANPAY --- | Set SIGHASH_FORKID flag. -setForkIdFlag :: SigHash -> SigHash -setForkIdFlag = (.|. sigHashForkId) -- | Set SIGHASH_ANYONECANPAY flag. setAnyoneCanPayFlag :: SigHash -> SigHash setAnyoneCanPayFlag = (.|. 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) + -- | Returns 'True' if the 'SigHash' has the value 'SIGHASH_ALL'. isSigHashAll :: SigHash -> Bool isSigHashAll = (== sigHashAll) . (.&. 0x1f) + -- | Returns 'True' if the 'SigHash' has the value 'SIGHASH_NONE'. isSigHashNone :: SigHash -> Bool isSigHashNone = (== sigHashNone) . (.&. 0x1f) + -- | Returns 'True' if the 'SigHash' has the value 'SIGHASH_SINGLE'. isSigHashSingle :: SigHash -> Bool isSigHashSingle = (== sigHashSingle) . (.&. 0x1f) + -- | Returns 'True' if the 'SigHash' has the value 'SIGHASH_UNKNOWN'. isSigHashUnknown :: SigHash -> Bool isSigHashUnknown = (`notElem` [sigHashAll, sigHashNone, sigHashSingle]) . (.&. 0x1f) --- | Add a fork id to a 'SigHash'. -sigHashAddForkId :: SigHash -> Word32 -> SigHash -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)) - --- | Get fork id from 'SigHash'. -sigHashGetForkId :: SigHash -> Word32 -sigHashGetForkId (SigHash n) = fromIntegral $ n `shiftR` 8 -- | Computes the hash that will be used for signing a transaction. txSigHash :: @@ -208,24 +186,22 @@ txSigHash :: 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 +txSigHash net tx out v i sh = 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 where fout = Script $ filter (/= OP_CODESEPARATOR) $ scriptOps out one = "0100000000000000000000000000000000000000000000000000000000000000" + -- | Build transaction inputs for computing sighashes. buildInputs :: [TxIn] -> Script -> Int -> SigHash -> [TxIn] buildInputs txins out i sh @@ -242,6 +218,7 @@ buildInputs txins out i sh then ti else ti{txInSequence = 0} + -- | Build transaction outputs for computing sighashes. buildOutputs :: [TxOut] -> Int -> SigHash -> Maybe [TxOut] buildOutputs txos i sh @@ -252,10 +229,10 @@ buildOutputs txos i sh where buffer = replicate i $ TxOut maxBound BS.empty -{- | Compute the hash that will be used for signing a transaction. This - function is used when the 'SIGHASH_FORKID' flag is set. --} -txSigHashForkId :: + +-- | Compute the hash that will be used for signing a transaction. This +-- function is used when the 'SIGHASH_FORKID' flag is set. +txSigHashSegwitV0 :: Network -> -- | transaction to sign Tx -> @@ -269,7 +246,7 @@ txSigHashForkId :: SigHash -> -- | hash to be signed Hash256 -txSigHashForkId net tx out v i sh = +txSigHashSegwitV0 _ tx out v i sh = doubleSHA256 . runPutS $ do putWord32le $ txVersion tx serialize hashPrevouts @@ -280,7 +257,7 @@ txSigHashForkId net tx out v i sh = putWord32le $ txInSequence $ txIn tx !! i serialize hashOutputs putWord32le $ txLockTime tx - putWord32le $ fromIntegral $ sigHashAddNetworkId net sh + putWord32le $ fromIntegral sh where hashPrevouts | not $ hasAnyoneCanPayFlag sh = @@ -305,10 +282,10 @@ txSigHashForkId net tx out v i sh = 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 @@ -317,14 +294,17 @@ data TxSignature | TxSignatureEmpty deriving (Eq, Show, Generic) + instance NFData TxSignature + -- | 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) + -- | Deserialize a 'TxSignature'. decodeTxSig :: Network -> BS.ByteString -> Either String TxSignature decodeTxSig _ bs | BS.null bs = Left "Empty signature candidate" @@ -334,7 +314,5 @@ decodeTxSig net bs = 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" diff --git a/src/Haskoin/Script/Standard.hs b/src/Haskoin/Script/Standard.hs index cf093ad2..30d47eef 100644 --- a/src/Haskoin/Script/Standard.hs +++ b/src/Haskoin/Script/Standard.hs @@ -2,17 +2,12 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{- | -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. --} +-- | +-- 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 (..), @@ -69,10 +64,10 @@ 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} @@ -98,6 +93,7 @@ data ScriptOutput DataCarrier {getOutputData :: !ByteString} deriving (Eq, Show, Read, Generic, Hashable, NFData) + instance A.FromJSON ScriptOutput where parseJSON = A.withText "scriptoutput" $ \t -> @@ -105,53 +101,62 @@ instance A.FromJSON ScriptOutput where maybeToEither "scriptoutput not hex" (decodeHex t) >>= decodeOutputBS + instance A.ToJSON ScriptOutput where toJSON = A.String . encodeHex . encodeOutputBS toEncoding = A.text . encodeHex . encodeOutputBS + -- | Is script a pay-to-public-key output? isPayPK :: ScriptOutput -> Bool isPayPK (PayPK _) = True isPayPK _ = False + -- | Is script a pay-to-pub-key-hash output? isPayPKHash :: ScriptOutput -> Bool isPayPKHash (PayPKHash _) = True isPayPKHash _ = False + -- | Is script a pay-to-multi-sig output? isPayMulSig :: ScriptOutput -> Bool isPayMulSig (PayMulSig _ _) = True isPayMulSig _ = False + -- | Is script a pay-to-script-hash output? isPayScriptHash :: ScriptOutput -> Bool isPayScriptHash (PayScriptHash _) = True isPayScriptHash _ = False + -- | Is script a pay-to-witness-pub-key-hash output? isPayWitnessPKHash :: ScriptOutput -> Bool isPayWitnessPKHash (PayWitnessPKHash _) = True isPayWitnessPKHash _ = False + -- | Is script a pay-to-witness-script-hash output? isPayWitnessScriptHash :: ScriptOutput -> Bool isPayWitnessScriptHash (PayWitnessScriptHash _) = True isPayWitnessScriptHash _ = False + -- | Is script paying to a different type of witness address? isPayWitness :: ScriptOutput -> Bool isPayWitness (PayWitness _ _) = True isPayWitness _ = False + -- | Is script a data carrier output? 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. --} + +-- | 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 @@ -179,6 +184,7 @@ decodeOutput s = case scriptOps s of -- Pay to MultiSig Keys _ -> matchPayMulSig s + witnessVersionOp :: Word8 -> Maybe ScriptOp witnessVersionOp 0 = Just OP_0 witnessVersionOp 1 = Just OP_1 @@ -199,6 +205,7 @@ witnessVersionOp 15 = Just OP_15 witnessVersionOp 16 = Just OP_16 witnessVersionOp _ = Nothing + opWitnessVersion :: ScriptOp -> Maybe Word8 opWitnessVersion OP_0 = Just 0 opWitnessVersion OP_1 = Just 1 @@ -219,10 +226,12 @@ 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 @@ -261,18 +270,22 @@ encodeOutput s = Script $ case s of -- Provably unspendable output (DataCarrier d) -> [OP_RETURN, opPushData d] + -- | Similar to 'encodeOutput' but encodes to a ByteString encodeOutputBS :: ScriptOutput -> ByteString encodeOutputBS = runPutS . serialize . encodeOutput + -- | Encode script as pay-to-script-hash script toP2SH :: Script -> ScriptOutput toP2SH = PayScriptHash . addressHash . runPutS . serialize + -- | Encode script as a pay-to-witness-script-hash script 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 @@ -287,79 +300,83 @@ matchPayMulSig (Script ops) = case splitAt (length ops - 2) ops of go [] = return [] 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. --} + +-- | 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" -{- | 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 + { getInputSig :: !TxSignature + -- ^ transaction signature } | SpendPKHash - { -- | embedded signature - getInputSig :: !TxSignature - , -- | public key - getInputKey :: !PubKeyI + { getInputSig :: !TxSignature + -- ^ embedded signature + , getInputKey :: !PubKeyI + -- ^ public key } | SpendMulSig - { -- | list of signatures - getInputMulSigKeys :: ![TxSignature] + { getInputMulSigKeys :: ![TxSignature] + -- ^ list of signatures } deriving (Eq, Show, 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 + -- | Returns true if the input script is spending a multisig output. isSpendMulSig :: ScriptInput -> Bool isSpendMulSig (RegularInput (SpendMulSig _)) = True isSpendMulSig _ = False + -- | Returns true if the input script is spending a pay-to-script-hash output. 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 + { getRegularInput :: !SimpleInput + -- ^ get wrapped simple input } | ScriptHashInput - { -- | get simple input associated with redeem script - getScriptHashInput :: !SimpleInput - , -- | redeem script - getScriptHashRedeem :: !RedeemScript + { getScriptHashInput :: !SimpleInput + -- ^ get simple input associated with redeem script + , getScriptHashRedeem :: !RedeemScript + -- ^ redeem script } deriving (Eq, Show, Generic, NFData) + -- | Heuristic to decode an input script into one of the standard types. decodeSimpleInput :: Network -> Script -> Either String SimpleInput decodeSimpleInput net (Script ops) = @@ -380,9 +397,9 @@ decodeSimpleInput net (Script ops) = 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. --} + +-- | 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 @@ -398,12 +415,13 @@ decodeInput net s@(Script ops) = _ -> Nothing errMsg = "decodeInput: Could not decode script input" -{- | Like 'decodeInput' but decodes directly from a serialized script - 'ByteString'. --} + +-- | Like 'decodeInput' but decodes directly from a serialized script +-- 'ByteString'. decodeInputBS :: Network -> ByteString -> Either String ScriptInput decodeInputBS net = decodeInput net <=< runGetS deserialize + -- | Encode a standard input into a script. encodeInput :: ScriptInput -> Script encodeInput s = case s of @@ -412,12 +430,13 @@ encodeInput s = case s of Script $ scriptOps (encodeSimpleInput i) ++ [opPushData $ encodeOutputBS o] -{- | Similar to 'encodeInput' but encodes directly to a serialized script - 'ByteString'. --} + +-- | Similar to 'encodeInput' but encodes directly to a serialized script +-- 'ByteString'. encodeInputBS :: ScriptInput -> ByteString encodeInputBS = runPutS . serialize . encodeInput + -- | Encode a standard 'SimpleInput' into opcodes as an input 'Script'. encodeSimpleInput :: SimpleInput -> Script encodeSimpleInput s = diff --git a/src/Haskoin/Transaction.hs b/src/Haskoin/Transaction.hs index 49ac96d7..5d4c4768 100644 --- a/src/Haskoin/Transaction.hs +++ b/src/Haskoin/Transaction.hs @@ -1,13 +1,8 @@ -{- | -Module : Haskoin.Transaction -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Transactions and related code. --} +-- | +-- Stability : experimental +-- Portability : POSIX +-- +-- Transactions and related code. module Haskoin.Transaction ( module Common, module Builder, @@ -23,3 +18,4 @@ import Haskoin.Transaction.Genesis as Genesis import Haskoin.Transaction.Partial as Partial import Haskoin.Transaction.Segwit as Segwit import Haskoin.Transaction.Taproot as Taproot + diff --git a/src/Haskoin/Transaction/Builder.hs b/src/Haskoin/Transaction/Builder.hs index b1eba445..bdf08b1f 100644 --- a/src/Haskoin/Transaction/Builder.hs +++ b/src/Haskoin/Transaction/Builder.hs @@ -2,17 +2,12 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{- | -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. --} +-- | +-- Stability : experimental +-- Portability : POSIX +-- +-- Code to simplify transaction creation, signing, fee calculation and coin +-- selection. module Haskoin.Transaction.Builder ( -- * Transaction Builder buildAddrTx, @@ -90,16 +85,16 @@ 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 -{- | 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 @@ -118,11 +113,11 @@ chooseCoins target fee nOut continue coins = 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 @@ -143,11 +138,11 @@ chooseCoinsSink target fee nOut continue 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 @@ -167,12 +162,12 @@ chooseMSCoins target fee ms nOut continue coins = 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 @@ -195,13 +190,13 @@ chooseMSCoinsSink target fee ms nOut continue 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 @@ -253,19 +248,21 @@ greedyAddSink target guessFee continue = 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) + -- | 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) -{- | 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 -> @@ -304,6 +301,7 @@ guessTxSize pki msi pkout msout = -- (1: script len) + (8: Word64) msout * 32 + -- | Size of a multisig P2SH input. guessMSSize :: (Int, Int) -> Int guessMSSize (m, n) = @@ -324,11 +322,11 @@ guessMSSize (m, n) = -- 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. --} +-- | 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 @@ -339,9 +337,9 @@ buildAddrTx net ops rcps = 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. --} + +-- | 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 @@ -349,20 +347,20 @@ buildTx ops rcpts = toIn op = TxIn op B.empty maxBound toOut (o, v) = TxOut v $ encodeOutputBS 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 @@ -377,9 +375,9 @@ signTx net tx si = S.signTx net 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 @@ -395,27 +393,29 @@ signNestedWitnessTx net tx si = S.signTx net tx $ nested <$> si -- 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) + -- | 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) -{- | 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 + {- 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 @@ -434,9 +434,9 @@ mergeTxs net txs os clearInput tx (_, i) = Tx (txVersion tx) (ins (txIn tx) i) (txOut tx) [] (txLockTime tx) -{- | 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] -> @@ -482,6 +482,7 @@ mergeTxInput net txs tx ((so, val), i) = do (pubKeyPoint p) f _ TxSignatureEmpty _ = False + {- Tx verification -} -- | Verify if a transaction is valid and all of its inputs are standard. @@ -493,6 +494,7 @@ verifyStdTx net tx xs = go (Just (so, val, _), i) = verifyStdInput net 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 @@ -560,6 +562,7 @@ verifyStdInput net tx i so0 val PayScriptHash h -> payToScriptAddress so' == p2shAddr h && verifySegwitInput so' x _ -> False + -- | Count the number of valid signatures for a multi-signature transaction. countMulSig :: Network -> @@ -575,6 +578,7 @@ countMulSig net tx out val i = where h = txSigHash net tx out val i + countMulSig' :: (SigHash -> Hash256) -> [PubKey] -> [TxSignature] -> Int countMulSig' _ [] _ = 0 countMulSig' _ _ [] = 0 diff --git a/src/Haskoin/Transaction/Builder/Sign.hs b/src/Haskoin/Transaction/Builder/Sign.hs index adc4f245..73ca1a09 100644 --- a/src/Haskoin/Transaction/Builder/Sign.hs +++ b/src/Haskoin/Transaction/Builder/Sign.hs @@ -3,16 +3,11 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{- | -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. --} +-- | +-- Stability : experimental +-- Portability : POSIX +-- +-- Types and logic for signing transactions. module Haskoin.Transaction.Builder.Sign ( SigInput (..), makeSignature, @@ -66,29 +61,30 @@ import Haskoin.Transaction.Common import Haskoin.Transaction.Segwit import Haskoin.Util (matchTemplate, updateIndex) -{- | 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) + { sigInputScript :: !ScriptOutput + -- ^ output script to spend + -- ^ output script value + , sigInputValue :: !Word64 + -- ^ output script value + -- ^ outpoint to spend + , sigInputOP :: !OutPoint + -- ^ outpoint to spend + -- ^ signature type + , sigInputSH :: !SigHash + -- ^ signature type + -- ^ redeem script + , sigInputRedeem :: !(Maybe RedeemScript) + -- ^ redeem script } deriving (Eq, Show, Read, Generic, Hashable, NFData) + instance ToJSON SigInput where toJSON (SigInput so val op sh rdm) = object $ @@ -106,19 +102,21 @@ instance ToJSON SigInput where <> "sighash" .= sh <> maybe mempty ("redeem" .=) rdm + instance FromJSON SigInput where parseJSON = withObject "SigInput" $ \o -> - SigInput <$> o .: "pkscript" + SigInput + <$> o .: "pkscript" <*> o .: "value" <*> o .: "outpoint" <*> o .: "sighash" <*> 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. --} + +-- | 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 @@ -138,9 +136,9 @@ signTx net otx sigis allKeys keys <- sigKeys so rdmM allKeys foldM (\t k -> signInput net 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 -> @@ -167,10 +165,10 @@ signInput net tx i (sigIn@(SigInput so val _ _ rdmM), nest) key = do | isSegwit so' = txIn tx | otherwise = updateIndex i txis (f si) -{- | Add the witness data of the transaction given segwit parameters for an input. - @since 0.11.0.0 --} +-- | 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 @@ -183,6 +181,7 @@ updatedWitnessData tx i so si defaultStack = replicate n $ toWitnessStack EmptyWitnessProgram n = length $ txIn tx + -- | Associate an input index to each value in a list findInputIndex :: -- | extract an outpoint @@ -199,9 +198,9 @@ findInputIndex getOutPoint as ti = 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 -> @@ -229,9 +228,9 @@ sigKeys so rdmM keys = keyByHash h = fmap fst . maybeToList . findKey h $ zipKeys findKey h = find $ (== h) . getAddrHash160 . pubKeyAddr . 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 @@ -271,11 +270,11 @@ buildInput net tx i so val rdmM sig pub = do verifyHashSig (makeSigHash net tx i so val sh rdmM) x (pubKeyPoint p) f TxSignatureEmpty _ = False -{- | Apply heuristics to extract the signatures for a particular input that are - embedded in the transaction. - @since 0.11.0.0 --} +-- | 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 where @@ -289,6 +288,7 @@ parseExistingSigs net tx so i = insSigs <> witSigs | null $ txWitness tx = [] | otherwise = rights $ decodeTxSig net <$> (txWitness tx !! 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 = @@ -296,10 +296,10 @@ makeSignature net tx i (SigInput so val _ sh rdmM) key = where m = makeSigHash net 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 -> @@ -315,5 +315,5 @@ makeSigHash net tx i so val sh rdmM = h net tx (encodeOutput so') val i sh PayWitnessPKHash h' -> PayPKHash h' _ -> fromMaybe so rdmM h - | isSegwit so = txSigHashForkId + | isSegwit so = txSigHashSegwitV0 | otherwise = txSigHash diff --git a/src/Haskoin/Transaction/Common.hs b/src/Haskoin/Transaction/Common.hs index 052bb5ab..13f9a04b 100644 --- a/src/Haskoin/Transaction/Common.hs +++ b/src/Haskoin/Transaction/Common.hs @@ -2,16 +2,11 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{- | -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. --} +-- | +-- Stability : experimental +-- Portability : POSIX +-- +-- Code related to transactions parsing and serialization. module Haskoin.Transaction.Common ( -- * Transactions Tx (..), @@ -64,36 +59,44 @@ import Haskoin.Network.Common import Haskoin.Util 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) + instance Serialize TxHash where put = serialize get = deserialize + instance Binary TxHash where put = serialize get = deserialize + instance Show TxHash where showsPrec _ = shows . txHashToHex + instance Read TxHash where 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 + instance FromJSON TxHash where parseJSON = withText "txid" $ maybe mzero return . hexToTxHash + instance ToJSON TxHash where toJSON = A.String . txHashToHex toEncoding h = @@ -102,6 +105,7 @@ instance ToJSON TxHash where <> hexBuilder (BL.reverse (runPutL (serialize h))) <> char7 '"' + -- | Transaction hash excluding signatures. nosigTxHash :: Tx -> TxHash nosigTxHash tx = @@ -112,10 +116,12 @@ nosigTxHash tx = where clearInput ti = ti{scriptInput = B.empty} + -- | Convert transaction hash to hex form, reversing bytes. txHashToHex :: TxHash -> Text txHashToHex (TxHash h) = encodeHex (B.reverse (runPutS (serialize h))) + -- | Convert transaction hash from hex, reversing bytes. hexToTxHash :: Text -> Maybe TxHash hexToTxHash hex = do @@ -123,40 +129,47 @@ hexToTxHash hex = do h <- either (const Nothing) Just (runGetS deserialize bs) return $ TxHash h + -- | Witness stack for SegWit transactions. type WitnessData = [WitnessStack] + -- | Witness stack for SegWit transactions. type WitnessStack = [WitnessStackItem] + -- | Witness stack item for SegWit transactions. 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 + { txVersion :: !Word32 + -- ^ transaction data format version + , txIn :: ![TxIn] + -- ^ list of transaction inputs + , txOut :: ![TxOut] + -- ^ list of transaction outputs + , txWitness :: !WitnessData + -- ^ witness data for the transaction + , txLockTime :: !Word32 + -- ^ earliest mining height or time } deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + -- | Compute transaction hash. txHash :: Tx -> TxHash txHash tx = TxHash . doubleSHA256 . runPutS $ serialize tx{txWitness = []} + instance IsString Tx where 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 @@ -164,14 +177,17 @@ instance Serial Tx where | null (txWitness tx) = putLegacyTx tx | otherwise = putWitnessTx tx + instance Binary Tx where put = serialize get = deserialize + instance Serialize Tx where put = serialize get = deserialize + putInOut :: MonadPut m => Tx -> m () putInOut tx = do putVarInt $ length (txIn tx) @@ -179,6 +195,7 @@ putInOut tx = do putVarInt $ length (txOut tx) forM_ (txOut tx) serialize + -- | Non-SegWit transaction serializer. putLegacyTx :: MonadPut m => Tx -> m () putLegacyTx tx = do @@ -186,6 +203,7 @@ putLegacyTx tx = do putInOut tx putWord32le (txLockTime tx) + -- | Witness transaciton serializer. putWitnessTx :: MonadPut m => Tx -> m () putWitnessTx tx = do @@ -196,6 +214,7 @@ putWitnessTx tx = do putWitnessData (txWitness tx) putWord32le (txLockTime tx) + isWitnessTx :: MonadGet m => m Bool isWitnessTx = lookAhead $ do _ <- getWord32le @@ -203,6 +222,7 @@ isWitnessTx = lookAhead $ do f <- getWord8 return (m == 0x00 && f == 0x01) + -- | Non-SegWit transaction deseralizer. parseLegacyTx :: MonadGet m => m Tx parseLegacyTx = do @@ -222,6 +242,7 @@ parseLegacyTx = do where replicateList (VarInt c) = replicateM (fromIntegral c) deserialize + -- | Witness transaction deserializer. parseWitnessTx :: MonadGet m => m Tx parseWitnessTx = do @@ -238,6 +259,7 @@ parseWitnessTx = do where replicateList (VarInt c) = replicateM (fromIntegral c) deserialize + -- | Witness data deserializer. Requires count of inputs. parseWitnessData :: MonadGet m => Int -> m WitnessData parseWitnessData n = replicateM n parseWitnessStack @@ -249,6 +271,7 @@ parseWitnessData n = replicateM n parseWitnessStack VarInt i <- deserialize getByteString $ fromIntegral i + -- | Witness data serializer. putWitnessData :: MonadPut m => WitnessData -> m () putWitnessData = mapM_ putWitnessStack @@ -260,9 +283,11 @@ putWitnessData = mapM_ putWitnessStack putVarInt $ B.length bs putByteString bs + instance FromJSON Tx where parseJSON = withObject "Tx" $ \o -> - Tx <$> o .: "version" + Tx + <$> o .: "version" <*> o .: "inputs" <*> o .: "outputs" <*> (mapM (mapM f) =<< o .: "witnessdata") @@ -270,6 +295,7 @@ instance FromJSON Tx where where f = maybe mzero return . decodeHex + instance ToJSON Tx where toJSON (Tx v i o w l) = object @@ -288,44 +314,52 @@ instance ToJSON Tx where <> "locktime" .= l ) + -- | 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 + { prevOutput :: !OutPoint + -- ^ output being spent + , scriptInput :: !ByteString + -- ^ signatures and redeem script + , txInSequence :: !Word32 + -- ^ lock-time using sequence numbers (BIP-68) } 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 + serialize (TxIn o s q) = do serialize o putVarInt $ B.length s putByteString s putWord32le q + instance Binary TxIn where get = deserialize put = serialize + instance Serialize TxIn where get = deserialize put = serialize + instance FromJSON TxIn where parseJSON = withObject "TxIn" $ \o -> - TxIn <$> o .: "prevoutput" + TxIn + <$> o .: "prevoutput" <*> (maybe mzero return . decodeHex =<< o .: "inputscript") <*> o .: "sequence" + instance ToJSON TxIn where toJSON (TxIn o s q) = object @@ -340,78 +374,93 @@ instance ToJSON TxIn where <> "sequence" .= q ) + -- | Data type representing a transaction output. data TxOut = TxOut - { -- | value of output is satoshi - outValue :: !Word64 - , -- | pubkey script - scriptOutput :: !ByteString + { outValue :: !Word64 + -- ^ value of output is satoshi + , scriptOutput :: !ByteString + -- ^ pubkey script } deriving (Eq, Show, Read, Ord, Generic, Hashable, NFData) + instance Serial TxOut where 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 + instance Binary TxOut where put = serialize get = deserialize + instance Serialize TxOut where put = serialize get = deserialize + instance FromJSON TxOut where parseJSON = withObject "TxOut" $ \o -> - TxOut <$> o .: "value" + TxOut + <$> o .: "value" <*> (maybe mzero return . decodeHex =<< o .: "outputscript") + instance ToJSON TxOut where toJSON (TxOut o s) = object ["value" .= o, "outputscript" .= encodeHex s] toEncoding (TxOut o s) = pairs ("value" .= o <> "outputscript" .= encodeHex 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 + { outPointHash :: !TxHash + -- ^ hash of previous transaction + , outPointIndex :: !Word32 + -- ^ position of output in previous transaction } 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 + instance Binary OutPoint where put = serialize get = deserialize + instance Serialize OutPoint where put = serialize get = deserialize + instance FromJSON OutPoint where 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) + -- | Outpoint used in coinbase transactions. nullOutPoint :: OutPoint nullOutPoint = diff --git a/src/Haskoin/Transaction/Genesis.hs b/src/Haskoin/Transaction/Genesis.hs index ce3d9554..89bf3c8d 100644 --- a/src/Haskoin/Transaction/Genesis.hs +++ b/src/Haskoin/Transaction/Genesis.hs @@ -1,15 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} -{- | -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 +--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 @@ -19,6 +18,7 @@ import Haskoin.Script.Standard import Haskoin.Transaction.Common import Haskoin.Util + -- | Transaction from Genesis block. genesisTx :: Tx genesisTx = diff --git a/src/Haskoin/Transaction/Partial.hs b/src/Haskoin/Transaction/Partial.hs index 0bf7b0ed..c230a6e3 100644 --- a/src/Haskoin/Transaction/Partial.hs +++ b/src/Haskoin/Transaction/Partial.hs @@ -4,16 +4,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{- | -Module : Haskoin.Transaction.Partial -Copyright : No rights reserved -License : MIT -Maintainer : matt@bitnomial.com -Stability : experimental -Portability : POSIX - -Code related to PSBT parsing and serialization. --} +-- | +-- Stability : experimental +-- Portability : POSIX +-- +-- Code related to PSBT parsing and serialization. module Haskoin.Transaction.Partial ( -- * Partially-Signed Transactions PartiallySignedTransaction (..), @@ -112,14 +107,14 @@ import Haskoin.Transaction.Common ( import Haskoin.Transaction.Segwit (isSegwit) import Haskoin.Util (eitherToMaybe) -{- | PSBT data type as specified in - [BIP-174](https://github.com/bitcoin/bips/blob/master/bip-0174.mediawiki). - This contains an unsigned transaction, inputs and outputs, and unspecified - extra data. There is one input per input in the unsigned transaction, and one - output per output in the unsigned transaction. The inputs and outputs in the - 'PartiallySignedTransaction' line up by index with the inputs and outputs in - the unsigned transaction. --} + +-- | PSBT data type as specified in +-- [BIP-174](https://github.com/bitcoin/bips/blob/master/bip-0174.mediawiki). +-- This contains an unsigned transaction, inputs and outputs, and unspecified +-- extra data. There is one input per input in the unsigned transaction, and one +-- output per output in the unsigned transaction. The inputs and outputs in the +-- 'PartiallySignedTransaction' line up by index with the inputs and outputs in +-- the unsigned transaction. data PartiallySignedTransaction = PartiallySignedTransaction { unsignedTransaction :: Tx , globalUnknown :: UnknownMap @@ -128,11 +123,12 @@ data PartiallySignedTransaction = PartiallySignedTransaction } deriving (Show, Eq, Generic) + instance NFData PartiallySignedTransaction -{- | Inputs contain all of the data needed to sign a transaction and all of the - resulting signature data after signing. --} + +-- | Inputs contain all of the data needed to sign a transaction and all of the +-- resulting signature data after signing. data Input = Input { nonWitnessUtxo :: Maybe Tx , witnessUtxo :: Maybe TxOut @@ -147,8 +143,10 @@ data Input = Input } deriving (Show, Eq, Generic) + instance NFData Input + -- | Outputs can contain information needed to spend the output at a later date. data Output = Output { outputRedeemScript :: Maybe Script @@ -158,17 +156,20 @@ data Output = Output } deriving (Show, Eq, Generic) + instance NFData Output -{- | A map of raw PSBT keys to byte strings for extra data. The 'keyType' field - cannot overlap with any of the reserved 'keyType' fields specified in the - PSBT specification. --} + +-- | A map of raw PSBT keys to byte strings for extra data. The 'keyType' field +-- cannot overlap with any of the reserved 'keyType' fields specified in the +-- PSBT specification. newtype UnknownMap = UnknownMap {unknownMap :: HashMap Key ByteString} deriving (Show, Eq, Semigroup, Monoid, Generic) + instance NFData UnknownMap + -- | Raw keys for the map type used in PSBTs. data Key = Key { keyType :: Word8 @@ -176,13 +177,15 @@ data Key = Key } deriving (Show, Eq, Generic) + instance NFData Key + instance Hashable Key -{- | Take two 'PartiallySignedTransaction's and merge them. The - 'unsignedTransaction' field in both must be the same. --} + +-- | Take two 'PartiallySignedTransaction's and merge them. The +-- 'unsignedTransaction' field in both must be the same. merge :: PartiallySignedTransaction -> PartiallySignedTransaction -> @@ -197,14 +200,15 @@ merge psbt1 psbt2 } merge _ _ = Nothing -{- | A version of 'merge' for a collection of PSBTs. - @since 0.21.0 --} +-- | A version of 'merge' for a collection of PSBTs. +-- +-- @since 0.21.0 mergeMany :: [PartiallySignedTransaction] -> Maybe PartiallySignedTransaction mergeMany (psbt : psbts) = foldM merge psbt psbts mergeMany _ = Nothing + mergeInput :: Input -> Input -> Input mergeInput a b = Input @@ -234,6 +238,7 @@ mergeInput a b = where witUtx = witnessUtxo a <|> witnessUtxo b + mergeOutput :: Output -> Output -> Output mergeOutput a b = Output @@ -247,12 +252,12 @@ mergeOutput a b = outputUnknown a <> outputUnknown b } -{- | A abstraction which covers varying key configurations. Use the 'Semigroup' - instance to create signers for sets of keys: `signerA <> signerB` can sign - anything for which `signerA` or `signerB` could sign. - @since 0.21@ --} +-- | A abstraction which covers varying key configurations. Use the 'Semigroup' +-- instance to create signers for sets of keys: `signerA <> signerB` can sign +-- anything for which `signerA` or `signerB` could sign. +-- +-- @since 0.21@ newtype PsbtSigner = PsbtSigner { unPsbtSigner :: PubKeyI -> @@ -260,25 +265,27 @@ newtype PsbtSigner = PsbtSigner Maybe SecKey } + instance Semigroup PsbtSigner where PsbtSigner signer1 <> PsbtSigner signer2 = PsbtSigner $ \pubKey origin -> signer1 pubKey origin <|> signer2 pubKey origin + instance Monoid PsbtSigner where mempty = PsbtSigner $ \_ _ -> Nothing -{- | Fetch the secret key for the given 'PubKeyI' if possible. - @since 0.21@ --} +-- | Fetch the secret key for the given 'PubKeyI' if possible. +-- +-- @since 0.21@ getSignerKey :: PsbtSigner -> PubKeyI -> Maybe (Fingerprint, DerivPath) -> Maybe SecKey getSignerKey = unPsbtSigner -{- | This signer can sign for one key. - @since 0.21@ --} +-- | This signer can sign for one key. +-- +-- @since 0.21@ secKeySigner :: SecKey -> PsbtSigner secKeySigner theSecKey = PsbtSigner signer where @@ -286,10 +293,10 @@ secKeySigner theSecKey = PsbtSigner signer | pubKeyPoint requiredKey == derivePubKey theSecKey = Just theSecKey | otherwise = Nothing -{- | This signer can sign with any child key, provided that derivation information is present. - @since 0.21@ --} +-- | This signer can sign with any child key, provided that derivation information is present. +-- +-- @since 0.21@ xPrvSigner :: XPrvKey -> -- | Origin data, if the input key is explicitly a child key @@ -299,7 +306,7 @@ xPrvSigner xprv origin = PsbtSigner signer where signer pubKey (Just hdData) | result@(Just theSecKey) <- maybe noOrigin onOrigin origin hdData - , pubKeyPoint pubKey == derivePubKey theSecKey = + , pubKeyPoint pubKey == derivePubKey theSecKey = result signer _ _ = Nothing @@ -326,11 +333,11 @@ xPrvSigner xprv origin = PsbtSigner signer adjustPath [] thePath = Just $ listToPath thePath adjustPath _ _ = Nothing -{- | Update a PSBT with signatures when possible. This function uses - 'inputHDKeypaths' in order to calculate secret keys. - @since 0.21@ --} +-- | Update a PSBT with signatures when possible. This function uses +-- 'inputHDKeypaths' in order to calculate secret keys. +-- +-- @since 0.21@ signPSBT :: Network -> PsbtSigner -> @@ -343,11 +350,13 @@ signPSBT net signer psbt = where tx = unsignedTransaction psbt + addSigsForInput :: Network -> PsbtSigner -> Tx -> (Int, Input) -> Input addSigsForInput net signer tx (ix, input) = maybe input (onPrevTxOut net signer tx ix input) $ Left <$> nonWitnessUtxo input <|> Right <$> witnessUtxo input + onPrevTxOut :: Network -> PsbtSigner -> @@ -398,6 +407,7 @@ onPrevTxOut net signer tx ix input prevTxData = sigKeys = HM.mapMaybeWithKey getSignerKey $ inputHDKeypaths input getSignerKey pubKey (fp, ixs) = unPsbtSigner signer pubKey $ Just (fp, listToPath ixs) + -- | Take partial signatures from all of the 'Input's and finalize the signature. complete :: PartiallySignedTransaction -> @@ -446,6 +456,7 @@ complete psbt = indexed :: [a] -> [(Word32, a)] indexed = zip [0 ..] + completeSig :: Input -> ScriptOutput -> Input completeSig input (PayPK k) = input @@ -455,7 +466,7 @@ completeSig input (PayPK k) = } completeSig input (PayPKHash h) | [(k, sig)] <- HashMap.toList (partialSigs input) - , PubKeyAddress h == pubKeyAddr k = + , PubKeyAddress h == pubKeyAddr k = input { finalScriptSig = Just $ @@ -472,9 +483,9 @@ completeSig input (PayMulSig pubKeys m) finalSig = Script $ OP_0 : map opPushData sigs completeSig input (PayScriptHash h) | Just rdmScript <- inputRedeemScript input - , PayScriptHash h == toP2SH rdmScript - , Right decodedScript <- decodeOutput rdmScript - , not (isPayScriptHash decodedScript) = + , PayScriptHash h == toP2SH rdmScript + , Right decodedScript <- decodeOutput rdmScript + , not (isPayScriptHash decodedScript) = pushScript rdmScript $ completeSig input decodedScript where pushScript rdmScript updatedInput = @@ -487,18 +498,20 @@ completeSig input (PayScriptHash h) scriptAppend (Script script1) (Script script2) = Script $ script1 <> script2 completeSig input (PayWitnessPKHash h) | [(k, sig)] <- HashMap.toList (partialSigs input) - , PubKeyAddress h == pubKeyAddr k = + , PubKeyAddress h == pubKeyAddr k = input{finalScriptWitness = Just [sig, runPutS $ serialize k]} completeSig input (PayWitnessScriptHash h) | Just witScript <- inputWitnessScript input - , PayWitnessScriptHash h == toP2WSH witScript - , Right decodedScript <- decodeOutput witScript = + , PayWitnessScriptHash h == toP2WSH witScript + , Right decodedScript <- decodeOutput witScript = completeWitnessSig input decodedScript completeSig input _ = input + serializedRedeemScript :: Script -> Script serializedRedeemScript = Script . pure . opPushData . runPutS . serialize + completeWitnessSig :: Input -> ScriptOutput -> Input completeWitnessSig input script@(PayMulSig pubKeys m) | length sigs >= m = @@ -508,6 +521,7 @@ completeWitnessSig input script@(PayMulSig pubKeys m) finalWit = mempty : sigs <> [encodeOutputBS script] completeWitnessSig input _ = input + collectSigs :: Int -> [PubKeyI] -> Input -> [ByteString] collectSigs m pubKeys input = take m . reverse $ foldl' lookupKey [] pubKeys @@ -516,10 +530,10 @@ collectSigs m pubKeys input = maybe sigs (: sigs) $ HashMap.lookup key (partialSigs input) -{- | Take a finalized 'PartiallySignedTransaction' and produce the signed final - transaction. You may need to call 'complete' on the - 'PartiallySignedTransaction' before producing the final transaction. --} + +-- | Take a finalized 'PartiallySignedTransaction' and produce the signed final +-- transaction. You may need to call 'complete' on the +-- 'PartiallySignedTransaction' before producing the final transaction. finalTransaction :: PartiallySignedTransaction -> Tx finalTransaction psbt = setInputs @@ -541,9 +555,9 @@ finalTransaction psbt = , fromMaybe [] (finalScriptWitness psbtInput) : witData ) -{- | Take an unsigned transaction and produce an empty - 'PartiallySignedTransaction' --} + +-- | Take an unsigned transaction and produce an empty +-- 'PartiallySignedTransaction' emptyPSBT :: Tx -> PartiallySignedTransaction emptyPSBT tx = PartiallySignedTransaction @@ -553,6 +567,7 @@ emptyPSBT tx = , outputs = replicate (length (txOut tx)) emptyOutput } + emptyInput :: Input emptyInput = Input @@ -567,9 +582,11 @@ emptyInput = Nothing (UnknownMap HashMap.empty) + emptyOutput :: Output emptyOutput = Output Nothing Nothing HashMap.empty (UnknownMap HashMap.empty) + instance Serialize PartiallySignedTransaction where get = do magic <- S.getBytes 4 @@ -606,6 +623,7 @@ instance Serialize PartiallySignedTransaction where , outputs } + put PartiallySignedTransaction { unsignedTransaction @@ -623,6 +641,7 @@ instance Serialize PartiallySignedTransaction where mapM_ S.put inputs mapM_ S.put outputs + instance Serialize Key where get = do VarInt keySize <- deserialize @@ -631,11 +650,13 @@ instance Serialize Key where k <- S.getBytes (fromIntegral keySize - 1) return (Key t k) + put (Key t k) = do putVarInt $ 1 + B.length k S.putWord8 t S.putByteString k + instance Serialize UnknownMap where get = go HashMap.empty where @@ -649,12 +670,14 @@ instance Serialize UnknownMap where then return (UnknownMap m) else getItem m + put (UnknownMap m) = void $ HashMap.traverseWithKey (\k v -> S.put k >> serialize (VarString v)) m + instance Serialize Input where get = getMap getInputItem setInputUnknown emptyInput @@ -665,6 +688,7 @@ instance Serialize Input where UnknownMap (f (unknownMap (inputUnknown input))) } + put Input { nonWitnessUtxo @@ -714,6 +738,7 @@ instance Serialize Input where S.put $ (VarInt . fromIntegral . length) witnessStack mapM_ (serialize . VarString) witnessStack + instance Serialize Output where get = getMap getOutputItem setOutputUnknown emptyOutput where @@ -723,6 +748,7 @@ instance Serialize Output where UnknownMap (f (unknownMap (outputUnknown output))) } + put Output { outputRedeemScript @@ -742,6 +768,7 @@ instance Serialize Output where S.put outputUnknown S.putWord8 0x00 + putSizedBytes :: Put -> Put putSizedBytes f = do putVarInt (B.length bs) @@ -749,21 +776,25 @@ putSizedBytes f = do where bs = S.runPut f + getSizedBytes :: Get a -> Get a getSizedBytes = S.getNested (fromIntegral . getVarInt <$> deserialize) + putKeyValue :: Enum t => t -> Put -> Put putKeyValue t v = do putKey t putSizedBytes v + putKey :: Enum t => t -> Put putKey t = do putVarInt (1 :: Word8) S.putWord8 (enumWord8 t) + getMap :: (Bounded t, Enum t) => (Int -> a -> t -> Get a) -> @@ -784,6 +815,7 @@ getMap getMapItem setUnknown = go then return m else getItem keySize m . word8Enum =<< S.getWord8 + data InputType = InNonWitnessUtxo | InWitnessUtxo @@ -796,16 +828,20 @@ data InputType | InFinalScriptWitness deriving (Show, Eq, Enum, Bounded, Generic) + instance NFData InputType + data OutputType = OutRedeemScript | OutWitnessScript | OutBIP32Derivation deriving (Show, Eq, Enum, Bounded, Generic) + instance NFData OutputType + getInputItem :: Int -> Input -> InputType -> Get Input getInputItem 0 input@Input{nonWitnessUtxo = Nothing} InNonWitnessUtxo = do utxo <- getSizedBytes deserialize @@ -856,6 +892,7 @@ getInputItem keySize input inputType = "Incorrect key size for input item or item already existed: " <> show (keySize, input, inputType) + getOutputItem :: Int -> Output -> OutputType -> Get Output getOutputItem 0 output@Output{outputRedeemScript = Nothing} OutRedeemScript = do script <- getSizedBytes deserialize @@ -871,20 +908,25 @@ getOutputItem keySize output outputType = "Incorrect key size for output item or item already existed: " <> show (keySize, output, outputType) + getHDPath :: Int -> Get (PubKeyI, (Fingerprint, [KeyIndex])) getHDPath keySize = (,) <$> S.isolate keySize deserialize <*> (unPSBTHDPath <$> S.get) + putHDPath :: Enum t => t -> HashMap PubKeyI (Fingerprint, [KeyIndex]) -> Put putHDPath t = putPubKeyMap S.put t . fmap PSBTHDPath + newtype PSBTHDPath = PSBTHDPath {unPSBTHDPath :: (Fingerprint, [KeyIndex])} deriving (Show, Eq, Generic) + instance NFData PSBTHDPath + instance Serialize PSBTHDPath where get = do VarInt valueSize <- deserialize @@ -897,12 +939,14 @@ instance Serialize PSBTHDPath where where getKeyIndexList n = replicateM n S.getWord32le + put (PSBTHDPath (fp, kis)) = do putVarInt (B.length bs) S.putByteString bs where bs = S.runPut $ S.put fp >> mapM_ S.putWord32le kis + putPubKeyMap :: Enum t => (a -> Put) -> t -> HashMap PubKeyI a -> Put putPubKeyMap f t = void . HashMap.traverseWithKey putItem @@ -911,15 +955,19 @@ putPubKeyMap f t = S.put $ Key (enumWord8 t) (runPutS (serialize k)) f v + enumWord8 :: Enum a => a -> Word8 enumWord8 = fromIntegral . fromEnum + word8Enum :: forall a. (Bounded a, Enum a) => Word8 -> Either Word8 a word8Enum n | n <= enumWord8 (maxBound :: a) = Right . toEnum $ fromIntegral n word8Enum n = Left n + whenJust :: Monad m => (a -> m ()) -> Maybe a -> m () whenJust = maybe (return ()) + justWhen :: (a -> Bool) -> a -> Maybe a justWhen test x = if test x then Just x else Nothing diff --git a/src/Haskoin/Transaction/Segwit.hs b/src/Haskoin/Transaction/Segwit.hs index b9b0891c..8f9e5720 100644 --- a/src/Haskoin/Transaction/Segwit.hs +++ b/src/Haskoin/Transaction/Segwit.hs @@ -2,19 +2,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} -{- | -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. --} +-- | +-- 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 (..), @@ -37,60 +32,60 @@ import Haskoin.Keys.Common import Haskoin.Script import Haskoin.Transaction.Common -{- | 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 -{- | 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) -{- | Encode a witness program - @since 0.11.0.0 --} +-- | Encode a witness program +-- +-- @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) -{- | 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) -{- | 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 @@ -105,10 +100,10 @@ viewWitnessProgram net so witness = case so of | 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 -> @@ -127,10 +122,10 @@ decodeWitnessInput net = \case _ -> 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 --} +-- | 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 @@ -142,10 +137,10 @@ calcWitnessProgram so si = case (so, si) of p2wpkh sig = return . P2WPKH . WitnessProgramPKH sig p2wsh i o = return . P2WSH $ WitnessProgramSH (simpleInputStack i) (encodeOutput o) -{- | Create the witness stack required to spend a standard P2WSH input - @since 0.11.0.0 --} +-- | 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] diff --git a/src/Haskoin/Transaction/Taproot.hs b/src/Haskoin/Transaction/Taproot.hs index b6332f92..e080ba04 100644 --- a/src/Haskoin/Transaction/Taproot.hs +++ b/src/Haskoin/Transaction/Taproot.hs @@ -3,17 +3,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} -{- | -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. --} +-- | +-- 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, @@ -62,18 +57,20 @@ import Haskoin.Script.Standard (ScriptOutput (PayWitness)) import Haskoin.Transaction.Common (WitnessStack) import Haskoin.Util (decodeHex, eitherToMaybe, encodeHex) -{- | 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 --} +-- | 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) + instance Eq XOnlyPubKey where k1 == k2 = runPutS (serialize k1) == runPutS (serialize k2) + instance Serial XOnlyPubKey where serialize (XOnlyPubKey pk) = putByteString @@ -87,14 +84,17 @@ instance Serial XOnlyPubKey where . BS.cons 0x02 =<< getBytes 32 + instance Serialize XOnlyPubKey where put = serialize get = deserialize + instance Binary XOnlyPubKey where put = serialize get = deserialize + -- | Hex encoding instance FromJSON XOnlyPubKey where parseJSON = @@ -102,30 +102,32 @@ instance FromJSON XOnlyPubKey where either fail pure . (runGetS deserialize <=< maybe (Left "Unable to decode hex") Right . decodeHex) + -- | Hex encoding instance ToJSON XOnlyPubKey where toJSON = toJSON . encodeHex . runPutS . serialize + -- | @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) -{- | 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 @@ -138,10 +140,10 @@ getMerkleProofs = getProofs mempty updateProof proofInit branchCommitment (v, s, 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 -> @@ -149,6 +151,7 @@ mastCommitment = \case MASTLeaf leafVersion leafScript -> leafHash leafVersion leafScript MASTCommitment theCommitment -> theCommitment + hashBranch :: Digest SHA256 -> Digest SHA256 -> Digest SHA256 hashBranch hashA hashB = hashFinalize $ @@ -158,6 +161,7 @@ hashBranch hashA hashB = , max hashA hashB ] + leafHash :: TapLeafVersion -> Script -> Digest SHA256 leafHash leafVersion leafScript = hashFinalize @@ -170,16 +174,17 @@ leafHash leafVersion leafScript = 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) + -- | @since 0.21.0 taprootOutputKey :: TaprootOutput -> PubKey taprootOutputKey TaprootOutput{taprootInternalKey, taprootMAST} = @@ -188,49 +193,52 @@ taprootOutputKey TaprootOutput{taprootInternalKey, taprootMAST} = commitment = taprootCommitment taprootInternalKey $ mastCommitment <$> taprootMAST keyFail = error "haskoin-core taprootOutputKey: key derivation failed" + taprootCommitment :: PubKey -> Maybe (Digest SHA256) -> ByteString taprootCommitment internalKey merkleRoot = - BA.convert . hashFinalize + BA.convert + . hashFinalize . maybe id (flip hashUpdate) merkleRoot . (`hashUpdate` keyBytes) $ initTaggedHash "TapTweak" where keyBytes = runPutS . serialize $ XOnlyPubKey internalKey -{- | Generate the output script for a taproot output -@since 0.21.0 --} +-- | Generate the output script for a taproot output +-- +-- @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) + -- | @since 0.21.0 data ScriptPathData = ScriptPathData { scriptPathAnnex :: Maybe ByteString , scriptPathStack :: [ByteString] , scriptPathScript :: Script , scriptPathExternalIsOdd :: Bool - , -- | This value is masked by 0xFE - scriptPathLeafVersion :: Word8 + , scriptPathLeafVersion :: Word8 + -- ^ This value is masked by 0xFE , scriptPathInternalKey :: PubKey , scriptPathControl :: [ByteString] } deriving (Eq, Show) -{- | Try to interpret a 'WitnessStack' as taproot witness data. -@since 0.21.0 --} +-- | 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 @@ -261,10 +269,10 @@ viewTaprootWitness witnessStack = case reverse witnessStack of 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 --} +-- | 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 @@ -281,10 +289,10 @@ encodeTaprootWitness = \case where parity = bool 0 1 . scriptPathExternalIsOdd -{- | 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 -> @@ -304,6 +312,7 @@ verifyScriptPathData outputKey scriptPathData = fromMaybe False $ do theLeafHash = (leafHash <$> (.&. 0xFE) . scriptPathLeafVersion <*> scriptPathScript) scriptPathData expectedParity = bool 0 1 $ scriptPathExternalIsOdd scriptPathData + keyParity :: PubKey -> Word8 keyParity key = case BS.unpack . runPutS . serialize $ PubKeyI key True of 0x02 : _ -> 0x00 diff --git a/src/Haskoin/Util.hs b/src/Haskoin/Util.hs index 4923d7eb..3c91d08a 100644 --- a/src/Haskoin/Util.hs +++ b/src/Haskoin/Util.hs @@ -2,16 +2,11 @@ {-# 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. --} +-- | +-- Stability : experimental +-- Portability : POSIX +-- +-- This module defines various utility functions used across the library. module Haskoin.Util ( -- * ByteString Helpers bsToInteger, @@ -91,6 +86,7 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as EL import Data.Word + -- ByteString helpers -- | Decode a big endian 'Integer' from a 'ByteString'. @@ -99,6 +95,7 @@ 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] @@ -109,27 +106,32 @@ integerToBS i f 0 = Nothing f x = Just (fromInteger x :: Word8, x `shiftR` 8) + hexBuilder :: BL.ByteString -> Builder hexBuilder = lazyByteStringHex + encodeHex :: ByteString -> Text encodeHex = B16.encodeBase16 + -- | Encode as string of human-readable hex characters. encodeHexLazy :: BL.ByteString -> TL.Text encodeHexLazy = BL16.encodeBase16 + decodeHex :: Text -> Maybe ByteString decodeHex = eitherToMaybe . B16.decodeBase16 . E.encodeUtf8 + -- | Decode string of human-readable hex characters. decodeHexLazy :: TL.Text -> Maybe BL.ByteString decodeHexLazy = eitherToMaybe . BL16.decodeBase16 . EL.encodeUtf8 -{- | Obtain 'Int' bits from beginning of 'ByteString'. Resulting 'ByteString' - will be smallest required to hold that many bits, padded with zeroes to the - right. --} + +-- | 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 @@ -140,30 +142,31 @@ getBits b 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. --} +-- | 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. --} + +-- | 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. --} +-- | 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 -> @@ -179,11 +182,11 @@ updateIndex i xs f 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. --} + +-- | 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] -> @@ -198,18 +201,22 @@ 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 = @@ -217,11 +224,11 @@ dropFieldLabel n = { 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. --} + +-- | 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) @@ -229,9 +236,9 @@ dropSumLabels c f tag = , sumEncoding = defaultTaggedObject{tagFieldName = tag} } -{- | Convert from one power-of-two base to another, as long as it fits in a - 'Word'. --} + +-- | 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 @@ -257,6 +264,7 @@ convertBits pad frombits tobits i = (reverse yout, rem') in inner acc out' bits' | otherwise = (out, bits) + -- -- Serialization helpers -- @@ -266,6 +274,7 @@ putInt32be n | n < 0 = putWord32be (complement (fromIntegral (abs n)) + 1) | otherwise = putWord32be (fromIntegral (abs n)) + getInt32be :: MonadGet m => m Int32 getInt32be = do n <- getWord32be @@ -273,11 +282,13 @@ getInt32be = do 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 @@ -285,6 +296,7 @@ getInt64be = do then return (negate (complement (fromIntegral n) + 1)) else return (fromIntegral n) + putInteger :: MonadPut m => Integer -> m () putInteger n | n >= lo && n <= hi = do @@ -300,6 +312,7 @@ putInteger n lo = fromIntegral (minBound :: Int32) hi = fromIntegral (maxBound :: Int32) + getInteger :: MonadGet m => m Integer getInteger = getWord8 >>= \case @@ -308,12 +321,14 @@ getInteger = sign <- getWord8 bytes <- getList getWord8 let v = roll bytes - return $! if sign == 0x01 then v else - v + 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 @@ -321,16 +336,19 @@ getMaybe f = 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 -- @@ -340,11 +358,13 @@ unroll = unfoldr step 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 @@ -357,24 +377,30 @@ nrBits k = 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 diff --git a/src/Haskoin/Util/Arbitrary.hs b/src/Haskoin/Util/Arbitrary.hs index 628f4f24..6edb12de 100644 --- a/src/Haskoin/Util/Arbitrary.hs +++ b/src/Haskoin/Util/Arbitrary.hs @@ -1,13 +1,8 @@ -{- | -Module : Haskoin.Test -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Arbitrary instances for testing. --} +-- | +-- Stability : experimental +-- Portability : POSIX +-- +-- Arbitrary instances for testing. module Haskoin.Util.Arbitrary ( module X, ) where @@ -21,3 +16,4 @@ import Haskoin.Util.Arbitrary.Network as X import Haskoin.Util.Arbitrary.Script as X import Haskoin.Util.Arbitrary.Transaction as X import Haskoin.Util.Arbitrary.Util as X + diff --git a/src/Haskoin/Util/Arbitrary/Address.hs b/src/Haskoin/Util/Arbitrary/Address.hs index 368af4e9..99251e80 100644 --- a/src/Haskoin/Util/Arbitrary/Address.hs +++ b/src/Haskoin/Util/Arbitrary/Address.hs @@ -1,13 +1,8 @@ {-# LANGUAGE TupleSections #-} -{- | -Module : Haskoin.Test.Address -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} +-- | +-- Stability : experimental +-- Portability : POSIX module Haskoin.Util.Arbitrary.Address where import qualified Data.ByteString as B @@ -18,10 +13,12 @@ import Haskoin.Util.Arbitrary.Crypto import Haskoin.Util.Arbitrary.Util import Test.QuickCheck + -- | Arbitrary pay-to-public-key-hash or pay-to-script-hash address. arbitraryAddress :: Gen Address arbitraryAddress = oneof [arbitraryPubKeyAddress, arbitraryScriptAddress] + -- | Arbitrary address including pay-to-witness arbitraryAddressAll :: Gen Address arbitraryAddressAll = @@ -33,30 +30,34 @@ arbitraryAddressAll = , 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,) <$> arbitraryAddress + -- | Arbitrary pay-to-public-key-hash address. arbitraryPubKeyAddress :: Gen Address arbitraryPubKeyAddress = PubKeyAddress <$> arbitraryHash160 + -- | Arbitrary pay-to-script-hash address. arbitraryScriptAddress :: Gen Address arbitraryScriptAddress = ScriptAddress <$> arbitraryHash160 + -- | Arbitrary pay-to-witness public key hash arbitraryWitnessPubKeyAddress :: Gen Address arbitraryWitnessPubKeyAddress = WitnessPubKeyAddress <$> arbitraryHash160 + -- | Arbitrary pay-to-witness script hash arbitraryWitnessScriptAddress :: Gen Address arbitraryWitnessScriptAddress = WitnessPubKeyAddress <$> arbitraryHash160 + arbitraryWitnessAddress :: Gen Address arbitraryWitnessAddress = do ver <- choose (1, 16) diff --git a/src/Haskoin/Util/Arbitrary/Block.hs b/src/Haskoin/Util/Arbitrary/Block.hs index 0180f7d9..c573ebfa 100644 --- a/src/Haskoin/Util/Arbitrary/Block.hs +++ b/src/Haskoin/Util/Arbitrary/Block.hs @@ -1,11 +1,6 @@ -{- | -Module : Haskoin.Test.Block -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} +-- | +-- Stability : experimental +-- Portability : POSIX module Haskoin.Util.Arbitrary.Block where import qualified Data.HashMap.Strict as HashMap @@ -17,6 +12,7 @@ import Haskoin.Util.Arbitrary.Transaction import Haskoin.Util.Arbitrary.Util import Test.QuickCheck + -- | Block full or arbitrary transactions. arbitraryBlock :: Network -> Gen Block arbitraryBlock net = do @@ -25,6 +21,7 @@ arbitraryBlock net = do txs <- vectorOf c (arbitraryTx net) return $ Block h txs + -- | Block header with random hash. arbitraryBlockHeader :: Gen BlockHeader arbitraryBlockHeader = @@ -36,10 +33,12 @@ arbitraryBlockHeader = <*> arbitrary <*> arbitrary + -- | Arbitrary block hash. arbitraryBlockHash :: Gen BlockHash arbitraryBlockHash = BlockHash <$> arbitraryHash256 + -- | Arbitrary 'GetBlocks' object with at least one block hash. arbitraryGetBlocks :: Gen GetBlocks arbitraryGetBlocks = @@ -48,6 +47,7 @@ arbitraryGetBlocks = <*> listOf1 arbitraryBlockHash <*> arbitraryBlockHash + -- | Arbitrary 'GetHeaders' object with at least one block header. arbitraryGetHeaders :: Gen GetHeaders arbitraryGetHeaders = @@ -56,11 +56,13 @@ arbitraryGetHeaders = <*> listOf1 arbitraryBlockHash <*> arbitraryBlockHash + -- | Arbitrary 'Headers' object with at least one block header. arbitraryHeaders :: Gen Headers arbitraryHeaders = Headers <$> listOf1 ((,) <$> arbitraryBlockHeader <*> arbitraryVarInt) + -- | Arbitrary 'MerkleBlock' with at least one hash. arbitraryMerkleBlock :: Gen MerkleBlock arbitraryMerkleBlock = do @@ -71,6 +73,7 @@ arbitraryMerkleBlock = do flags <- vectorOf (c * 8) arbitrary return $ MerkleBlock bh ntx hashes flags + -- | Arbitrary 'BlockNode' arbitraryBlockNode :: Gen BlockNode arbitraryBlockNode = @@ -80,6 +83,7 @@ arbitraryBlockNode = <*> arbitrarySizedNatural <*> arbitraryBlockHash + -- | Arbitrary 'HeaderMemory' arbitraryHeaderMemory :: Gen HeaderMemory arbitraryHeaderMemory = do diff --git a/src/Haskoin/Util/Arbitrary/Crypto.hs b/src/Haskoin/Util/Arbitrary/Crypto.hs index ec6cdbe8..f5a3b734 100644 --- a/src/Haskoin/Util/Arbitrary/Crypto.hs +++ b/src/Haskoin/Util/Arbitrary/Crypto.hs @@ -1,32 +1,31 @@ -{- | -Module : Haskoin.Test.Crypto -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} +-- | +-- Stability : experimental +-- Portability : POSIX module Haskoin.Util.Arbitrary.Crypto where import Haskoin.Crypto.Hash import Haskoin.Util.Arbitrary.Util import Test.QuickCheck + -- | Arbitrary 160-bit hash. arbitraryHash160 :: Gen Hash160 arbitraryHash160 = ripemd160 <$> arbitraryBSn 20 + -- | Arbitrary 256-bit hash. arbitraryHash256 :: Gen Hash256 arbitraryHash256 = sha256 <$> arbitraryBSn 32 + -- | Arbitrary 512-bit hash. arbitraryHash512 :: Gen Hash512 arbitraryHash512 = sha512 <$> arbitraryBSn 64 + -- | Arbitrary 32-bit checksum. arbitraryCheckSum32 :: Gen CheckSum32 arbitraryCheckSum32 = diff --git a/src/Haskoin/Util/Arbitrary/Keys.hs b/src/Haskoin/Util/Arbitrary/Keys.hs index 8c43bfc1..11054565 100644 --- a/src/Haskoin/Util/Arbitrary/Keys.hs +++ b/src/Haskoin/Util/Arbitrary/Keys.hs @@ -1,11 +1,6 @@ -{- | -Module : Haskoin.Test.Keys -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} +-- | +-- Stability : experimental +-- Portability : POSIX module Haskoin.Util.Arbitrary.Keys where import Data.Bits (clearBit) @@ -19,38 +14,46 @@ import Haskoin.Keys.Extended.Internal (Fingerprint (..)) import Haskoin.Util.Arbitrary.Crypto import Test.QuickCheck + -- | Arbitrary private key with arbitrary compressed flag. arbitrarySecKeyI :: Gen SecKeyI arbitrarySecKeyI = wrapSecKey <$> arbitrary <*> arbitrary + -- | Arbitrary keypair, both either compressed or not. arbitraryKeyPair :: Gen (SecKeyI, PubKeyI) arbitraryKeyPair = do k <- arbitrarySecKeyI return (k, derivePubKeyI k) + arbitraryFingerprint :: Gen Fingerprint arbitraryFingerprint = Fingerprint <$> arbitrary + -- | Arbitrary extended private key. arbitraryXPrvKey :: Gen XPrvKey arbitraryXPrvKey = - XPrvKey <$> 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 + {- Custom derivations -} -- | Arbitrary derivation index with last bit unset. genIndex :: Gen Word32 genIndex = (`clearBit` 31) <$> arbitrary + -- | Arbitrary BIP-32 path index. Can be hardened or not. arbitraryBip32PathIndex :: Gen Bip32PathIndex arbitraryBip32PathIndex = @@ -59,21 +62,24 @@ arbitraryBip32PathIndex = , Bip32HardIndex <$> genIndex ] + -- | Arbitrary BIP-32 derivation path composed of only hardened derivations. arbitraryHardPath :: Gen HardPath arbitraryHardPath = foldl' (:|) Deriv <$> listOf genIndex + -- | Arbitrary BIP-32 derivation path composed of only non-hardened derivations. arbitrarySoftPath :: Gen SoftPath arbitrarySoftPath = foldl' (:/) Deriv <$> listOf genIndex + -- | Arbitrary derivation path composed of hardened and non-hardened derivations. 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 @@ -82,10 +88,10 @@ arbitraryParsedPath = , 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. --} + +-- | 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 diff --git a/src/Haskoin/Util/Arbitrary/Message.hs b/src/Haskoin/Util/Arbitrary/Message.hs index 353ea8d9..9c570ba4 100644 --- a/src/Haskoin/Util/Arbitrary/Message.hs +++ b/src/Haskoin/Util/Arbitrary/Message.hs @@ -1,11 +1,6 @@ -{- | -Module : Haskoin.Test.Message -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} +-- | +-- Stability : experimental +-- Portability : POSIX module Haskoin.Util.Arbitrary.Message where import Haskoin.Data @@ -16,14 +11,17 @@ import Haskoin.Util.Arbitrary.Network import Haskoin.Util.Arbitrary.Transaction import Test.QuickCheck + -- | Arbitrary 'MessageHeader'. arbitraryMessageHeader :: Gen MessageHeader arbitraryMessageHeader = - MessageHeader <$> arbitrary + MessageHeader + <$> arbitrary <*> arbitraryMessageCommand <*> arbitrary <*> arbitraryCheckSum32 + -- | Arbitrary 'Message'. arbitraryMessage :: Network -> Gen Message arbitraryMessage net = diff --git a/src/Haskoin/Util/Arbitrary/Network.hs b/src/Haskoin/Util/Arbitrary/Network.hs index c8693818..08195e6c 100644 --- a/src/Haskoin/Util/Arbitrary/Network.hs +++ b/src/Haskoin/Util/Arbitrary/Network.hs @@ -1,11 +1,6 @@ -{- | -Module : Haskoin.Test.Network -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} +-- | +-- Stability : experimental +-- Portability : POSIX module Haskoin.Util.Arbitrary.Network where import qualified Data.ByteString as BS (empty, pack) @@ -17,14 +12,17 @@ import Haskoin.Util.Arbitrary.Util import Network.Socket (SockAddr (..)) import Test.QuickCheck + -- | Arbitrary 'VarInt'. arbitraryVarInt :: Gen VarInt arbitraryVarInt = VarInt <$> arbitrary + -- | Arbitrary 'VarString'. arbitraryVarString :: Gen VarString arbitraryVarString = VarString <$> arbitraryBS + -- | Arbitrary 'NetworkAddress'. arbitraryNetworkAddress :: Gen NetworkAddress arbitraryNetworkAddress = do @@ -43,26 +41,32 @@ arbitraryNetworkAddress = do let n = sockToHostAddress d return $ NetworkAddress s n + -- | Arbitrary 'NetworkAddressTime'. arbitraryNetworkAddressTime :: Gen (Word32, NetworkAddress) arbitraryNetworkAddressTime = (,) <$> arbitrary <*> arbitraryNetworkAddress + -- | Arbitrary 'InvType'. arbitraryInvType :: Gen InvType arbitraryInvType = elements [InvError, InvTx, InvBlock, InvMerkleBlock] + -- | Arbitrary 'InvVector'. arbitraryInvVector :: Gen InvVector arbitraryInvVector = InvVector <$> arbitraryInvType <*> arbitraryHash256 + -- | Arbitrary non-empty 'Inv'. arbitraryInv1 :: Gen Inv arbitraryInv1 = Inv <$> listOf1 arbitraryInvVector + -- | Arbitrary 'Version'. arbitraryVersion :: Gen Version arbitraryVersion = - Version <$> arbitrary + Version + <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitraryNetworkAddress @@ -72,16 +76,18 @@ arbitraryVersion = <*> 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 @@ -95,6 +101,7 @@ arbitraryReject = do ] return $ Reject m c s d + -- | Arbitrary 'RejectCode'. arbitraryRejectCode :: Gen RejectCode arbitraryRejectCode = @@ -109,22 +116,27 @@ arbitraryRejectCode = , RejectCheckpoint ] + -- | Arbitrary non-empty 'GetData'. arbitraryGetData :: Gen GetData arbitraryGetData = GetData <$> listOf1 arbitraryInvVector + -- | Arbitrary 'NotFound'. arbitraryNotFound :: Gen NotFound arbitraryNotFound = NotFound <$> listOf1 arbitraryInvVector + -- | Arbitrary 'Ping'. arbitraryPing :: Gen Ping arbitraryPing = Ping <$> arbitrary + -- | Arbitrary 'Pong'. arbitraryPong :: Gen Pong arbitraryPong = Pong <$> arbitrary + -- | Arbitrary bloom filter flags. arbitraryBloomFlags :: Gen BloomFlags arbitraryBloomFlags = @@ -134,9 +146,9 @@ arbitraryBloomFlags = , 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) @@ -145,16 +157,19 @@ arbitraryBloomFilter = do fl <- arbitraryBloomFlags return (n, fp, bloomCreate n fp tweak fl) + -- | Arbitrary 'FilterLoad'. arbitraryFilterLoad :: Gen FilterLoad arbitraryFilterLoad = do (_, _, bf) <- arbitraryBloomFilter return $ FilterLoad bf + -- | Arbitrary 'FilterAdd'. arbitraryFilterAdd :: Gen FilterAdd arbitraryFilterAdd = FilterAdd <$> arbitraryBS + -- | Arbitrary 'MessageCommand'. arbitraryMessageCommand :: Gen MessageCommand arbitraryMessageCommand = do diff --git a/src/Haskoin/Util/Arbitrary/Script.hs b/src/Haskoin/Util/Arbitrary/Script.hs index 2899e37f..990ddfcb 100644 --- a/src/Haskoin/Util/Arbitrary/Script.hs +++ b/src/Haskoin/Util/Arbitrary/Script.hs @@ -1,13 +1,8 @@ {-# LANGUAGE LambdaCase #-} -{- | -Module : Haskoin.Test.Script -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} +-- | +-- Stability : experimental +-- Portability : POSIX module Haskoin.Util.Arbitrary.Script where import Crypto.Secp256k1 @@ -27,10 +22,12 @@ import Haskoin.Util.Arbitrary.Keys import Haskoin.Util.Arbitrary.Util import Test.QuickCheck + -- | Arbitrary 'Script' with random script ops. arbitraryScript :: Gen Script arbitraryScript = Script <$> listOf arbitraryScriptOp + -- | Arbitrary 'ScriptOp' (push operations have random data). arbitraryScriptOp :: Gen ScriptOp arbitraryScriptOp = @@ -152,17 +149,13 @@ arbitraryScriptOp = , 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 = @@ -185,25 +178,24 @@ arbitraryIntScriptOp = , OP_16 ] + -- | Arbitrary 'PushDataType'. arbitraryPushDataType :: Gen PushDataType arbitraryPushDataType = elements [OPCODE, OPDATA1, OPDATA2, OPDATA4] + -- | Arbitrary 'SigHash' (including invalid/unknown sighash codes). arbitrarySigHash :: Gen SigHash 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 + f <- elements [id, setAnyoneCanPayFlag] + return $ f sh + arbitrarySigHashFlag :: Gen SigHashFlag arbitrarySigHashFlag = @@ -211,14 +203,13 @@ arbitrarySigHashFlag = [ 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. --} + +-- | 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 @@ -226,10 +217,8 @@ arbitraryTxSignature net = do let txsig = TxSignature sig sh return (TxHash m, key, txsig) where - filterBad sh = - not $ - isSigHashUnknown sh - || isNothing (getSigHashForkId net) && hasForkIdFlag sh + filterBad = not . isSigHashUnknown + -- | Arbitrary transaction signature that could also be empty. arbitraryTxSignatureEmpty :: Network -> Gen TxSignature @@ -239,6 +228,7 @@ arbitraryTxSignatureEmpty net = , (10, lst3 <$> arbitraryTxSignature net) ] + -- | Arbitrary m of n parameters. arbitraryMSParam :: Gen (Int, Int) arbitraryMSParam = do @@ -246,6 +236,7 @@ arbitraryMSParam = do n <- choose (m, 16) return (m, n) + -- | Arbitrary 'ScriptOutput' (Can by any valid type). arbitraryScriptOutput :: Network -> Gen ScriptOutput arbitraryScriptOutput net = @@ -264,9 +255,9 @@ arbitraryScriptOutput net = ] else [] -{- | Arbitrary 'ScriptOutput' of type 'PayPK', 'PayPKHash' or 'PayMS' - (Not 'PayScriptHash', 'DataCarrier', or SegWit) --} + +-- | Arbitrary 'ScriptOutput' of type 'PayPK', 'PayPKHash' or 'PayMS' +-- (Not 'PayScriptHash', 'DataCarrier', or SegWit) arbitrarySimpleOutput :: Gen ScriptOutput arbitrarySimpleOutput = oneof @@ -275,22 +266,27 @@ arbitrarySimpleOutput = , arbitraryMSOutput ] + -- | Arbitrary 'ScriptOutput' of type 'PayPK' arbitraryPKOutput :: Gen ScriptOutput arbitraryPKOutput = PayPK . snd <$> arbitraryKeyPair + -- | Arbitrary 'ScriptOutput' of type 'PayPKHash' arbitraryPKHashOutput :: Gen ScriptOutput arbitraryPKHashOutput = PayPKHash <$> arbitraryHash160 + -- | Arbitrary 'PayWitnessPKHash' output. arbitraryWPKHashOutput :: Gen ScriptOutput arbitraryWPKHashOutput = PayWitnessPKHash <$> arbitraryHash160 + -- | Arbitrary 'PayWitnessScriptHash' output. arbitraryWSHOutput :: Gen ScriptOutput arbitraryWSHOutput = PayWitnessScriptHash <$> arbitraryHash256 + arbitraryWitOutput :: Gen ScriptOutput arbitraryWitOutput = do ver <- choose (1, 16) @@ -299,6 +295,7 @@ arbitraryWitOutput = do let bs = B.pack ws return $ PayWitness ver bs + -- | Arbitrary 'ScriptOutput' of type 'PayMS'. arbitraryMSOutput :: Gen ScriptOutput arbitraryMSOutput = do @@ -306,6 +303,7 @@ arbitraryMSOutput = do keys <- map snd <$> vectorOf n arbitraryKeyPair return $ PayMulSig keys m + -- | Arbitrary 'ScriptOutput' of type 'PayMS', only using compressed keys. arbitraryMSOutputC :: Gen ScriptOutput arbitraryMSOutputC = do @@ -315,14 +313,17 @@ arbitraryMSOutputC = do <$> vectorOf n (arbitraryKeyPair `suchThat` (pubKeyCompressed . snd)) return $ PayMulSig keys m + -- | Arbitrary 'ScriptOutput' of type 'PayScriptHash'. arbitrarySHOutput :: Gen ScriptOutput arbitrarySHOutput = PayScriptHash . getAddrHash160 <$> arbitraryScriptAddress + -- | Arbitrary 'ScriptOutput' of type 'DataCarrier'. arbitraryDCOutput :: Gen ScriptOutput arbitraryDCOutput = DataCarrier <$> arbitraryBS1 + -- | Arbitrary 'ScriptInput'. arbitraryScriptInput :: Network -> Gen ScriptInput arbitraryScriptInput net = @@ -333,9 +334,9 @@ arbitraryScriptInput net = , arbitrarySHInput net ] -{- | Arbitrary 'ScriptInput' of type 'SpendPK', 'SpendPKHash' or 'SpendMulSig' - (not 'ScriptHashInput') --} + +-- | Arbitrary 'ScriptInput' of type 'SpendPK', 'SpendPKHash' or 'SpendMulSig' +-- (not 'ScriptHashInput') arbitrarySimpleInput :: Network -> Gen ScriptInput arbitrarySimpleInput net = oneof @@ -344,10 +345,12 @@ arbitrarySimpleInput net = , arbitraryMSInput net ] + -- | Arbitrary 'ScriptInput' of type 'SpendPK'. arbitraryPKInput :: Network -> Gen ScriptInput arbitraryPKInput net = RegularInput . SpendPK <$> arbitraryTxSignatureEmpty net + -- | Arbitrary 'ScriptInput' of type 'SpendPK'. arbitraryPKHashInput :: Network -> Gen ScriptInput arbitraryPKHashInput net = do @@ -355,6 +358,7 @@ arbitraryPKHashInput net = do key <- snd <$> arbitraryKeyPair return $ RegularInput $ SpendPKHash sig key + -- | Like 'arbitraryPKHashInput' without empty signatures. arbitraryPKHashInputFull :: Network -> Gen ScriptInput arbitraryPKHashInputFull net = do @@ -362,6 +366,7 @@ arbitraryPKHashInputFull net = do key <- snd <$> arbitraryKeyPair return $ RegularInput $ SpendPKHash sig key + -- | Like above but only compressed. arbitraryPKHashInputFullC :: Network -> Gen ScriptInput arbitraryPKHashInputFullC net = do @@ -369,6 +374,7 @@ arbitraryPKHashInputFullC net = do key <- fmap snd $ arbitraryKeyPair `suchThat` (pubKeyCompressed . snd) return $ RegularInput $ SpendPKHash sig key + -- | Arbitrary 'ScriptInput' of type 'SpendMulSig'. arbitraryMSInput :: Network -> Gen ScriptInput arbitraryMSInput net = do @@ -376,15 +382,16 @@ arbitraryMSInput net = do sigs <- vectorOf m (arbitraryTxSignatureEmpty net) return $ RegularInput $ SpendMulSig sigs + -- | Arbitrary 'ScriptInput' of type 'ScriptHashInput'. arbitrarySHInput :: Network -> Gen ScriptInput arbitrarySHInput net = do i <- arbitrarySimpleInput net ScriptHashInput (getRegularInput i) <$> arbitrarySimpleOutput -{- | Arbitrary 'ScriptInput' of type 'ScriptHashInput' containing a - 'RedeemScript' of type 'PayMulSig' and an input of type 'SpendMulSig'. --} + +-- | 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 @@ -393,9 +400,9 @@ arbitraryMulSigSHInput net = return $ ScriptHashInput (SpendMulSig sigs) rdm _ -> undefined -{- | Arbitrary 'ScriptInput' of type 'ScriptHashInput' containing a - 'RedeemScript' of type 'PayMulSig' and an input of type 'SpendMulSig'. --} + +-- | 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 @@ -404,6 +411,7 @@ arbitraryMulSigSHInputC net = return $ ScriptHashInput (SpendMulSig sigs) rdm _ -> undefined + -- | Like 'arbitraryMulSigSHCInput' with no empty signatures. arbitraryMulSigSHInputFull :: Network -> Gen ScriptInput arbitraryMulSigSHInputFull net = @@ -413,6 +421,7 @@ arbitraryMulSigSHInputFull net = return $ ScriptHashInput (SpendMulSig sigs) rdm _ -> undefined + -- | Like 'arbitraryMulSigSHCInput' with no empty signatures. arbitraryMulSigSHInputFullC :: Network -> Gen ScriptInput arbitraryMulSigSHInputFullC net = diff --git a/src/Haskoin/Util/Arbitrary/Transaction.hs b/src/Haskoin/Util/Arbitrary/Transaction.hs index a6d6e296..61256528 100644 --- a/src/Haskoin/Util/Arbitrary/Transaction.hs +++ b/src/Haskoin/Util/Arbitrary/Transaction.hs @@ -1,11 +1,6 @@ -{- | -Module : Haskoin.Test.Transaction -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} +-- | +-- Stability : experimental +-- Portability : POSIX module Haskoin.Util.Arbitrary.Transaction where import Control.Monad @@ -25,50 +20,63 @@ import Haskoin.Util.Arbitrary.Script import Haskoin.Util.Arbitrary.Util import Test.QuickCheck + -- | Wrapped coin value for testing. newtype TestCoin = TestCoin {getTestCoin :: Word64} deriving (Eq, Show) + instance Coin TestCoin where coinValue = getTestCoin + -- | Arbitrary transaction hash (for non-existent transaction). arbitraryTxHash :: Gen TxHash arbitraryTxHash = TxHash <$> arbitraryHash256 + -- | Arbitrary amount of Satoshi as 'Word64' (Between 1 and 21e14) arbitrarySatoshi :: Network -> Gen TestCoin arbitrarySatoshi net = TestCoin <$> choose (1, getMaxSatoshi net) + -- | Arbitrary 'OutPoint'. arbitraryOutPoint :: Gen OutPoint arbitraryOutPoint = OutPoint <$> arbitraryTxHash <*> arbitrary + -- | Arbitrary 'TxOut'. arbitraryTxOut :: Network -> Gen TxOut arbitraryTxOut net = - TxOut <$> (getTestCoin <$> arbitrarySatoshi net) + TxOut + <$> (getTestCoin <$> arbitrarySatoshi net) <*> (encodeOutputBS <$> arbitraryScriptOutput net) + -- | Arbitrary 'TxIn'. arbitraryTxIn :: Network -> Gen TxIn arbitraryTxIn net = - TxIn <$> arbitraryOutPoint + TxIn + <$> arbitraryOutPoint <*> (encodeInputBS <$> arbitraryScriptInput net) <*> arbitrary + -- | Arbitrary transaction. Can be regular or with witnesses. arbitraryTx :: Network -> Gen Tx arbitraryTx net = oneof [arbitraryLegacyTx net, arbitraryWitnessTx net] + -- | Arbitrary regular transaction. arbitraryLegacyTx :: Network -> Gen Tx arbitraryLegacyTx net = arbitraryWLTx net False + -- | Arbitrary witness transaction (witness data is fake). arbitraryWitnessTx :: Network -> Gen Tx arbitraryWitnessTx net = arbitraryWLTx net True + -- | Arbitrary witness or legacy transaction. arbitraryWLTx :: Network -> Bool -> Gen Tx arbitraryWLTx net wit = do @@ -83,10 +91,10 @@ arbitraryWLTx net wit = do 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. --} + +-- | 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) @@ -95,6 +103,7 @@ arbitraryAddrOnlyTx net = do outs <- vectorOf no (arbitraryAddrOnlyTxOut net) Tx <$> arbitrary <*> pure inps <*> pure outs <*> pure [] <*> arbitrary + -- | Like 'arbitraryAddrOnlyTx' without empty signatures in the inputs. arbitraryAddrOnlyTxFull :: Network -> Gen Tx arbitraryAddrOnlyTxFull net = do @@ -104,14 +113,15 @@ arbitraryAddrOnlyTxFull net = do outs <- vectorOf no (arbitraryAddrOnlyTxOut net) 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. --} + +-- | 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 + -- | like 'arbitraryAddrOnlyTxIn' with no empty signatures. arbitraryAddrOnlyTxInFull :: Network -> Gen TxIn arbitraryAddrOnlyTxInFull net = do @@ -119,6 +129,7 @@ arbitraryAddrOnlyTxInFull net = do oneof [arbitraryPKHashInputFullC net, arbitraryMulSigSHInputFullC net] TxIn <$> arbitraryOutPoint <*> pure (encodeInputBS inp) <*> arbitrary + -- | Arbitrary 'TxOut' that can only be of type 'PayPKHash' or 'PaySH'. arbitraryAddrOnlyTxOut :: Network -> Gen TxOut arbitraryAddrOnlyTxOut net = do @@ -126,9 +137,9 @@ arbitraryAddrOnlyTxOut net = do out <- oneof [arbitraryPKHashOutput, arbitrarySHOutput] return $ TxOut v $ encodeOutputBS out -{- | Arbitrary 'SigInput' with the corresponding private keys used - to generate the 'ScriptOutput' or 'RedeemScript'. --} + +-- | Arbitrary 'SigInput' with the corresponding private keys used +-- to generate the 'ScriptOutput' or 'RedeemScript'. arbitrarySigInput :: Network -> Gen (SigInput, [SecKeyI]) arbitrarySigInput net = oneof @@ -140,14 +151,17 @@ arbitrarySigInput net = , arbitraryWSHSigInput net ] + -- | Arbitrary 'SigInput' with a 'ScriptOutput' of type 'PayPK'. arbitraryPKSigInput :: Network -> Gen (SigInput, SecKeyI) arbitraryPKSigInput net = arbitraryAnyInput net False + -- | Arbitrary 'SigInput' with a 'ScriptOutput' of type 'PayPKHash'. arbitraryPKHashSigInput :: Network -> Gen (SigInput, SecKeyI) arbitraryPKHashSigInput net = arbitraryAnyInput net True + -- | Arbitrary 'SigInput'. arbitraryAnyInput :: Network -> Bool -> Gen (SigInput, SecKeyI) arbitraryAnyInput net pkh = do @@ -158,6 +172,7 @@ arbitraryAnyInput net pkh = do (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 @@ -166,6 +181,7 @@ arbitraryInputStuff net = do sh <- arbitraryValidSigHash net return (val, op, sh) + -- | Arbitrary 'SigInput' with a 'ScriptOutput' of type 'PayMulSig'. arbitraryMSSigInput :: Network -> Gen (SigInput, [SecKeyI]) arbitraryMSSigInput net = do @@ -177,9 +193,9 @@ arbitraryMSSigInput net = do 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'. --} + +-- | Arbitrary 'SigInput' with 'ScriptOutput' of type 'PaySH' and a +-- 'RedeemScript'. arbitrarySHSigInput :: Network -> Gen (SigInput, [SecKeyI]) arbitrarySHSigInput net = do (SigInput rdm val op sh _, ks) <- @@ -191,6 +207,7 @@ arbitrarySHSigInput net = do let out = PayScriptHash $ getAddrHash160 $ payToScriptAddress rdm return (SigInput out val op sh $ Just rdm, ks) + arbitraryWPKHSigInput :: Network -> Gen (SigInput, SecKeyI) arbitraryWPKHSigInput net = do (k, p) <- arbitraryKeyPair @@ -198,6 +215,7 @@ arbitraryWPKHSigInput net = do let out = PayWitnessPKHash . getAddrHash160 $ pubKeyAddr p return (SigInput out val op sh Nothing, k) + arbitraryWSHSigInput :: Network -> Gen (SigInput, [SecKeyI]) arbitraryWSHSigInput net = do (SigInput rdm val op sh _, ks) <- @@ -209,9 +227,9 @@ arbitraryWSHSigInput net = do let out = PayWitnessScriptHash . getAddrHash256 $ payToWitnessScriptAddress rdm 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'. --} + +-- | 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 @@ -227,6 +245,7 @@ arbitrarySigningData net = do keys = concatMap snd uSigis return (tx, map fst uSigis, keys) + -- | Arbitrary transaction with empty inputs. arbitraryEmptyTx :: Network -> Gen Tx arbitraryEmptyTx net = do @@ -239,6 +258,7 @@ arbitraryEmptyTx net = do 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)]) @@ -277,5 +297,6 @@ arbitraryPartialTxs net = do ) ] + wrapKey :: (SigInput, SecKeyI) -> (SigInput, [SecKeyI]) wrapKey (s, k) = (s, [k]) diff --git a/src/Haskoin/Util/Arbitrary/Util.hs b/src/Haskoin/Util/Arbitrary/Util.hs index 26f3bdce..648dcef8 100644 --- a/src/Haskoin/Util/Arbitrary/Util.hs +++ b/src/Haskoin/Util/Arbitrary/Util.hs @@ -1,14 +1,9 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-} -{- | -Module : Haskoin.Test.Util -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} +-- | +-- Stability : experimental +-- Portability : POSIX module Haskoin.Util.Arbitrary.Util ( arbitraryBS, arbitraryBS1, @@ -37,8 +32,8 @@ 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 @@ -54,36 +49,44 @@ import Test.Hspec (Spec, describe, shouldBe, shouldSatisfy) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck + -- | Arbitrary strict 'ByteString'. arbitraryBS :: Gen ByteString arbitraryBS = pack <$> arbitrary + -- | Arbitrary non-empty strict 'ByteString' arbitraryBS1 :: Gen ByteString arbitraryBS1 = pack <$> listOf1 arbitrary + -- | Arbitrary strict 'ByteString' of a given length arbitraryBSn :: Int -> Gen ByteString arbitraryBSn n = pack <$> vectorOf n arbitrary + -- | Arbitrary 'ShortByteString'. arbitraryBSS :: Gen BSS.ShortByteString arbitraryBSS = BSS.pack <$> arbitrary + -- | Arbitrary non-empty 'ShortByteString' arbitraryBSS1 :: Gen BSS.ShortByteString arbitraryBSS1 = BSS.pack <$> listOf1 arbitrary + -- | Arbitrary 'ShortByteString' of a given length arbitraryBSSn :: Int -> Gen BSS.ShortByteString 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 + -- | Generate a Maybe from a Gen a arbitraryMaybe :: Gen a -> Gen (Maybe a) arbitraryMaybe g = @@ -92,10 +95,12 @@ arbitraryMaybe g = , (5, Just <$> g) ] + -- | Generate an Network arbitraryNetwork :: Gen Network arbitraryNetwork = elements allNets + -- Helpers for creating Serial and JSON Identity tests data SerialBox @@ -103,16 +108,19 @@ data SerialBox (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) + data JsonBox = 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) => @@ -123,16 +131,22 @@ data NetBox , Gen (Network, a) ) + testIdentity :: [SerialBox] -> [ReadBox] -> [JsonBox] -> [NetBox] -> Spec testIdentity serialVals readVals jsonVals netVals = do describe "Binary Encoding" $ - forM_ serialVals $ \(SerialBox g) -> testSerial g + forM_ serialVals $ + \(SerialBox g) -> testSerial g describe "Read/Show Encoding" $ - forM_ readVals $ \(ReadBox g) -> testRead g + forM_ readVals $ + \(ReadBox g) -> testRead g describe "Data.Aeson Encoding" $ - forM_ jsonVals $ \(JsonBox g) -> testJson g + forM_ jsonVals $ + \(JsonBox g) -> testJson g describe "Data.Aeson Encoding with Network" $ - forM_ netVals $ \(NetBox (j, e, p, g)) -> testNetJson j e p g + forM_ netVals $ + \(NetBox (j, e, p, g)) -> testNetJson j e p g + -- | Generate binary identity tests testSerial :: @@ -149,17 +163,20 @@ testSerial gen = proxy :: Gen a -> Proxy a proxy = const Proxy + -- | Generate Read/Show identity tests testRead :: (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 + forAll gen $ + \x -> (read . show) x `shouldBe` x where name = show $ T.typeRep $ proxy gen proxy :: Gen a -> Proxy a proxy = const Proxy + -- | Generate Data.Aeson identity tests testJson :: (Eq a, Show a, T.Typeable a, A.ToJSON a, A.FromJSON a) => Gen a -> Spec @@ -177,6 +194,7 @@ testJson gen = do (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) => @@ -187,9 +205,11 @@ testNetJson :: 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 + 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 + 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,23 +218,28 @@ testNetJson j e p g = do proxy :: (Network -> a -> A.Value) -> Proxy a proxy = const Proxy + arbitraryNetData :: Arbitrary a => Gen (Network, a) arbitraryNetData = do net <- arbitraryNetwork x <- arbitrary return (net, x) + genNetData :: Gen a -> Gen (Network, a) genNetData gen = do net <- arbitraryNetwork x <- gen return (net, x) + toMap :: a -> Map.Map String a toMap = Map.singleton "object" + toMapE :: A.Encoding -> A.Encoding toMapE = A.pairs . A.pair "object" + fromMap :: Map.Map String a -> a fromMap = (Map.! "object") diff --git a/stack.yaml b/stack.yaml index 65de78f5..f3a4011d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,5 +1,8 @@ -resolver: lts-19.3 +resolver: lts-19.22 +system-ghc: true nix: packages: - secp256k1 - pkg-config +extra-deps: + - fourmolu-0.8.2.0 diff --git a/stack.yaml.lock b/stack.yaml.lock index 729c2194..eefaa121 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -3,10 +3,17 @@ # For more information, please see the documentation at: # https://docs.haskellstack.org/en/stable/lock_files -packages: [] +packages: +- completed: + hackage: fourmolu-0.8.2.0@sha256:2cc2e4b296897b14e937c6a22e1b9840699b2b7bf5021fbdc6f212376d44edb6,7469 + pantry-tree: + size: 143718 + sha256: e467a3bce53e6bbb71414a368369095eee13e423d093a5aff2cd128317362c3e + original: + hackage: fourmolu-0.8.2.0 snapshots: - completed: - size: 617368 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/3.yaml - sha256: a209d3455279ee76eb45f01f73bbb960ceaaa8dfad8891435384689df4dcb653 - original: lts-19.3 + size: 619399 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/22.yaml + sha256: 5098594e71bdefe0c13e9e6236f12e3414ef91a2b89b029fd30e8fc8087f3a07 + original: lts-19.22 diff --git a/test/Haskoin/Address/Bech32Spec.hs b/test/Haskoin/Address/Bech32Spec.hs index 9fb74e08..78849731 100644 --- a/test/Haskoin/Address/Bech32Spec.hs +++ b/test/Haskoin/Address/Bech32Spec.hs @@ -20,6 +20,7 @@ import Haskoin.Util import Test.HUnit import Test.Hspec + spec = do describe "bech32 checksum" $ do it "should be valid" $ @@ -67,6 +68,7 @@ spec = do 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) @@ -86,10 +88,12 @@ testValidChecksum enc checksum = case bech32Decode checksum of expectedChecksum checksumEncoded + testInvalidChecksum :: Bech32 -> Assertion testInvalidChecksum checksum = assertBool (show checksum) (isNothing $ bech32Decode checksum) + testValidAddress :: (Text, Text) -> Assertion testValidAddress (address, hexscript) = do let address' = T.toLower address @@ -107,17 +111,20 @@ testValidAddress (address, hexscript) = do (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) + segwitScriptPubkey :: Word8 -> [Word8] -> ByteString segwitScriptPubkey witver witprog = B.pack $ witver' : fromIntegral (length witprog) : witprog where witver' = if witver == 0 then 0 else witver + 0x50 + validChecksums :: [(Bech32Encoding, Text)] validChecksums = [ @@ -170,6 +177,7 @@ validChecksums = ) ] + invalidChecksums :: [Text] invalidChecksums = [ " 1nwldj5" @@ -182,6 +190,7 @@ invalidChecksums = , "de1lg7wt\xFF" ] + validAddresses :: [(Text, Text)] validAddresses = [ @@ -230,6 +239,7 @@ validAddresses = ) ] + invalidAddresses :: [Text] invalidAddresses = [ "tc1qw508d6qejxtdg4y5r3zarvary0c5xw7kg3g4ty" @@ -257,9 +267,11 @@ invalidAddresses = , "tb1p0xlxvlhemja6c4dqv22uapctqupfhlxm9h8z3k2e72q4k9hcz7vpggkg4j" ] + hrpCaseVariants :: [Text] hrpCaseVariants = map T.pack hrpTestPermutations + hrpTestPermutations :: [String] hrpTestPermutations = do a <- ['t', 'T'] diff --git a/test/Haskoin/Address/CashAddrSpec.hs b/test/Haskoin/Address/CashAddrSpec.hs deleted file mode 100644 index 11c640c0..00000000 --- a/test/Haskoin/Address/CashAddrSpec.hs +++ /dev/null @@ -1,347 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Haskoin.Address.CashAddrSpec (spec) where - -import Control.Monad -import qualified Data.ByteString.Char8 as C -import Data.Maybe -import Data.String.Conversions -import Data.Text (Text) -import Haskoin.Address -import Haskoin.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 - -{- 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 - where - Just bs = decodeHex hex - Just (_, ver, pay) = cash32decodeType addr - -{- | 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" - ) - ] diff --git a/test/Haskoin/AddressSpec.hs b/test/Haskoin/AddressSpec.hs index 11f4f452..ede53321 100644 --- a/test/Haskoin/AddressSpec.hs +++ b/test/Haskoin/AddressSpec.hs @@ -18,16 +18,20 @@ import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck + serialVals :: [SerialBox] serialVals = [SerialBox arbitraryAddressAll] + readVals :: [ReadBox] readVals = [ReadBox arbitraryAddressAll] + netVals :: [NetBox] netVals = [NetBox (addrToJSON, addrToEncoding, addrFromJSON, arbitraryNetAddress)] + spec :: Spec spec = do testIdentity serialVals readVals [] netVals @@ -56,6 +60,7 @@ spec = do it "Passes addresses witness p2sh(pwpkh) vectors" $ mapM_ testCompatWitnessVector compatWitnessVectors + testVector :: (ByteString, Text, Text) -> Assertion testVector (bs, e, chk) = do assertEqual "encodeBase58" e b58 @@ -66,6 +71,7 @@ testVector (bs, e, chk) = do b58 = encodeBase58 bs b58Chk = encodeBase58Check bs + vectors :: [(ByteString, Text, Text)] vectors = [ (BS.empty, "", "3QJmnh") @@ -93,6 +99,7 @@ vectors = ) ] + -- Test vectors from: -- https://github.com/bitcoin/bitcoin/blob/master/src/test/data/base58_encode_decode.json @@ -105,6 +112,7 @@ testBase58Vector (a, b) = do bsA = fromJust $ decodeHex a bsB = fromJust $ decodeBase58 b + base58Vectors :: [(Text, Text)] base58Vectors = [ ("", "") @@ -149,6 +157,7 @@ base58Vectors = ) ] + -- Test vectors from: -- https://github.com/bitcoin/bitcoin/blob/master/src/test/base58_tests.cpp @@ -156,6 +165,7 @@ testBase58InvalidVector :: (Text, Maybe Text) -> Assertion testBase58InvalidVector (a, resM) = assertEqual "decodeBase58 invalid match" resM (encodeHex <$> decodeBase58 a) + base58InvalidVectors :: [(Text, Maybe Text)] base58InvalidVectors = [ ("invalid", Nothing) @@ -169,6 +179,7 @@ base58InvalidVectors = -- , (" \t\n\v\f\r skip \r\f\v\n\t ", Just "971a55") ] + testBase58ChkInvalidVector :: (Text, Maybe Text) -> Assertion testBase58ChkInvalidVector (a, resM) = assertEqual @@ -176,6 +187,7 @@ testBase58ChkInvalidVector (a, resM) = resM (encodeHex <$> decodeBase58Check a) + base58ChkInvalidVectors :: [(Text, Maybe Text)] base58ChkInvalidVectors = [ ("3vQB7B6MrGQZaxCuFg4oh", Just "68656c6c6f20776f726c64") @@ -184,6 +196,7 @@ base58ChkInvalidVectors = , ("3vQB7B6MrGQZaxCuFg4oh\00IOl", Nothing) ] + testCompatWitnessVector :: (Network, Text, Text) -> Assertion testCompatWitnessVector (net, seckey, addr) = do let seckeyM = fromWif net seckey @@ -193,6 +206,7 @@ testCompatWitnessVector (net, seckey, addr) = do assertBool "address can be encoded" (isJust addrM) assertEqual "witness address matches" addr (fromJust addrM) + compatWitnessVectors :: [(Network, Text, Text)] compatWitnessVectors = [ diff --git a/test/Haskoin/BlockSpec.hs b/test/Haskoin/BlockSpec.hs index 4b744373..585a8248 100644 --- a/test/Haskoin/BlockSpec.hs +++ b/test/Haskoin/BlockSpec.hs @@ -22,6 +22,7 @@ import Test.Hspec.QuickCheck import Test.QuickCheck import Text.Printf (printf) + serialVals :: [SerialBox] serialVals = [ SerialBox (arbitraryBlock =<< arbitraryNetwork) @@ -34,6 +35,7 @@ serialVals = , SerialBox arbitraryBlockNode ] + readVals :: [ReadBox] readVals = [ ReadBox (arbitraryBlock =<< arbitraryNetwork) @@ -46,6 +48,7 @@ readVals = , ReadBox arbitraryBlockNode ] + jsonVals :: [JsonBox] jsonVals = [ JsonBox (arbitraryBlock =<< arbitraryNetwork) @@ -53,12 +56,15 @@ jsonVals = , JsonBox arbitraryBlockHeader ] + myTime :: Timestamp myTime = 1499083075 + withChain :: Network -> State HeaderMemory a -> a withChain net f = evalState f (initialChain net) + chain :: BlockHeaders m => Network -> BlockHeader -> Int -> m () chain net bh i = do bnsE <- connectBlocks net myTime bhs @@ -66,30 +72,10 @@ chain net bh i = do 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 -> @@ -120,6 +106,7 @@ spec = do it "computes bitcoin block subsidy correctly" (testSubsidy btc) it "computes regtest block subsidy correctly" (testSubsidy btcRegTest) + -- 0 → → 2015 → → → → → → → 4031 -- ↓ -- → → 2035 → → → → → → 4035* @@ -162,14 +149,17 @@ splitChain net = do Right bn -> return bn Left ex -> error ex + {- Merkle Trees -} testTreeWidth :: Int -> Property testTreeWidth i = i /= 0 ==> calcTreeWidth (abs i) (calcTreeHeight $ abs i) == 1 + testBaseWidth :: Int -> Property 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) @@ -179,6 +169,7 @@ buildExtractTree net 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) @@ -188,6 +179,7 @@ testCompact = do assertEqual "vector 5" 0x05c0de00 (encodeCompact (-0x40de000000)) assertEqual "vector 6" (-0x40de000000, False) (decodeCompact 0x05c0de00) + testCompactBitcoinCore :: Assertion testCompactBitcoinCore = do assertEqual "zero" (0, False) (decodeCompact 0x00000000) @@ -268,6 +260,7 @@ testCompactBitcoinCore = do "vector 9 (decode) (positive)" ((> 0) . fst $ decodeCompact 0xff123456) + runMerkleVector :: (Text, [Text]) -> Assertion runMerkleVector (r, hs) = assertBool "merkle vector" $ @@ -275,6 +268,7 @@ runMerkleVector (r, hs) = where f = fromJust . hexToTxHash + merkleVectors :: [(Text, [Text])] merkleVectors = -- Block 000000000000cd7e8cf6510303dde76121a1a791c15dba0be4be7022b07cf9e1 @@ -369,6 +363,7 @@ merkleVectors = ) ] + testSubsidy :: Network -> Assertion testSubsidy net = go (2 * 50 * 100 * 1000 * 1000) 0 where @@ -381,10 +376,13 @@ testSubsidy net = go (2 * 50 * 100 * 1000 * 1000) 0 subsidy `shouldBe` (previous_subsidy `div` 2) go subsidy (halvings + 1) + data AsertBlock = AsertBlock Int Integer Integer Word32 + data AsertVector = AsertVector String Integer Integer Word32 [AsertBlock] + readAsertVector :: FilePath -> IO AsertVector readAsertVector p = do (d : ah : apt : ab : _ : _ : _ : _ : xs) <- lines <$> readFile ("data/" ++ p) @@ -404,11 +402,13 @@ readAsertVector p = do 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 + testAsertBits :: AsertVector -> Assertion testAsertBits (AsertVector _ anchor_height anchor_parent_time anchor_bits blocks) = forM_ blocks $ \(AsertBlock _ h t g) -> diff --git a/test/Haskoin/Crypto/HashSpec.hs b/test/Haskoin/Crypto/HashSpec.hs index a97992c7..eb6dfc0b 100644 --- a/test/Haskoin/Crypto/HashSpec.hs +++ b/test/Haskoin/Crypto/HashSpec.hs @@ -25,6 +25,7 @@ import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck + serialVals :: [SerialBox] serialVals = [ SerialBox arbitraryBS @@ -33,6 +34,7 @@ serialVals = , SerialBox arbitraryHash512 ] + readVals :: [ReadBox] readVals = [ ReadBox arbitraryBS @@ -42,13 +44,15 @@ readVals = , 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 + forAll arbitraryHash256 $ + forAll arbitraryHash256 . joinSplit512 prop "decodeCompact . encodeCompact i == i" decEncCompact prop "from string Hash512" $ forAll arbitraryHash512 $ \h -> @@ -73,9 +77,11 @@ spec = it "Passes HMAC_SHA512 test vectors" $ mapM_ (testHMACVector hmac512 getHash512) hmacSha512Vectors + joinSplit512 :: Hash256 -> Hash256 -> Bool joinSplit512 a b = split512 (join512 (a, b)) == (a, b) + -- After encoding and decoding, we may loose precision so the new result is >= -- to the old one. decEncCompact :: Integer -> Bool @@ -87,6 +93,7 @@ decEncCompact i | 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 @@ -98,6 +105,7 @@ testVector :: testVector f1 f2 (i, res) = assertEqual "Hash matches" res (encodeHex (BSS.fromShort $ f2 $ f1 i)) + testHMACVector :: (ByteString -> ByteString -> a) -> (a -> BSS.ShortByteString) -> @@ -109,6 +117,7 @@ testHMACVector f1 f2 (k, m, res) = bsK = fromJust $ decodeHex k bsM = fromJust $ decodeHex m + longTestString :: ByteString longTestString = BL.toStrict $! toLazyByteString $! go [0 .. 199999] @@ -123,6 +132,7 @@ longTestString = i5 = fromIntegral $! i `shiftR` 16 in word8 i1 <> word8 i2 <> word8 i3 <> word8 i4 <> word8 i5 <> go is + ripemd160Vectors :: [(ByteString, Text)] ripemd160Vectors = [ ("", "9c1185a5c5e9fc54612808977ee8f548b2258d31") @@ -149,6 +159,7 @@ ripemd160Vectors = , (longTestString, "464243587bd146ea835cdf57bdae582f25ec45f1") ] + sha1Vectors :: [(ByteString, Text)] sha1Vectors = [ ("", "da39a3ee5e6b4b0d3255bfef95601890afd80709") @@ -175,6 +186,7 @@ sha1Vectors = , (longTestString, "b7755760681cbfd971451668f32af5774f4656b5") ] + sha256Vectors :: [(ByteString, Text)] sha256Vectors = [ ("", "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855") @@ -220,6 +232,7 @@ sha256Vectors = ) ] + sha512Vectors :: [(ByteString, Text)] sha512Vectors = [ @@ -280,6 +293,7 @@ sha512Vectors = ) ] + -- test cases 1, 2, 3, 4, 6 and 7 of RFC 4231 hmacSha256Vectors :: [(Text, Text, Text)] hmacSha256Vectors = @@ -349,6 +363,7 @@ hmacSha256Vectors = ) ] + -- test cases 1, 2, 3, 4, 6 and 7 of RFC 4231 hmacSha512Vectors :: [(Text, Text, Text)] hmacSha512Vectors = diff --git a/test/Haskoin/Crypto/SignatureSpec.hs b/test/Haskoin/Crypto/SignatureSpec.hs index 7de6d3df..9670b702 100644 --- a/test/Haskoin/Crypto/SignatureSpec.hs +++ b/test/Haskoin/Crypto/SignatureSpec.hs @@ -26,6 +26,7 @@ import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck + spec :: Spec spec = do describe "Signature properties" $ do @@ -33,9 +34,11 @@ spec = do forAll arbitrarySignature $ \(m, key', sig) -> verifyHashSig m sig (derivePubKey key') prop "s component less than half order" $ - forAll arbitrarySignature $ isCanonicalHalfOrder . lst3 + forAll arbitrarySignature $ + isCanonicalHalfOrder . lst3 prop "encoded signature is canonical" $ - forAll arbitrarySignature $ testIsCanonical . lst3 + forAll arbitrarySignature $ + testIsCanonical . lst3 prop "decodeStrictSig . exportSig identity" $ forAll arbitrarySignature $ (\s -> decodeStrictSig (exportSig s) == Just s) . lst3 @@ -59,6 +62,7 @@ spec = do it "builds a p2wsh multisig transaction" testP2WSHMulsig it "agrees with BIP143 p2sh-p2wsh multisig example" testBip143p2shp2wpkhMulsig + -- github.com/bitcoin/bitcoin/blob/master/src/script.cpp -- from function IsCanonicalSignature testIsCanonical :: Sig -> Bool @@ -117,6 +121,7 @@ testIsCanonical sig = rlen = BS.index s 3 slen = BS.index s (fromIntegral rlen + 5) + -- RFC6979 note: Different libraries of libsecp256k1 use different constants -- to produce a nonce. Thus, their deterministric signatures will be different. -- We still want to test against fixed signatures so we need a way to switch @@ -126,6 +131,7 @@ data ValidImpl = ImplCore | ImplABC + implSig :: Text implSig = encodeHex $ @@ -134,6 +140,7 @@ implSig = "0000000000000000000000000000000000000000000000000000000000000001" "0000000000000000000000000000000000000000000000000000000000000000" + -- We have test vectors for these cases validImplMap :: Map Text ValidImpl validImplMap = @@ -152,20 +159,25 @@ validImplMap = ) ] + getImpl :: Maybe ValidImpl getImpl = implSig `Map.lookup` validImplMap + rfc6979files :: ValidImpl -> (FilePath, FilePath) rfc6979files ImplCore = ("rfc6979core.json", "rfc6979DERcore.json") rfc6979files ImplABC = ("rfc6979abc.json", "rfc6979DERabc.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" + void $ + assertFailure "Invalid rfc6979 signature" + {- Trezor RFC 6979 Test Vectors -} -- github.com/trezor/python-ecdsa/blob/master/ecdsa/test_pyecdsa.py @@ -173,6 +185,7 @@ 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) @@ -183,6 +196,7 @@ testRFC6979Vector (prv, m, res) = do h = sha256 m s = signHash prv h + -- Test vectors from: -- https://crypto.stackexchange.com/questions/20838/request-for-data-to-test-deterministic-ecdsa-signature-algorithm-for-secp256k1 @@ -196,6 +210,7 @@ testRFC6979DERVector (prv, m, res) = do h = sha256 m s = signHash prv h + -- Reproduce the P2WPKH example from BIP 143 testBip143p2wpkh :: Assertion testBip143p2wpkh = @@ -249,6 +264,7 @@ testBip143p2wpkh = sigIn1 = SigInput (PayWitnessPKHash h) 600000000 op1 sigHashAll Nothing generatedSignedTx = signTx btc unsignedTx [sigIn0, sigIn1] [key0, key1] + -- Reproduce the P2SH-P2WPKH example from BIP 143 testBip143p2shp2wpkh :: Assertion testBip143p2shp2wpkh = @@ -290,6 +306,7 @@ testBip143p2shp2wpkh = sigIn0 = SigInput (PayWitnessPKHash h) 1000000000 op0 sigHashAll Nothing generatedSignedTx = signNestedWitnessTx btc unsignedTx [sigIn0] [key0] + -- P2WSH multisig example (tested against bitcoin-core 0.19.0.1) testP2WSHMulsig :: Assertion testP2WSHMulsig = @@ -346,6 +363,7 @@ testP2WSHMulsig = (Just rdm) generatedSignedTx = signTx btc unsignedTx [sigIn] (take 2 keys) + -- Reproduce the P2SH-P2WSH multisig example from BIP 143 testBip143p2shp2wpkhMulsig :: Assertion testBip143p2shp2wpkhMulsig = @@ -437,8 +455,10 @@ testBip143p2shp2wpkhMulsig = generatedSignedTx = foldM addSig unsignedTx $ zip sigIns keys addSig tx (sigIn', key') = signNestedWitnessTx btc tx [sigIn'] [key'] + secHexKey :: Text -> Maybe SecKey secHexKey = decodeHex >=> secKey + toPubKey :: SecKey -> PubKeyI toPubKey = derivePubKeyI . wrapSecKey True diff --git a/test/Haskoin/Keys/ExtendedSpec.hs b/test/Haskoin/Keys/ExtendedSpec.hs index 18591f9b..07be8b92 100644 --- a/test/Haskoin/Keys/ExtendedSpec.hs +++ b/test/Haskoin/Keys/ExtendedSpec.hs @@ -27,6 +27,7 @@ import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck hiding ((.&.)) + serialVals :: [SerialBox] serialVals = [ SerialBox arbitraryDerivPath @@ -34,6 +35,7 @@ serialVals = , SerialBox arbitrarySoftPath ] + readVals :: [ReadBox] readVals = [ ReadBox arbitraryDerivPath @@ -45,6 +47,7 @@ readVals = , ReadBox arbitraryBip32PathIndex ] + jsonVals :: [JsonBox] jsonVals = [ JsonBox arbitraryDerivPath @@ -53,6 +56,7 @@ jsonVals = , JsonBox arbitraryParsedPath ] + netVals :: [NetBox] netVals = [ NetBox @@ -69,6 +73,7 @@ netVals = ) ] + spec :: Spec spec = do testIdentity serialVals readVals jsonVals netVals @@ -94,13 +99,17 @@ spec = do it "to json" testToJsonPath describe "Derivation Paths" $ do prop "from string derivation path" $ - forAll arbitraryDerivPath $ \p -> fromString (cs $ pathToStr p) == p + forAll arbitraryDerivPath $ + \p -> fromString (cs $ pathToStr p) == p prop "from string hard derivation path" $ - forAll arbitraryHardPath $ \p -> fromString (cs $ pathToStr p) == p + forAll arbitraryHardPath $ + \p -> fromString (cs $ pathToStr p) == p prop "from string soft derivation path" $ - forAll arbitrarySoftPath $ \p -> fromString (cs $ pathToStr p) == p + forAll arbitrarySoftPath $ + \p -> fromString (cs $ pathToStr p) == p prop "from and to lists of derivation paths" $ - forAll arbitraryDerivPath $ \p -> listToPath (pathToList p) == p + 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 @@ -118,12 +127,14 @@ spec = do 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 @@ -134,6 +145,7 @@ testFromJsonPath = (Just [fromString path :: DerivPath]) (A.decode $ B8.pack $ "[\"" ++ path ++ "\"]") + testToJsonPath :: Assertion testToJsonPath = sequence_ $ do @@ -144,6 +156,7 @@ testToJsonPath = (B8.pack $ "[\"" ++ path ++ "\"]") (A.encode [fromString path :: ParsedPath]) + jsonPathVectors :: [String] jsonPathVectors = [ "m" @@ -158,12 +171,14 @@ jsonPathVectors = , "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) @@ -186,19 +201,25 @@ parsePathVectors = , ("NaN", isNothing) ] + testApplyPath :: Assertion testApplyPath = sequence_ $ do (key, path, final) <- applyPathVectors return $ - assertEqual path final $ applyPath (fromJust $ parsePath path) key + 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 + assertBool path $ + isLeft $ + applyPath (fromJust $ parsePath path) key + testDerivePubPath :: Assertion testDerivePubPath = @@ -208,6 +229,7 @@ testDerivePubPath = assertEqual path final $ derivePubPath (fromString path :: SoftPath) key + testDerivePrvPath :: Assertion testDerivePrvPath = sequence_ $ do @@ -216,6 +238,7 @@ testDerivePrvPath = assertEqual path final $ derivePath (fromString path :: DerivPath) key + derivePubPathVectors :: [(XPubKey, String, XPubKey)] derivePubPathVectors = [ (xpub, "M", xpub) @@ -231,6 +254,7 @@ derivePubPathVectors = \WzGmb8oageSRxBY8s4rjr9VXPVp2HQDbwPt4H31Gg4LpB" xpub = deriveXPubKey xprv + derivePrvPathVectors :: [(XPrvKey, String, XPrvKey)] derivePrvPathVectors = [ (xprv, "m", xprv) @@ -266,6 +290,7 @@ derivePrvPathVectors = "xprv9s21ZrQH143K46iDVRSyFfGfMgQjzC4BV3ZUfNbG7PHQrJjE53ofAn5gYkp6KQ\ \WzGmb8oageSRxBY8s4rjr9VXPVp2HQDbwPt4H31Gg4LpB" + applyPathVectors :: [(XKey, String, Either String XKey)] applyPathVectors = [ (XPrv xprv btc, "m", Right (XPrv xprv btc)) @@ -311,6 +336,7 @@ applyPathVectors = \WzGmb8oageSRxBY8s4rjr9VXPVp2HQDbwPt4H31Gg4LpB" xpub = deriveXPubKey xprv + badApplyPathVectors :: [(XKey, String)] badApplyPathVectors = [ (XPub xpub btc, "m/8'") @@ -326,17 +352,20 @@ badApplyPathVectors = \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 @@ -357,6 +386,7 @@ runVector m v = do 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 = @@ -376,6 +406,7 @@ genVector m = , ("Hex PrvKey", encodeHex (runPutS (putXPrvKey btc m))) ] + parseVector :: TestKey -> [TestVector] -> [(Text, XPrvKey, TestVector)] parseVector mTxt vs = go <$> vs @@ -386,12 +417,17 @@ parseVector mTxt vs = in (d, derivePath deriv mast, vec) go _ = undefined + type TestVector = [Text] + + type TestKey = Text + m1 :: TestKey m1 = "000102030405060708090a0b0c0d0e0f" + vector1 :: [TestVector] vector1 = [ @@ -486,9 +522,11 @@ vector1 = ] ] + m2 :: TestKey m2 = "fffcf9f6f3f0edeae7e4e1dedbd8d5d2cfccc9c6c3c0bdbab7b4b1aeaba8a5a29f9c999693908d8a8784817e7b7875726f6c696663605d5a5754514e4b484542" + vector2 :: [TestVector] vector2 = [ @@ -583,9 +621,11 @@ vector2 = ] ] + m3 :: TestKey m3 = "4b381541583be4423346c643850da4b320e46a87ae3d2a4e6da11eba819cd4acba45d239319ac14f863b8d5ab5a0d0c64d2e8a1e7d1457df2e5a3c51c73235be" + vector3 :: [TestVector] vector3 = [ diff --git a/test/Haskoin/Keys/MnemonicSpec.hs b/test/Haskoin/Keys/MnemonicSpec.hs index faeab484..1b1a85f4 100644 --- a/test/Haskoin/Keys/MnemonicSpec.hs +++ b/test/Haskoin/Keys/MnemonicSpec.hs @@ -19,6 +19,7 @@ import Test.HUnit import Test.Hspec import Test.QuickCheck hiding ((.&.)) + spec :: Spec spec = describe "mnemonic" $ do @@ -45,6 +46,7 @@ spec = it "get bits" $ property getBitsByteCount it "get end bits" $ property getBitsEndBits + toMnemonicTest :: Assertion toMnemonicTest = zipWithM_ f ents mss where @@ -55,6 +57,7 @@ toMnemonicTest = zipWithM_ f ents mss . fromJust . decodeHex + fromMnemonicTest :: Assertion fromMnemonicTest = zipWithM_ f ents mss where @@ -64,6 +67,7 @@ fromMnemonicTest = zipWithM_ f ents mss . fromRight (error "Could not decode mnemonic sentence") . fromMnemonic + mnemonicToSeedTest :: Assertion mnemonicToSeedTest = zipWithM_ f mss seeds where @@ -73,6 +77,7 @@ mnemonicToSeedTest = zipWithM_ f mss seeds . fromRight (error "Could not decode mnemonic seed") . mnemonicToSeed "TREZOR" + fromMnemonicInvalidTest :: Assertion fromMnemonicInvalidTest = mapM_ f invalidMss where @@ -81,6 +86,7 @@ fromMnemonicInvalidTest = mapM_ f invalidMss Right _ -> False Left err -> "fromMnemonic: checksum failed:" `isPrefixOf` err + emptyMnemonicTest :: Assertion emptyMnemonicTest = assertBool "" $ @@ -88,6 +94,7 @@ emptyMnemonicTest = Right _ -> False Left err -> "fromMnemonic: empty mnemonic" `isPrefixOf` err + ents :: [Text] ents = [ "00000000000000000000000000000000" @@ -116,6 +123,7 @@ ents = , "15da872c95a13dd738fbf50e427583ad61f18fd99f628c417a61cf8343c90419" ] + mss :: [Mnemonic] mss = [ "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ @@ -173,6 +181,7 @@ mss = \ coconut" ] + seeds :: [Text] seeds = [ "c55257c360c07c72029aebc1b53c05ed0362ada38ead3e3e9efa3708e53495531f09a69\ @@ -225,6 +234,7 @@ seeds = \86a96776b91946ff06f8eac594dc6ee1d3e82a42dfe1b40fef6bcc3fd" ] + invalidMss :: [Mnemonic] invalidMss = [ "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ @@ -282,11 +292,13 @@ invalidMss = \ 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 @@ -299,6 +311,7 @@ toMnemonic128 (a, b) = l == 12 . fromRight (error "Could not decode mnemonic senttence") $ toMnemonic bs + toMnemonic160 :: (Word32, Word64, Word64) -> Bool toMnemonic160 (a, b, c) = l == 15 where @@ -309,6 +322,7 @@ toMnemonic160 (a, b, c) = l == 15 . fromRight (error "Could not decode mnemonic sentence") $ toMnemonic bs + toMnemonic256 :: (Word64, Word64, Word64, Word64) -> Bool toMnemonic256 (a, b, c, d) = l == 24 where @@ -319,6 +333,7 @@ toMnemonic256 (a, b, c, d) = l == 24 . 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 @@ -340,6 +355,7 @@ toMnemonic512 ((a, b, c, d), (e, f, g, h)) = l == 48 . fromRight (error "Could not decode mnemonic sentence") $ toMnemonic bs + toMnemonicVar :: [Word32] -> Property toMnemonicVar ls = not (null ls) && length ls <= 8 ==> l == wc where @@ -348,10 +364,12 @@ toMnemonicVar ls = not (null ls) && length ls <= 8 ==> l == wc cb = bl `div` 4 wc = (cb + bl * 8) `div` 11 l = - length . T.words + length + . T.words . fromRight (error "Could not decode mnemonic sentence") $ toMnemonic bs + {- Encode/Decode -} fromToMnemonic128 :: (Word64, Word64) -> Bool @@ -363,6 +381,7 @@ fromToMnemonic128 (a, b) = bs == bs' (error "Could not decode mnemonic entropy") (fromMnemonic =<< toMnemonic bs) + fromToMnemonic160 :: (Word32, Word64, Word64) -> Bool fromToMnemonic160 (a, b, c) = bs == bs' where @@ -372,6 +391,7 @@ fromToMnemonic160 (a, b, c) = bs == bs' (error "Could not decode mnemonic entropy") (fromMnemonic =<< toMnemonic bs) + fromToMnemonic256 :: (Word64, Word64, Word64, Word64) -> Bool fromToMnemonic256 (a, b, c, d) = bs == bs' where @@ -381,6 +401,7 @@ fromToMnemonic256 (a, b, c, d) = bs == bs' (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' @@ -401,6 +422,7 @@ fromToMnemonic512 ((a, b, c, d), (e, f, g, h)) = bs == bs' (error "Could not decode mnemonic entropy") (fromMnemonic =<< toMnemonic bs) + fromToMnemonicVar :: [Word32] -> Property fromToMnemonicVar ls = not (null ls) && length ls <= 8 ==> bs == bs' where @@ -410,6 +432,7 @@ fromToMnemonicVar ls = not (null ls) && length ls <= 8 ==> bs == bs' (error "Could not decode mnemonic entropy") (fromMnemonic =<< toMnemonic bs) + {- Mnemonic to seed -} mnemonicToSeed128 :: (Word64, Word64) -> Bool @@ -422,6 +445,7 @@ mnemonicToSeed128 (a, b) = l == 64 (mnemonicToSeed "" =<< toMnemonic bs) l = BS.length seed + mnemonicToSeed160 :: (Word32, Word64, Word64) -> Bool mnemonicToSeed160 (a, b, c) = l == 64 where @@ -432,6 +456,7 @@ mnemonicToSeed160 (a, b, c) = l == 64 (mnemonicToSeed "" =<< toMnemonic bs) l = BS.length seed + mnemonicToSeed256 :: (Word64, Word64, Word64, Word64) -> Bool mnemonicToSeed256 (a, b, c, d) = l == 64 where @@ -442,6 +467,7 @@ mnemonicToSeed256 (a, b, c, d) = l == 64 (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 @@ -463,6 +489,7 @@ mnemonicToSeed512 ((a, b, c, d), (e, f, g, h)) = l == 64 (mnemonicToSeed "" =<< toMnemonic bs) l = BS.length seed + mnemonicToSeedVar :: [Word32] -> Property mnemonicToSeedVar ls = not (null ls) && length ls <= 16 ==> l == 64 where @@ -473,16 +500,19 @@ mnemonicToSeedVar ls = not (null ls) && length ls <= 16 ==> l == 64 (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 @@ -490,6 +520,7 @@ getBitsByteCount (ByteCountGen bs i) = BS.length bits == l 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) diff --git a/test/Haskoin/KeysSpec.hs b/test/Haskoin/KeysSpec.hs index 9407e0ce..8cc83550 100644 --- a/test/Haskoin/KeysSpec.hs +++ b/test/Haskoin/KeysSpec.hs @@ -29,11 +29,13 @@ import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck + serialVals :: [SerialBox] serialVals = [ SerialBox (snd <$> arbitraryKeyPair) -- PubKeyI ] + readVals :: [ReadBox] readVals = [ ReadBox (arbitrary :: Gen SecKey) @@ -41,11 +43,13 @@ readVals = , ReadBox (snd <$> arbitraryKeyPair) -- PubKeyI ] + jsonVals :: [JsonBox] jsonVals = [ JsonBox (snd <$> arbitraryKeyPair) -- PubKeyI ] + spec :: Spec spec = do testIdentity serialVals readVals jsonVals [] @@ -78,6 +82,7 @@ spec = do 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 @@ -97,6 +102,7 @@ isCanonicalPubKey p = where bs = runPutS $ serialize p + testMiniKey :: Assertion testMiniKey = assertEqual "fromMiniKey" (Just res) (go "S6c56bnXQiBjk9mqSYE7ykVQ7NzrRy") @@ -104,6 +110,7 @@ testMiniKey = 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 @@ -152,6 +159,7 @@ testKeyIOValidVector (a, payload, obj) "regtest" -> btcRegTest _ -> error "Invalid chain key in key_io_valid.json" + testKeyIOInvalidVector :: [Text] -> Assertion testKeyIOInvalidVector [a] = do let wifMs = (`fromWif` a) <$> allNets @@ -162,6 +170,7 @@ testKeyIOInvalidVector [a] = do 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 @@ -173,6 +182,7 @@ testPrivkey = do assertBool "Key 2C" $ isJust $ fromWif btc strSecret2C assertBool "Bad key" $ isNothing $ fromWif btc strAddressBad + testPrvKeyCompressed :: Assertion testPrvKeyCompressed = do assertBool "Key 1" $ not $ secKeyCompressed sec1 @@ -180,6 +190,7 @@ testPrvKeyCompressed = do assertBool "Key 1C" $ secKeyCompressed sec1C assertBool "Key 2C" $ secKeyCompressed sec2C + testKeyCompressed :: Assertion testKeyCompressed = do assertBool "Key 1" $ not $ pubKeyCompressed pub1 @@ -187,6 +198,7 @@ testKeyCompressed = do assertBool "Key 1C" $ pubKeyCompressed pub1C assertBool "Key 2C" $ pubKeyCompressed pub2C + testMatchingAddress :: Assertion testMatchingAddress = do assertEqual "Key 1" (Just addr1) $ addrToText btc (pubKeyAddr pub1) @@ -194,15 +206,18 @@ testMatchingAddress = do 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 @@ -226,6 +241,7 @@ testSignature h = do 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) @@ -238,27 +254,32 @@ testDetSigning = do (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 diff --git a/test/Haskoin/NetworkSpec.hs b/test/Haskoin/NetworkSpec.hs index 561b5fd5..684ddbd7 100644 --- a/test/Haskoin/NetworkSpec.hs +++ b/test/Haskoin/NetworkSpec.hs @@ -21,6 +21,7 @@ import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck + serialVals :: [SerialBox] serialVals = [ SerialBox arbitraryVarInt @@ -46,6 +47,7 @@ serialVals = , SerialBox arbitraryFilterAdd ] + spec :: Spec spec = do testIdentity serialVals [] [] [] @@ -62,11 +64,13 @@ spec = do it "Relevant Update" relevantOutputUpdated it "Irrelevant Update" irrelevantOutputNotUpdated + 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 + 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" $ @@ -82,12 +86,15 @@ bloomFilter n x = do v4 = fromJust $ decodeHex "b9300670b4c5366e95b2699e8b18bc75e5f729c5" bs = fromJust $ decodeHex x + bloomFilter1 :: Assertion bloomFilter1 = bloomFilter 0 "03614e9b050000000000000001" + bloomFilter2 :: Assertion bloomFilter2 = bloomFilter 2147483649 "03ce4299050000000100008001" + bloomFilter3 :: Assertion bloomFilter3 = assertBool "Bloom filter serialization is incorrect" $ @@ -100,6 +107,7 @@ bloomFilter3 = p = derivePubKeyI k bs = fromJust $ decodeHex "038fc16b080000000000000001" + relevantOutputUpdated :: Assertion relevantOutputUpdated = assertBool "Bloom filter output updated" $ @@ -111,6 +119,7 @@ relevantOutputUpdated = bf2 = fromJust $ bloomRelevantUpdate bf1 relevantTx spendTxInput = runPutS . serialize . prevOutput <$> txIn spendRelevantTx + irrelevantOutputNotUpdated :: Assertion irrelevantOutputNotUpdated = assertEqual "Bloom filter not updated" Nothing bf2 where @@ -119,6 +128,7 @@ irrelevantOutputNotUpdated = assertEqual "Bloom filter not updated" Nothing bf2 bf1 = bloomInsert bf0 relevantOutputHash bf2 = bloomRelevantUpdate bf1 unrelatedTx + -- Random transaction (57dc904f32ad4daab7b321dd469e8791ad09df784cdd273a73985150a4f225e9) relevantTx :: Tx relevantTx = @@ -139,6 +149,7 @@ relevantTx = , txLockTime = 0 } + -- Transaction that spends above (fd6e3b693b844aa431fad46765c1aa019a6b13aebfa9dae916b3ffa43283a300) spendRelevantTx :: Tx spendRelevantTx = @@ -164,6 +175,7 @@ spendRelevantTx = , txLockTime = 0 } + -- This random transaction is unrelated to the others unrelatedTx :: Tx unrelatedTx = diff --git a/test/Haskoin/ScriptSpec.hs b/test/Haskoin/ScriptSpec.hs index 5c3d07ff..3ef30eff 100644 --- a/test/Haskoin/ScriptSpec.hs +++ b/test/Haskoin/ScriptSpec.hs @@ -31,12 +31,14 @@ import Test.Hspec.QuickCheck import Test.QuickCheck import Text.Read + serialVals :: [SerialBox] serialVals = [ SerialBox arbitraryScriptOp , SerialBox arbitraryScript ] + readVals :: [ReadBox] readVals = [ ReadBox arbitrarySigHash @@ -47,6 +49,7 @@ readVals = , ReadBox (arbitraryScriptOutput =<< arbitraryNetwork) ] + jsonVals :: [JsonBox] jsonVals = [ JsonBox $ arbitraryScriptOutput =<< arbitraryNetwork @@ -55,31 +58,32 @@ jsonVals = , JsonBox $ fst <$> (arbitrarySigInput =<< arbitraryNetwork) ] + 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 + 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 + standardSpec :: Network -> Spec standardSpec net = do prop "has intToScriptOp . scriptOpToInt identity" $ @@ -104,7 +108,10 @@ standardSpec net = do `shouldBe` Right (RegularInput (SpendPK TxSignatureEmpty)) let pk = derivePubKeyI $ - wrapSecKey True $ fromJust $ secKey $ B.replicate 32 1 + 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]) @@ -112,6 +119,7 @@ standardSpec net = do decodeInput net (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") $ @@ -145,9 +153,12 @@ scriptSpec net = unless ("DISABLED" `isInfixOf` flags) $ do let _strict = - "DERSIG" `isInfixOf` flags - || "STRICTENC" `isInfixOf` flags - || "NULLDUMMY" `isInfixOf` flags + "DERSIG" + `isInfixOf` flags + || "STRICTENC" + `isInfixOf` flags + || "NULLDUMMY" + `isInfixOf` flags scriptSig = parseScript siStr scriptPubKey = parseScript soStr decodedOutput = decodeOutputBS scriptPubKey @@ -162,39 +173,6 @@ scriptSpec net = "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 creditTx :: ByteString -> Word64 -> Tx creditTx scriptPubKey val = @@ -208,6 +186,7 @@ creditTx scriptPubKey val = , txInSequence = maxBound } + spendTx :: ByteString -> Word64 -> ByteString -> Tx spendTx scriptPubKey val scriptSig = Tx 1 [txI] [txO] [] 0 @@ -220,6 +199,7 @@ spendTx scriptPubKey val scriptSig = , txInSequence = maxBound } + parseScript :: String -> ByteString parseScript str = B.concat $ fromMaybe err $ mapM f $ words str @@ -229,11 +209,13 @@ parseScript str = dropHex xs = xs err = error $ "Could not decode script: " <> str + replaceToken :: String -> String replaceToken str = case readMaybe $ "OP_" <> str of Just opcode -> "0x" <> cs (encodeHex $ runPutS $ serialize (opcode :: ScriptOp)) _ -> str + strictSigSpec :: Network -> Spec strictSigSpec net = when (getNetworkName net == "btc") $ do @@ -250,6 +232,7 @@ strictSigSpec net = forM_ vectors $ \sig -> decodeTxSig net sig `shouldSatisfy` isLeft + txSigHashSpec :: Network -> Spec txSigHashSpec net = when (getNetworkName net == "btc") $ @@ -276,30 +259,6 @@ txSigHashSpec net = =<< 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 sigHashSpec :: Network -> Spec sigHashSpec net = do @@ -307,31 +266,15 @@ sigHashSpec net = 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 + show (0xabac3344 :: SigHash) + `shouldBe` "SigHash " + <> show (0xabac3344 :: Word32) 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 @@ -351,12 +294,14 @@ sigHashSpec net = do decodeTxSig net (encodeTxSig ts) `shouldBe` Right ts it "can produce the sighash one" $ property $ - forAll (arbitraryTx net) $ forAll arbitraryScript . testSigHashOne net + forAll (arbitraryTx net) $ + 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) + not (null $ txIn tx) ==> + if length (txIn tx) > length (txOut tx) then res `shouldBe` one else res `shouldNotBe` one where @@ -367,6 +312,7 @@ testSigHashOne net tx s val acp = then setAnyoneCanPayFlag else id + {- Parse tests from bitcoin-qt repository -} mapMulSigVector :: ((Text, Text), Int) -> Spec @@ -375,6 +321,7 @@ mapMulSigVector (v, i) = where name = "check multisig vector " <> show i + runMulSigVector :: (Text, Text) -> Assertion runMulSigVector (a, ops) = assertBool "multisig vector" $ Just a == b where @@ -386,12 +333,14 @@ runMulSigVector (a, ops) = assertBool "multisig vector" $ Just a == b d <- eitherToMaybe $ decodeOutput o addrToText btc $ payToScriptAddress d + sigDecodeMap :: Network -> (Text, Int) -> Spec sigDecodeMap net (_, i) = it ("check signature " ++ show i) func where func = testSigDecode net $ scriptSigSignatures !! i + testSigDecode :: Network -> Text -> Assertion testSigDecode net str = let bs = fromJust $ decodeHex str @@ -404,6 +353,7 @@ testSigDecode net str = ) $ isRight eitherSig + mulSigVectors :: [(Text, Text)] mulSigVectors = [ @@ -418,6 +368,7 @@ mulSigVectors = ) ] + scriptSigSignatures :: [Text] scriptSigSignatures = -- Signature in input of txid @@ -434,6 +385,7 @@ scriptSigSignatures = -- \e18fe1e7d1510db501" ] + encodeScriptVector :: Assertion encodeScriptVector = assertEqual "Encode script" res (encodeHex $ runPutS $ serialize s) diff --git a/test/Haskoin/Transaction/PartialSpec.hs b/test/Haskoin/Transaction/PartialSpec.hs index a1c92223..6977dbe2 100644 --- a/test/Haskoin/Transaction/PartialSpec.hs +++ b/test/Haskoin/Transaction/PartialSpec.hs @@ -2,7 +2,11 @@ module Haskoin.Transaction.PartialSpec (spec) where +import Control.Monad ((<=<)) +import Data.Aeson (FromJSON, parseJSON, withObject, (.:)) +import Data.Bifunctor (first) import Data.ByteString (ByteString) +import Data.ByteString.Base64 (decodeBase64) import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial @@ -11,14 +15,6 @@ import Data.HashMap.Strict (fromList, singleton) import Data.Maybe (fromJust, isJust) import Data.Serialize as S import Data.Text (Text) -import Test.HUnit (Assertion, assertBool, assertEqual) -import Test.Hspec -import Test.QuickCheck - -import Control.Monad ((<=<)) -import Data.Aeson (FromJSON, parseJSON, withObject, (.:)) -import Data.Bifunctor (first) -import Data.ByteString.Base64 (decodeBase64) import qualified Data.Text as Text import Data.Text.Encoding (encodeUtf8) import Haskoin.Address @@ -31,6 +27,10 @@ import Haskoin.Transaction import Haskoin.Util import Haskoin.Util.Arbitrary import Haskoin.UtilSpec (readTestFile) +import Test.HUnit (Assertion, assertBool, assertEqual) +import Test.Hspec +import Test.QuickCheck + spec :: Spec spec = describe "partially signed bitcoin transaction unit tests" $ do @@ -45,7 +45,8 @@ spec = describe "partially signed bitcoin transaction unit tests" $ do it "encodes valid bip vecs" $ mapM_ (uncurry encodeVecTest) validEncodeVec it "decodes valid bip vecs" $ - mapM_ (uncurry decodeVecTest) $ zip [1 ..] validVec + mapM_ (uncurry decodeVecTest) $ + zip [1 ..] validVec it "decodes vector 2" vec2Test it "decodes vector 3" vec3Test it "decodes vector 4" vec4Test @@ -53,15 +54,18 @@ spec = describe "partially signed bitcoin transaction unit tests" $ do it "decodes vector 6" vec6Test it "signed and finalized p2pkh PSBTs verify" $ property $ - forAll arbitraryKeyPair $ verifyNonWitnessPSBT btc . unfinalizedPkhPSBT btc + forAll arbitraryKeyPair $ + verifyNonWitnessPSBT btc . unfinalizedPkhPSBT btc it "signed and finalized multisig PSBTs verify" $ property $ - forAll arbitraryMultiSig $ verifyNonWitnessPSBT btc . unfinalizedMsPSBT btc + forAll arbitraryMultiSig $ + verifyNonWitnessPSBT btc . unfinalizedMsPSBT btc it "encodes and decodes psbt with final witness script" $ (fmap (encodeHex . S.encode) . decodeHexPSBT) validVec7Hex == Right validVec7Hex it "handles complex psbts correctly" complexPsbtTest it "calculates keys properly" psbtSignerTest + vec2Test :: Assertion vec2Test = do psbt <- decodeHexPSBTM "Cannot parse validVec2" validVec2Hex @@ -79,6 +83,7 @@ vec2Test = do mapM_ (assertEqual "outputs are empty" emptyOutput) (outputs psbt) + vec3Test :: Assertion vec3Test = do psbt <- decodeHexPSBTM "Cannot parse validVec3" validVec3Hex @@ -97,6 +102,7 @@ vec3Test = do assertBool "p2pkh" $ isPayPKHash prevOutputKey assertEqual "sighash type" sigHashAll (fromJust $ sigHashType firstInput) + vec4Test :: Assertion vec4Test = do psbt <- decodeHexPSBTM "Cannot parse validVec4" validVec4Hex @@ -117,6 +123,7 @@ vec4Test = do assertBool "all non-empty outputs" $ emptyOutput `notElem` outputs psbt + vec5Test :: Assertion vec5Test = do psbt <- decodeHexPSBTM "Cannot parse validVec5" validVec5Hex @@ -229,6 +236,7 @@ vec5Test = do } hardIndex = (+ 2 ^ 31) + vec6Test :: Assertion vec6Test = do psbt <- decodeHexPSBTM "Cannot parse validVec6" validVec6Hex @@ -246,6 +254,7 @@ vec6Test = do (Key 0x0f (fromJust $ decodeHex "010203040506070809")) (fromJust $ decodeHex "0102030405060708090a0b0c0d0e0f") + complexPsbtTest :: Assertion complexPsbtTest = do complexPsbtData <- readTestFile "complex_psbt.json" @@ -266,6 +275,7 @@ complexPsbtTest = do | Just{} <- witnessUtxo input = input{nonWitnessUtxo = Nothing} | otherwise = input + psbtSignerTest :: Assertion psbtSignerTest = do assertEqual "recover explicit secret key" (Just theSecKey) (getSignerKey signer thePubKey Nothing) @@ -298,6 +308,7 @@ psbtSignerTest = do directPathSecKey = xPrvKey $ derivePath directPath xprv directPathPubKey = PubKeyI{pubKeyPoint = derivePubKey directPathSecKey, pubKeyCompressed = True} + expectedOut :: ScriptOutput expectedOut = fromRight (error "could not decode expected output") @@ -305,6 +316,7 @@ expectedOut = . fromJust $ decodeHex "a9143545e6e33b832c47050f24d3eeb93c9c03948bc787" + witnessScriptPubKey :: Input -> ScriptOutput witnessScriptPubKey = fromRight (error "could not decode witness utxo") @@ -313,12 +325,15 @@ witnessScriptPubKey = . fromJust . witnessUtxo + decodeHexPSBT :: Text -> Either String PartiallySignedTransaction decodeHexPSBT = S.decode . fromJust . decodeHex + decodeHexPSBTM :: (Monad m, MonadFail m) => String -> Text -> m PartiallySignedTransaction decodeHexPSBTM errMsg = either (fail . (errMsg <>) . (": " <>)) return . decodeHexPSBT + hexScript :: Text -> ByteString hexScript = either (error "Could not decode script") encodeScript @@ -329,15 +344,19 @@ hexScript = encodeScript :: Script -> ByteString encodeScript = runPutS . serialize + invalidVecTest :: Text -> Assertion invalidVecTest = assertBool "invalid psbt" . isLeft . decodeHexPSBT + decodeVecTest :: Int -> Text -> Assertion decodeVecTest i = assertBool (show i <> " decodes correctly") . isRight . decodeHexPSBT + encodeVecTest :: PartiallySignedTransaction -> Text -> Assertion encodeVecTest psbt hex = assertEqual "encodes correctly" (S.encode psbt) (fromJust $ decodeHex hex) + trivialPSBT :: PartiallySignedTransaction trivialPSBT = PartiallySignedTransaction @@ -347,12 +366,15 @@ trivialPSBT = , outputs = [] } + trivialPSBTHex :: Text trivialPSBTHex = "70736274ff01000a0200000000000000000000" + nonEmptyTransactionPSBT :: PartiallySignedTransaction nonEmptyTransactionPSBT = emptyPSBT testTx1 + verifyNonWitnessPSBT :: Network -> PartiallySignedTransaction -> Bool verifyNonWitnessPSBT net psbt = verifyStdTx net (finalTransaction (complete psbt)) sigData where @@ -363,6 +385,7 @@ verifyNonWitnessPSBT net psbt = verifyStdTx net (finalTransaction (complete psbt (\(TxOut val script) -> (decodeOutScript script, val, prevOutput txInput)) (txOut . fromJust $ nonWitnessUtxo input) + unfinalizedPkhPSBT :: Network -> (SecKeyI, PubKeyI) -> PartiallySignedTransaction unfinalizedPkhPSBT net (prvKey, pubKey) = (emptyPSBT currTx) @@ -380,12 +403,14 @@ unfinalizedPkhPSBT net (prvKey, pubKey) = h = txSigHash net currTx prevOutScript (outValue prevOut) 0 sigHashAll sig = encodeTxSig $ TxSignature (signHash (secKeyData prvKey) h) sigHashAll + arbitraryMultiSig :: Gen ([(SecKeyI, PubKeyI)], Int) arbitraryMultiSig = do (m, n) <- arbitraryMSParam keys <- vectorOf n arbitraryKeyPair return (keys, m) + unfinalizedMsPSBT :: Network -> ([(SecKeyI, PubKeyI)], Int) -> PartiallySignedTransaction unfinalizedMsPSBT net (keys, m) = (emptyPSBT currTx) @@ -406,6 +431,7 @@ unfinalizedMsPSBT net (keys, m) = sigs = fromList $ map sig keys sig (prvKey, pubKey) = (pubKey, encodeTxSig $ TxSignature (signHash (secKeyData prvKey) h) sigHashAll) + unfinalizedTx :: TxHash -> Tx unfinalizedTx prevHash = Tx @@ -425,6 +451,7 @@ unfinalizedTx prevHash = , txLockTime = 1257139 } + invalidVec :: [Text] invalidVec = [ "0200000001268171371edff285e937adeea4b37b78000c0566cbb3ad64641713ca42171bf6000000006a473044022070b2245123e6bf474d60c5b50c043d4c691a5d2435f09a34a7662a9dc251790a022001329ca9dacf280bdf30740ec0390422422c81cb45839457aeb76fc12edd95b3012102657d118d3357b8e0f4c2cd46db7b39f6d9c38d9a70abcb9b2de5dc8dbfe4ce31feffffff02d3dff505000000001976a914d0c59903c5bac2868760e90fd521a4665aa7652088ac00e1f5050000000017a9143545e6e33b832c47050f24d3eeb93c9c03948bc787b32e1300" @@ -447,9 +474,11 @@ invalidVec = , "70736274ff0100730200000001301ae986e516a1ec8ac5b4bc6573d32f83b465e23ad76167d68b38e730b4dbdb0000000000ffffffff02747b01000000000017a91403aa17ae882b5d0d54b25d63104e4ffece7b9ea2876043993b0000000017a914b921b1ba6f722e4bfa83b6557a3139986a42ec8387000000000001011f00ca9a3b00000000160014d2d94b64ae08587eefc8eeb187c601e939f9037c00010016001462e9e982fff34dd8239610316b090cd2a3b747cb000100220020876bad832f1d168015ed41232a9ea65a1815d9ef13c0ef8759f64b5b2b278a6521010025512103b7ce23a01c5b4bf00a642537cdfabb315b668332867478ef51309d2bd57f8a8751ae00" ] + validEncodeVec :: [(PartiallySignedTransaction, Text)] validEncodeVec = [(validVec1, validVec1Hex)] + testTx1 :: Tx testTx1 = Tx @@ -469,6 +498,7 @@ testTx1 = , txLockTime = 1257139 } + testUtxo :: [TxOut] -> Tx testUtxo prevOuts = Tx @@ -499,6 +529,7 @@ testUtxo prevOuts = , txLockTime = 0 } + testUtxo1 :: Tx testUtxo1 = testUtxo @@ -506,34 +537,44 @@ testUtxo1 = , TxOut{outValue = 190303501938, scriptOutput = hexScript "a914339725ba21efd62ac753a9bcd067d6c7a6a39d0587"} ] + validVec1 :: PartiallySignedTransaction validVec1 = (emptyPSBT testTx1){inputs = [emptyInput{nonWitnessUtxo = Just testUtxo1}]} + validVec :: [Text] validVec = [validVec1Hex, validVec2Hex, validVec3Hex, validVec4Hex, validVec5Hex, validVec6Hex] + validVec1Hex :: Text validVec1Hex = "70736274ff0100750200000001268171371edff285e937adeea4b37b78000c0566cbb3ad64641713ca42171bf60000000000feffffff02d3dff505000000001976a914d0c59903c5bac2868760e90fd521a4665aa7652088ac00e1f5050000000017a9143545e6e33b832c47050f24d3eeb93c9c03948bc787b32e1300000100fda5010100000000010289a3c71eab4d20e0371bbba4cc698fa295c9463afa2e397f8533ccb62f9567e50100000017160014be18d152a9b012039daf3da7de4f53349eecb985ffffffff86f8aa43a71dff1448893a530a7237ef6b4608bbb2dd2d0171e63aec6a4890b40100000017160014fe3e9ef1a745e974d902c4355943abcb34bd5353ffffffff0200c2eb0b000000001976a91485cff1097fd9e008bb34af709c62197b38978a4888ac72fef84e2c00000017a914339725ba21efd62ac753a9bcd067d6c7a6a39d05870247304402202712be22e0270f394f568311dc7ca9a68970b8025fdd3b240229f07f8a5f3a240220018b38d7dcd314e734c9276bd6fb40f673325bc4baa144c800d2f2f02db2765c012103d2e15674941bad4a996372cb87e1856d3652606d98562fe39c5e9e7e413f210502483045022100d12b852d85dcd961d2f5f4ab660654df6eedcc794c0c33ce5cc309ffb5fce58d022067338a8e0e1725c197fb1a88af59f51e44e4255b20167c8684031c05d1f2592a01210223b72beef0965d10be0778efecd61fcac6f79a4ea169393380734464f84f2ab300000000000000" + validVec2Hex :: Text validVec2Hex = "70736274ff0100a00200000002ab0949a08c5af7c49b8212f417e2f15ab3f5c33dcf153821a8139f877a5b7be40000000000feffffffab0949a08c5af7c49b8212f417e2f15ab3f5c33dcf153821a8139f877a5b7be40100000000feffffff02603bea0b000000001976a914768a40bbd740cbe81d988e71de2a4d5c71396b1d88ac8e240000000000001976a9146f4620b553fa095e721b9ee0efe9fa039cca459788ac000000000001076a47304402204759661797c01b036b25928948686218347d89864b719e1f7fcf57d1e511658702205309eabf56aa4d8891ffd111fdf1336f3a29da866d7f8486d75546ceedaf93190121035cdc61fc7ba971c0b501a646a2a83b102cb43881217ca682dc86e2d73fa882920001012000e1f5050000000017a9143545e6e33b832c47050f24d3eeb93c9c03948bc787010416001485d13537f2e265405a34dbafa9e3dda01fb82308000000" + validVec3Hex :: Text validVec3Hex = "70736274ff0100750200000001268171371edff285e937adeea4b37b78000c0566cbb3ad64641713ca42171bf60000000000feffffff02d3dff505000000001976a914d0c59903c5bac2868760e90fd521a4665aa7652088ac00e1f5050000000017a9143545e6e33b832c47050f24d3eeb93c9c03948bc787b32e1300000100fda5010100000000010289a3c71eab4d20e0371bbba4cc698fa295c9463afa2e397f8533ccb62f9567e50100000017160014be18d152a9b012039daf3da7de4f53349eecb985ffffffff86f8aa43a71dff1448893a530a7237ef6b4608bbb2dd2d0171e63aec6a4890b40100000017160014fe3e9ef1a745e974d902c4355943abcb34bd5353ffffffff0200c2eb0b000000001976a91485cff1097fd9e008bb34af709c62197b38978a4888ac72fef84e2c00000017a914339725ba21efd62ac753a9bcd067d6c7a6a39d05870247304402202712be22e0270f394f568311dc7ca9a68970b8025fdd3b240229f07f8a5f3a240220018b38d7dcd314e734c9276bd6fb40f673325bc4baa144c800d2f2f02db2765c012103d2e15674941bad4a996372cb87e1856d3652606d98562fe39c5e9e7e413f210502483045022100d12b852d85dcd961d2f5f4ab660654df6eedcc794c0c33ce5cc309ffb5fce58d022067338a8e0e1725c197fb1a88af59f51e44e4255b20167c8684031c05d1f2592a01210223b72beef0965d10be0778efecd61fcac6f79a4ea169393380734464f84f2ab30000000001030401000000000000" + validVec4Hex :: Text validVec4Hex = "70736274ff0100a00200000002ab0949a08c5af7c49b8212f417e2f15ab3f5c33dcf153821a8139f877a5b7be40000000000feffffffab0949a08c5af7c49b8212f417e2f15ab3f5c33dcf153821a8139f877a5b7be40100000000feffffff02603bea0b000000001976a914768a40bbd740cbe81d988e71de2a4d5c71396b1d88ac8e240000000000001976a9146f4620b553fa095e721b9ee0efe9fa039cca459788ac00000000000100df0200000001268171371edff285e937adeea4b37b78000c0566cbb3ad64641713ca42171bf6000000006a473044022070b2245123e6bf474d60c5b50c043d4c691a5d2435f09a34a7662a9dc251790a022001329ca9dacf280bdf30740ec0390422422c81cb45839457aeb76fc12edd95b3012102657d118d3357b8e0f4c2cd46db7b39f6d9c38d9a70abcb9b2de5dc8dbfe4ce31feffffff02d3dff505000000001976a914d0c59903c5bac2868760e90fd521a4665aa7652088ac00e1f5050000000017a9143545e6e33b832c47050f24d3eeb93c9c03948bc787b32e13000001012000e1f5050000000017a9143545e6e33b832c47050f24d3eeb93c9c03948bc787010416001485d13537f2e265405a34dbafa9e3dda01fb8230800220202ead596687ca806043edc3de116cdf29d5e9257c196cd055cf698c8d02bf24e9910b4a6ba670000008000000080020000800022020394f62be9df19952c5587768aeb7698061ad2c4a25c894f47d8c162b4d7213d0510b4a6ba6700000080010000800200008000" + validVec5Hex :: Text validVec5Hex = "70736274ff0100550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac0000000000010120955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87220203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4646304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a010104220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681010547522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae220603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4610b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000" + validVec6Hex :: Text validVec6Hex = "70736274ff01003f0200000001ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff0000000000ffffffff010000000000000000036a010000000000000a0f0102030405060708090f0102030405060708090a0b0c0d0e0f0000" + -- Example of a PSBT with a `finalWitnessScript` validVec7Hex :: Text validVec7Hex = "70736274ff0100520200000001815dd29e16fd2f567a040ce24f5337fb9cfd0c05bacd8890714a33edc7cbbc920000000000ffffffff0192f1052a01000000160014ef9ade26f63015d57f4ecdb268d1a9b8d6cd8872000000000001008402000000010000000000000000000000000000000000000000000000000000000000000000ffffffff03510101ffffffff0200f2052a010000001600145f4ffa19dbbe464561c50fc4d8d8ac0b41009dd20000000000000000266a24aa21a9ede2f61c3f71d1defd3fa999dfa36953755c690689799962b48bebd836974e8cf90000000001011f00f2052a010000001600145f4ffa19dbbe464561c50fc4d8d8ac0b41009dd201086b02473044022026a9f7afdb0128970bb3577e536ec3d3dc10c1e82650d11c9da1df9003b31d0202202258b11f962f12e0897c642cd6f38a0181db17197f3693a530c9431eb44dde7d0121033dc786e9628bb6c41c08fceb9b37458ad7a95e7e6b04e0bde45b6879398c3ac100220203a6affb58dda998a4ffdce652feb91038fdfc78c748ae687372e11292af8d312d101c4c5bfc00000080000000800100008000" + data ComplexPsbtData = ComplexPsbtData { complexSignedPsbts :: [PartiallySignedTransaction] , complexCombinedPsbt :: PartiallySignedTransaction @@ -542,6 +583,7 @@ data ComplexPsbtData = ComplexPsbtData } deriving (Eq, Show) + instance FromJSON ComplexPsbtData where parseJSON = withObject "ComplexPsbtData" $ \obj -> do ComplexPsbtData diff --git a/test/Haskoin/Transaction/TaprootSpec.hs b/test/Haskoin/Transaction/TaprootSpec.hs index 3a85b472..3f481eaf 100644 --- a/test/Haskoin/Transaction/TaprootSpec.hs +++ b/test/Haskoin/Transaction/TaprootSpec.hs @@ -42,6 +42,7 @@ import Haskoin.UtilSpec (readTestFile) import Test.HUnit (assertBool, (@?=)) import Test.Hspec (Spec, describe, it, runIO) + spec :: Spec spec = do TestVector{testScriptPubKey} <- runIO $ readTestFile "bip341.json" @@ -52,6 +53,7 @@ spec = do it "should calculate the correct control blocks" $ mapM_ testControlBlocks testScriptPubKey it "should arrive at the correct address" $ mapM_ testAddress testScriptPubKey + testHashes :: TestScriptPubKey -> IO () testHashes testData = mapM_ checkMASTDetails $ (taprootMAST . tspkGiven) testData @@ -67,6 +69,7 @@ testHashes testData = leaf@MASTLeaf{} -> [BA.convert $ mastCommitment leaf] MASTCommitment{} -> mempty -- The test vectors have complete trees + testOutputKey :: TestScriptPubKey -> IO () testOutputKey testData = do XOnlyPubKey (taprootOutputKey theOutput) @?= theOutputKey @@ -74,10 +77,12 @@ testOutputKey testData = do theOutput = tspkGiven testData theOutputKey = XOnlyPubKey . spkiTweakedPubKey $ tspkIntermediary testData + testScriptOutput :: TestScriptPubKey -> IO () testScriptOutput testData = taprootScriptOutput (tspkGiven testData) @?= (spkeScriptPubKey . tspkExpected) testData + testControlBlocks :: TestScriptPubKey -> IO () testControlBlocks testData = do mapM_ onExamples exampleControlBlocks @@ -105,18 +110,22 @@ testControlBlocks testData = do onExamples = zipWithM (@?=) calculatedControlBlocks checkVerification = assertBool "Script verifies" . verifyScriptPathData theOutputKey + keyParity :: PubKey -> Word8 keyParity key = case BS.unpack . runPutS . serialize $ PubKeyI key True of 0x02 : _ -> 0x00 _ -> 0x01 + testAddress :: TestScriptPubKey -> IO () testAddress testData = computedAddress @?= (Just . spkeAddress . tspkExpected) testData where computedAddress = (addrToText btc <=< outputAddress) . taprootScriptOutput $ tspkGiven testData + newtype SpkGiven = SpkGiven {unSpkGiven :: TaprootOutput} + instance FromJSON SpkGiven where parseJSON = withObject "SpkGiven" $ \obj -> fmap SpkGiven $ @@ -138,12 +147,14 @@ instance FromJSON SpkGiven where _ -> fail "ScriptTree branch" hexScript = either fail pure . runGetS deserialize <=< jsonHex + data SpkIntermediary = SpkIntermediary { spkiLeafHashes :: Maybe [ByteString] , spkiMerkleRoot :: Maybe ByteString , spkiTweakedPubKey :: PubKey } + instance FromJSON SpkIntermediary where parseJSON = withObject "SpkIntermediary" $ \obj -> SpkIntermediary @@ -151,12 +162,14 @@ instance FromJSON SpkIntermediary where <*> (obj .: "merkleRoot" >>= traverse jsonHex) <*> (xOnlyPubKey <$> obj .: "tweakedPubkey") + data SpkExpected = SpkExpected { spkeScriptPubKey :: ScriptOutput , spkeControlBlocks :: Maybe [ByteString] , spkeAddress :: Text } + instance FromJSON SpkExpected where parseJSON = withObject "SpkExpected" $ \obj -> SpkExpected @@ -164,12 +177,14 @@ instance FromJSON SpkExpected where <*> (obj .:? "scriptPathControlBlocks" >>= (traverse . traverse) jsonHex) <*> obj .: "bip350Address" + data TestScriptPubKey = TestScriptPubKey { tspkGiven :: TaprootOutput , tspkIntermediary :: SpkIntermediary , tspkExpected :: SpkExpected } + instance FromJSON TestScriptPubKey where parseJSON = withObject "TestScriptPubKey" $ \obj -> TestScriptPubKey @@ -177,13 +192,16 @@ instance FromJSON TestScriptPubKey where <*> obj .: "intermediary" <*> obj .: "expected" + newtype TestVector = TestVector { testScriptPubKey :: [TestScriptPubKey] } + instance FromJSON TestVector where parseJSON = withObject "TestVector" $ \obj -> TestVector <$> obj .: "scriptPubKey" + jsonHex :: Text -> Parser ByteString jsonHex = maybe (fail "Unable to decode hex") pure . decodeHex diff --git a/test/Haskoin/TransactionSpec.hs b/test/Haskoin/TransactionSpec.hs index 473668fc..a06472df 100644 --- a/test/Haskoin/TransactionSpec.hs +++ b/test/Haskoin/TransactionSpec.hs @@ -25,6 +25,7 @@ import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck + serialVals :: [SerialBox] serialVals = [ SerialBox $ arbitraryTx =<< arbitraryNetwork @@ -35,6 +36,7 @@ serialVals = , SerialBox arbitraryOutPoint ] + readVals :: [ReadBox] readVals = [ ReadBox arbitraryTxHash @@ -44,6 +46,7 @@ readVals = , ReadBox arbitraryOutPoint ] + jsonVals :: [JsonBox] jsonVals = [ JsonBox arbitraryTxHash @@ -55,6 +58,7 @@ jsonVals = , JsonBox arbitraryOutPoint ] + spec :: Spec spec = do testIdentity serialVals readVals jsonVals [] @@ -93,6 +97,7 @@ spec = do it "build pkhash transaction (generated from bitcoind)" $ mapM_ testPKHashVector pkHashVectors + -- Txid Vectors testTxidVector :: (Text, Text) -> Assertion @@ -101,6 +106,7 @@ testTxidVector (tid, tx) = where txM = eitherToMaybe . runGetS deserialize =<< decodeHex tx + txidVectors :: [(Text, Text)] txidVectors = [ @@ -161,6 +167,7 @@ txidVectors = ) ] + -- Build address transactions vectors generated from bitcoin-core raw tx API testPKHashVector :: ([(Text, Word32)], [(Text, Word64)], Text) -> Assertion @@ -173,6 +180,7 @@ testPKHashVector (is, os, res) = txE = buildAddrTx btc (map f is) os f (tid, ix) = OutPoint (fromJust $ hexToTxHash tid) ix + pkHashVectors :: [([(Text, Word32)], [(Text, Word64)], Text)] pkHashVectors = [ @@ -236,6 +244,7 @@ pkHashVectors = ) ] + -- Transaction Properties -- testBuildAddrTx :: Network -> Address -> TestCoin -> Bool @@ -251,6 +260,7 @@ testBuildAddrTx net a (TestCoin v) head $ txOut (fromRight (error "Could not build transaction") tx) + -- We compute an upper bound but it should be close enough to the real size -- We give 2 bytes of slack on every signature (1 on r and 1 on s) testGuessSize :: Network -> Tx -> Bool @@ -279,6 +289,7 @@ testGuessSize net tx = pkout = length $ filter isPayPKHash out msout = length $ filter isPayScriptHash out + testChooseCoins :: [TestCoin] -> Word64 -> Word64 -> Int -> Property testChooseCoins coins target byteFee nOut = nOut >= 0 ==> @@ -293,6 +304,7 @@ testChooseCoins coins target byteFee nOut = where s = sum $ map coinValue coins + testChooseMSCoins :: (Int, Int) -> [TestCoin] -> @@ -313,6 +325,7 @@ testChooseMSCoins (m, n) coins target byteFee nOut = where s = sum $ map coinValue coins + {- Signing Transactions -} testDetSignTx :: Network -> (Tx, [SigInput], [SecKeyI]) -> Bool @@ -329,6 +342,7 @@ testDetSignTx net (tx, sigis, prv) = signTx net txSigP sigis [secKeyData (head prv)] verData = map (\(SigInput s v o _ _) -> (s, v, o)) sigis + testDetSignNestedTx :: Network -> (Tx, [SigInput], [SecKeyI]) -> Bool testDetSignNestedTx net (tx, sigis, prv) = not (verifyStdTx net tx verData) @@ -346,6 +360,7 @@ testDetSignNestedTx net (tx, sigis, prv) = | isSegwit s = (toP2SH $ encodeOutput s, v, o) | otherwise = (s, v, o) + testMergeTx :: Network -> ([Tx], [(ScriptOutput, Word64, OutPoint, Int, Int)]) -> Bool testMergeTx net (txs, os) = and diff --git a/test/Haskoin/UtilSpec.hs b/test/Haskoin/UtilSpec.hs index 039a22b8..3bb3ee09 100644 --- a/test/Haskoin/UtilSpec.hs +++ b/test/Haskoin/UtilSpec.hs @@ -22,6 +22,7 @@ import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck + spec :: Spec spec = describe "utility functions" $ do @@ -33,18 +34,22 @@ spec = 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 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) + testMatchTemplate :: [Int] -> Int -> Bool testMatchTemplate as i = catMaybes res == bs where @@ -55,24 +60,29 @@ testMatchTemplate as i = catMaybes res == bs else i `mod` length as bs = permutations as !! idx + testMatchTemplateLen :: [Int] -> [Int] -> Bool testMatchTemplateLen as bs = length bs == length res where res = matchTemplate as bs (==) + testEitherToMaybe :: Either String Int -> Bool testEitherToMaybe (Right v) = eitherToMaybe (Right v) == Just v 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 diff --git a/test/Spec.hs b/test/Spec.hs index a824f8c3..038e7c8e 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1 +1,2 @@ {-# OPTIONS_GHC -F -pgmF hspec-discover #-} +