diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,11 @@ 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.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. diff --git a/haskoin-core.cabal b/haskoin-core.cabal --- a/haskoin-core.cabal +++ b/haskoin-core.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: ad4c6376deb0bf12b7271c03f9d6602888452d75a32a16f711ef2f018b500a10 +-- hash: bd9822c23e8579ff68357d7e634d820b25e23e1d6ce81b019ebb8e96bc872370 name: haskoin-core -version: 0.13.1 +version: 0.13.2 synopsis: Bitcoin & Bitcoin Cash library for Haskell description: Haskoin Core is a complete Bitcoin and Bitcoin Cash library of functions and data types for Haskell developers. category: Bitcoin, Finance, Network @@ -37,38 +37,38 @@ library exposed-modules: Haskoin + Haskoin.Address + Haskoin.Block + Haskoin.Constants + Haskoin.Crypto + Haskoin.Keys + Haskoin.Network + Haskoin.Script + Haskoin.Transaction + Haskoin.Util other-modules: - Network.Haskoin.Address - Network.Haskoin.Address.Base58 - Network.Haskoin.Address.Bech32 - Network.Haskoin.Address.CashAddr - Network.Haskoin.Block - Network.Haskoin.Block.Common - Network.Haskoin.Block.Headers - Network.Haskoin.Block.Merkle - Network.Haskoin.Constants - Network.Haskoin.Crypto - Network.Haskoin.Crypto.Hash - Network.Haskoin.Crypto.Signature - Network.Haskoin.Keys - Network.Haskoin.Keys.Common - Network.Haskoin.Keys.Extended - Network.Haskoin.Keys.Mnemonic - Network.Haskoin.Network - Network.Haskoin.Network.Bloom - Network.Haskoin.Network.Common - Network.Haskoin.Network.Message - Network.Haskoin.Script - Network.Haskoin.Script.Common - Network.Haskoin.Script.SigHash - Network.Haskoin.Script.Standard - Network.Haskoin.Transaction - Network.Haskoin.Transaction.Builder - Network.Haskoin.Transaction.Builder.Sign - Network.Haskoin.Transaction.Common - Network.Haskoin.Transaction.Partial - Network.Haskoin.Transaction.Segwit - Network.Haskoin.Util + Haskoin.Address.Base58 + Haskoin.Address.Bech32 + Haskoin.Address.CashAddr + Haskoin.Block.Common + Haskoin.Block.Headers + Haskoin.Block.Merkle + Haskoin.Crypto.Hash + Haskoin.Crypto.Signature + Haskoin.Keys.Common + Haskoin.Keys.Extended + Haskoin.Keys.Mnemonic + Haskoin.Network.Bloom + Haskoin.Network.Common + Haskoin.Network.Message + Haskoin.Script.Common + Haskoin.Script.SigHash + Haskoin.Script.Standard + Haskoin.Transaction.Builder + Haskoin.Transaction.Builder.Sign + Haskoin.Transaction.Common + Haskoin.Transaction.Partial + Haskoin.Transaction.Segwit Paths_haskoin_core hs-source-dirs: src @@ -105,63 +105,63 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - Network.Haskoin.Address.Bech32Spec - Network.Haskoin.Address.CashAddrSpec - Network.Haskoin.AddressSpec - Network.Haskoin.BlockSpec - Network.Haskoin.Crypto.HashSpec - Network.Haskoin.Crypto.SignatureSpec - Network.Haskoin.CryptoSpec - Network.Haskoin.Keys.ExtendedSpec - Network.Haskoin.Keys.MnemonicSpec - Network.Haskoin.KeysSpec - Network.Haskoin.NetworkSpec - Network.Haskoin.ScriptSpec - Network.Haskoin.Test - Network.Haskoin.Test.Address - Network.Haskoin.Test.Block - Network.Haskoin.Test.Crypto - Network.Haskoin.Test.Keys - Network.Haskoin.Test.Message - Network.Haskoin.Test.Network - Network.Haskoin.Test.Script - Network.Haskoin.Test.Transaction - Network.Haskoin.Test.Util - Network.Haskoin.Transaction.PartialSpec - Network.Haskoin.TransactionSpec - Network.Haskoin.UtilSpec + Haskoin.Address.Bech32Spec + Haskoin.Address.CashAddrSpec + Haskoin.AddressSpec + Haskoin.BlockSpec + Haskoin.Crypto.HashSpec + Haskoin.Crypto.SignatureSpec + Haskoin.CryptoSpec + Haskoin.Keys.ExtendedSpec + Haskoin.Keys.MnemonicSpec + Haskoin.KeysSpec + Haskoin.NetworkSpec + Haskoin.ScriptSpec + Haskoin.Test + Haskoin.Test.Address + Haskoin.Test.Block + Haskoin.Test.Crypto + Haskoin.Test.Keys + Haskoin.Test.Message + Haskoin.Test.Network + Haskoin.Test.Script + Haskoin.Test.Transaction + Haskoin.Test.Util + Haskoin.Transaction.PartialSpec + Haskoin.TransactionSpec + Haskoin.UtilSpec Haskoin - Network.Haskoin.Address - Network.Haskoin.Address.Base58 - Network.Haskoin.Address.Bech32 - Network.Haskoin.Address.CashAddr - Network.Haskoin.Block - Network.Haskoin.Block.Common - Network.Haskoin.Block.Headers - Network.Haskoin.Block.Merkle - Network.Haskoin.Constants - Network.Haskoin.Crypto - Network.Haskoin.Crypto.Hash - Network.Haskoin.Crypto.Signature - Network.Haskoin.Keys - Network.Haskoin.Keys.Common - Network.Haskoin.Keys.Extended - Network.Haskoin.Keys.Mnemonic - Network.Haskoin.Network - Network.Haskoin.Network.Bloom - Network.Haskoin.Network.Common - Network.Haskoin.Network.Message - Network.Haskoin.Script - Network.Haskoin.Script.Common - Network.Haskoin.Script.SigHash - Network.Haskoin.Script.Standard - Network.Haskoin.Transaction - Network.Haskoin.Transaction.Builder - Network.Haskoin.Transaction.Builder.Sign - Network.Haskoin.Transaction.Common - Network.Haskoin.Transaction.Partial - Network.Haskoin.Transaction.Segwit - Network.Haskoin.Util + Haskoin.Address + Haskoin.Address.Base58 + Haskoin.Address.Bech32 + Haskoin.Address.CashAddr + Haskoin.Block + Haskoin.Block.Common + Haskoin.Block.Headers + Haskoin.Block.Merkle + Haskoin.Constants + Haskoin.Crypto + Haskoin.Crypto.Hash + Haskoin.Crypto.Signature + Haskoin.Keys + Haskoin.Keys.Common + Haskoin.Keys.Extended + Haskoin.Keys.Mnemonic + Haskoin.Network + Haskoin.Network.Bloom + Haskoin.Network.Common + Haskoin.Network.Message + Haskoin.Script + Haskoin.Script.Common + Haskoin.Script.SigHash + Haskoin.Script.Standard + Haskoin.Transaction + Haskoin.Transaction.Builder + Haskoin.Transaction.Builder.Sign + Haskoin.Transaction.Common + Haskoin.Transaction.Partial + Haskoin.Transaction.Segwit + Haskoin.Util Paths_haskoin_core hs-source-dirs: test diff --git a/src/Haskoin.hs b/src/Haskoin.hs --- a/src/Haskoin.hs +++ b/src/Haskoin.hs @@ -33,13 +33,13 @@ , module Util ) where -import Network.Haskoin.Address as Address -import Network.Haskoin.Block as Block -import Network.Haskoin.Constants as Constants -import Network.Haskoin.Crypto as Crypto -import Network.Haskoin.Keys as Keys -import Network.Haskoin.Network as Network -import Network.Haskoin.Script as Script -import Network.Haskoin.Transaction as Transaction -import Network.Haskoin.Transaction.Partial as Partial -import Network.Haskoin.Util as Util +import Haskoin.Address as Address +import Haskoin.Block as Block +import Haskoin.Constants as Constants +import Haskoin.Crypto as Crypto +import Haskoin.Keys as Keys +import Haskoin.Network as Network +import Haskoin.Script as Script +import Haskoin.Transaction as Transaction +import Haskoin.Transaction.Partial as Partial +import Haskoin.Util as Util diff --git a/src/Haskoin/Address.hs b/src/Haskoin/Address.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Address.hs @@ -0,0 +1,314 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Haskoin.Address +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Base58, CashAddr, Bech32 address and WIF private key serialization support. +-} +module Haskoin.Address + ( Address(..) + , isPubKeyAddress + , isScriptAddress + , isWitnessPubKeyAddress + , isWitnessScriptAddress + , addrToString + , stringToAddr + , addrToJSON + , addrToEncoding + , addrFromJSON + , pubKeyAddr + , pubKeyWitnessAddr + , pubKeyCompatWitnessAddr + , p2pkhAddr + , p2wpkhAddr + , p2shAddr + , p2wshAddr + , inputAddress + , outputAddress + , addressToScript + , addressToScriptBS + , addressToOutput + , payToScriptAddress + , payToWitnessScriptAddress + , payToNestedScriptAddress + , scriptToAddress + , scriptToAddressBS + -- * Private Key Wallet Import Format (WIF) + , fromWif + , toWif + -- * Base58 + , module Haskoin.Address.Base58 + -- * Bech32 + , module Haskoin.Address.Bech32 + -- * CashAddr + , module Haskoin.Address.CashAddr + ) where + +import Control.Applicative +import Control.DeepSeq +import Control.Monad +import Data.Aeson as A +import Data.Aeson.Encoding as A +import Data.Aeson.Types +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Hashable +import Data.Maybe +import Data.Serialize as S +import Data.Text (Text) +import GHC.Generics (Generic) +import Haskoin.Address.Base58 +import Haskoin.Address.Bech32 +import Haskoin.Address.CashAddr +import Haskoin.Constants +import Haskoin.Crypto +import Haskoin.Keys.Common +import Haskoin.Script +import Haskoin.Util + +-- | Address format for Bitcoin and Bitcoin Cash. +data Address + -- | pay to public key hash (regular) + = PubKeyAddress { getAddrHash160 :: !Hash160 + -- ^ RIPEMD160 hash of public key's SHA256 hash + } + -- | pay to script hash + | ScriptAddress { getAddrHash160 :: !Hash160 + -- ^ RIPEMD160 hash of script's SHA256 hash + } + -- | pay to witness public key hash + | WitnessPubKeyAddress { getAddrHash160 :: !Hash160 + -- ^ RIPEMD160 hash of public key's SHA256 hash + } + -- | pay to witness script hash + | WitnessScriptAddress { getAddrHash256 :: !Hash256 + -- ^ HASH256 hash of script + } + deriving (Eq, Ord, Generic, Show, Read, Serialize, Hashable, NFData) + +-- | '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. +isWitnessPubKeyAddress :: Address -> Bool +isWitnessPubKeyAddress WitnessPubKeyAddress {} = True +isWitnessPubKeyAddress _ = False + +-- | 'Address' pays to a witness script hash. Only valid for SegWit networks. +isWitnessScriptAddress :: Address -> Bool +isWitnessScriptAddress WitnessScriptAddress {} = True +isWitnessScriptAddress _ = False + +-- | Deserializer for binary 'Base58' addresses. +base58get :: Network -> Get Address +base58get net = do + pfx <- getWord8 + addr <- S.get + f pfx addr + where + f x a + | x == getAddrPrefix net = return $ PubKeyAddress a + | x == getScriptPrefix net = return $ ScriptAddress a + | otherwise = fail "Does not recognize address prefix" + +-- | Binary serializer for 'Base58' addresses. +base58put :: Network -> Putter Address +base58put net (PubKeyAddress h) = do + putWord8 (getAddrPrefix net) + put h +base58put net (ScriptAddress h) = do + putWord8 (getScriptPrefix net) + put h +base58put _ _ = error "Cannot serialize this address as Base58" + +addrToJSON :: Network -> Address -> Value +addrToJSON net a = toJSON (addrToString net a) + +addrToEncoding :: Network -> Address -> Encoding +addrToEncoding net a = + case addrToString net a of + Nothing -> null_ + Just txt -> text txt + +-- | JSON parsing for Bitcoin addresses. Works with 'Base58', 'CashAddr' and +-- 'Bech32'. +addrFromJSON :: Network -> Value -> Parser Address +addrFromJSON net = + withText "address" $ \t -> + case stringToAddr net t of + Nothing -> fail "could not decode address" + Just x -> return x + +-- | Convert address to human-readable string. Uses 'Base58', 'Bech32', or +-- 'CashAddr' depending on network. +addrToString :: Network -> Address -> Maybe Text +addrToString net a@PubKeyAddress {getAddrHash160 = h} + | isNothing (getCashAddrPrefix net) = + Just . encodeBase58Check . runPut $ base58put net a + | otherwise = + cashAddrEncode net 0 (S.encode h) +addrToString net a@ScriptAddress {getAddrHash160 = h} + | isNothing (getCashAddrPrefix net) = + Just . encodeBase58Check . runPut $ base58put net a + | otherwise = + cashAddrEncode net 1 (S.encode h) +addrToString net WitnessPubKeyAddress {getAddrHash160 = h} = do + hrp <- getBech32Prefix net + segwitEncode hrp 0 (B.unpack (S.encode h)) +addrToString net WitnessScriptAddress {getAddrHash256 = h} = do + hrp <- getBech32Prefix net + segwitEncode hrp 0 (B.unpack (S.encode h)) + +-- | Parse 'Base58', 'Bech32' or 'CashAddr' address, depending on network. +stringToAddr :: Network -> Text -> Maybe Address +stringToAddr net bs = cash <|> segwit <|> b58 + where + b58 = eitherToMaybe . runGet (base58get net) =<< decodeBase58Check bs + cash = cashAddrDecode net bs >>= \(ver, bs') -> case ver of + 0 -> do + h <- eitherToMaybe (S.decode bs') + return $ PubKeyAddress h + 1 -> do + h <- eitherToMaybe (S.decode bs') + return $ ScriptAddress h + _ -> Nothing + segwit = do + hrp <- getBech32Prefix net + (ver, bs') <- segwitDecode hrp bs + guard (ver == 0) + let bs'' = B.pack bs' + case B.length bs'' of + 20 -> do + h <- eitherToMaybe (S.decode bs'') + return $ WitnessPubKeyAddress h + 32 -> do + h <- eitherToMaybe (S.decode bs'') + return $ WitnessScriptAddress h + _ -> Nothing + +-- | Obtain a standard pay-to-public-key-hash address from a public key. +pubKeyAddr :: PubKeyI -> Address +pubKeyAddr = PubKeyAddress . addressHash . S.encode + +-- | Obtain a standard pay-to-public-key-hash (P2PKH) address from a 'Hash160'. +p2pkhAddr :: Hash160 -> Address +p2pkhAddr = PubKeyAddress + +-- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a +-- public key. +pubKeyWitnessAddr :: PubKeyI -> Address +pubKeyWitnessAddr = WitnessPubKeyAddress . addressHash . S.encode + +-- | Obtain a backwards-compatible SegWit P2SH-P2WPKH address from a public key. +pubKeyCompatWitnessAddr :: PubKeyI -> Address +pubKeyCompatWitnessAddr = + p2shAddr . + addressHash . encodeOutputBS . PayWitnessPKHash . addressHash . S.encode + +-- | 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. +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. +addressToOutput :: Address -> ScriptOutput +addressToOutput (PubKeyAddress h) = PayPKHash h +addressToOutput (ScriptAddress h) = PayScriptHash h +addressToOutput (WitnessPubKeyAddress h) = PayWitnessPKHash h +addressToOutput (WitnessScriptAddress h) = PayWitnessScriptHash h + +-- | 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 = S.encode . 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 (PayPKHash h) = Just $ PubKeyAddress h +outputAddress (PayScriptHash h) = Just $ ScriptAddress h +outputAddress (PayPK k) = Just $ pubKeyAddr k +outputAddress (PayWitnessPKHash h) = Just $ WitnessPubKeyAddress h +outputAddress (PayWitnessScriptHash h) = Just $ WitnessScriptAddress h +outputAddress _ = Nothing + +-- | Infer the 'Address' of a 'ScriptInput'. +inputAddress :: ScriptInput -> Maybe Address +inputAddress (RegularInput (SpendPKHash _ key)) = Just $ pubKeyAddr key +inputAddress (ScriptHashInput _ rdm) = Just $ payToScriptAddress rdm +inputAddress _ = Nothing + +-- | Decode private key from WIF (wallet import format) string. +fromWif :: Network -> Base58 -> Maybe SecKeyI +fromWif net wif = do + bs <- decodeBase58Check wif + -- Check that this is a private key + guard (B.head bs == getSecretPrefix net) + case B.length bs of + -- Uncompressed format + 33 -> wrapSecKey False <$> secKey (B.tail bs) + -- Compressed format + 34 -> do + guard $ B.last bs == 0x01 + wrapSecKey True <$> secKey (B.tail $ B.init bs) + -- Bad length + _ -> Nothing + +-- | Encode private key into a WIF string. +toWif :: Network -> SecKeyI -> Base58 +toWif net (SecKeyI k c) = + encodeBase58Check . B.cons (getSecretPrefix net) $ + if c + then getSecKey k `B.snoc` 0x01 + else getSecKey k diff --git a/src/Haskoin/Address/Base58.hs b/src/Haskoin/Address/Base58.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Address/Base58.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Haskoin.Address.Base58 +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Support for legacy 'Base58' addresses. Superseded by Bech32 for Bitcoin SegWit +(BTC) and CashAddr for Bitcoin Cash (BCH). +-} +module Haskoin.Address.Base58 + ( Base58 + , encodeBase58 + , decodeBase58 + , encodeBase58Check + , decodeBase58Check + ) where + +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C +import Data.Maybe (fromMaybe, isJust, listToMaybe) +import Data.Serialize as S +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Data.Text as T +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" + +-- | Convert a number less than or equal to provided integer into a 'Base58' +-- character. +b58 :: Int -> Char +b58 = C.index b58Data + +-- | Convert a 'Base58' character into the number it represents. +b58' :: Char -> Maybe Int +b58' = flip C.elemIndex b58Data + +-- | 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 b58 i "" + +-- | Decode a 'Base58' string into an arbitrary-length 'Integer'. +decodeBase58I :: Base58 -> Maybe Integer +decodeBase58I s = + case go of + Just (r,[]) -> Just r + _ -> Nothing + where + p = isJust . b58' + f = fromMaybe e . b58' + 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. +encodeBase58 :: ByteString -> Base58 +encodeBase58 bs = + l `mappend` r + where + (z, b) = BS.span (== 0) bs + l = cs $ BS.replicate (BS.length z) (BS.index b58Data 0) -- preserve leading 0's + r | BS.null b = T.empty + | otherwise = encodeBase58I $ bsToInteger b + +-- | Decode a 'Base58'-encoded 'Text' to a 'ByteString'. +decodeBase58 :: Base58 -> Maybe ByteString +decodeBase58 t = + BS.append prefix <$> r + where + (z, b) = BS.span (== BS.index b58Data 0) (cs t) + prefix = BS.replicate (BS.length z) 0 -- preserve leading 1's + r | 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'. +encodeBase58Check :: ByteString -> Base58 +encodeBase58Check bs = + encodeBase58 $ BS.append bs $ encode $ 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. +decodeBase58Check :: Base58 -> Maybe ByteString +decodeBase58Check bs = do + rs <- decodeBase58 bs + let (res, chk) = BS.splitAt (BS.length rs - 4) rs + guard $ chk == encode (checkSum32 res) + return res diff --git a/src/Haskoin/Address/Bech32.hs b/src/Haskoin/Address/Bech32.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Address/Bech32.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Haskoin.Address.Base58 +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Support for Bitcoin SegWit (BTC) Bech32 addresses. This module is a modified +version of Marko Bencun's reference implementation. +-} +module Haskoin.Address.Bech32 + ( HRP + , Bech32 + , Data + , bech32Encode + , bech32Decode + , toBase32 + , toBase256 + , segwitEncode + , segwitDecode + , Word5(..) + , word5 + , fromWord5 + ) where + +import Control.Monad (guard) +import Data.Array (Array, assocs, bounds, listArray, (!), + (//)) +import Data.Bits (Bits, testBit, unsafeShiftL, + unsafeShiftR, xor, (.&.), (.|.)) +import qualified Data.ByteString as B +import Data.Char (toUpper) +import Data.Foldable (foldl') +import Data.Functor.Identity (Identity, runIdentity) +import Data.Ix (Ix (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import Data.Word (Word8) + +-- | 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 + | inRange (bounds inv) upperC = inv ! upperC + | otherwise = Nothing + where + upperC = toUpper 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 + where + go chk value = + foldl' xor chk' [g | (g, i) <- zip generator [25 ..], testBit chk i] + where + generator = [0x3b6a57b2, 0x26508e6d, 0x1ea119fa, 0x3d4233dd, 0x2a1462b3] + chk' = chk .<<. 5 `xor` fromWord5 value + +-- | Convert human-readable part of 'Bech32' string into a list of five-bit +-- words. +bech32HRPExpand :: HRP -> [Word5] +bech32HRPExpand hrp = + map (UnsafeWord5 . (.>>. 5)) hrpBytes ++ + [UnsafeWord5 0] ++ map word5 hrpBytes + where + hrpBytes = B.unpack $ E.encodeUtf8 hrp + +-- | Calculate checksum for a string of five-bit words. +bech32CreateChecksum :: HRP -> [Word5] -> [Word5] +bech32CreateChecksum hrp dat = [word5 (polymod .>>. i) | i <- [25,20 .. 0]] + where + values = bech32HRPExpand hrp ++ dat + polymod = + bech32Polymod (values ++ map UnsafeWord5 [0, 0, 0, 0, 0, 0]) `xor` 1 + +-- | Verify checksum for a human-readable part and string of five-bit words. +bech32VerifyChecksum :: HRP -> [Word5] -> Bool +bech32VerifyChecksum hrp dat = bech32Polymod (bech32HRPExpand hrp ++ dat) == 1 + +-- | 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. +bech32Encode :: HRP -> [Word5] -> Maybe Bech32 +bech32Encode hrp dat = do + guard $ checkHRP hrp + let dat' = dat ++ bech32CreateChecksum (T.toLower hrp) dat + rest = map (charset !) dat' + result = T.concat [T.toLower hrp, T.pack "1", T.pack rest] + guard $ T.length result <= maxBech32Length + return result + +-- | Check that human-readable part is valid for a 'Bech32' string. +checkHRP :: HRP -> Bool +checkHRP hrp = not (T.null hrp) && T.all (\char -> char >= '\x21' && char <= '\x7e') hrp + +-- | Decode human-readable 'Bech32' string into a human-readable part and a +-- string of five-bit words. +bech32Decode :: Bech32 -> Maybe (HRP, [Word5]) +bech32Decode bech32 = do + guard $ T.length bech32 <= maxBech32Length + guard $ T.toUpper bech32 == bech32 || lowerBech32 == bech32 + let (hrp, dat) = T.breakOnEnd "1" lowerBech32 + guard $ T.length dat >= 6 + hrp' <- T.stripSuffix "1" hrp + guard $ checkHRP hrp' + dat' <- mapM charsetMap $ T.unpack dat + guard $ bech32VerifyChecksum hrp' dat' + return (hrp', take (T.length dat - 6) dat') + 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}\). +convertBits :: Functor f => [Word] -> Int -> Int -> Pad f -> f [Word] +convertBits dat frombits tobits pad = concat . reverse <$> go dat 0 0 [] + where + go [] acc bits result = + let padValue = (acc .<<. (tobits - bits)) .&. maxv + in pad frombits bits padValue result + go (value:dat') acc bits result = + go dat' acc' (bits' `rem` tobits) (result' : result) + where + acc' = (acc .<<. frombits) .|. fromIntegral value + bits' = bits + frombits + result' = + [ (acc' .>>. b) .&. maxv + | b <- [bits' - tobits,bits' - 2 * tobits .. 0] + ] + maxv = (1 .<<. tobits) - 1 +{-# INLINE convertBits #-} + +-- | Convert from eight-bit to five-bit word string, adding padding as required. +toBase32 :: [Word8] -> [Word5] +toBase32 dat = + map word5 $ runIdentity $ convertBits (map fromIntegral dat) 8 5 yesPadding + +-- | 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 :: Word8 -> Data -> Bool +segwitCheck witver witprog = + witver <= 16 && + if witver == 0 + then length witprog == 20 || length witprog == 32 + else 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 + (hrp', dat) <- bech32Decode addr + guard $ (hrp == hrp') && not (null dat) + let (UnsafeWord5 witver:datBase32) = dat + decoded <- toBase256 datBase32 + guard $ segwitCheck witver decoded + return (witver, decoded) + +-- | 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 witver witprog + bech32Encode hrp $ UnsafeWord5 witver : toBase32 witprog diff --git a/src/Haskoin/Address/CashAddr.hs b/src/Haskoin/Address/CashAddr.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Address/CashAddr.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Haskoin.Address.CashAddr +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Support for Bitcoin Cash (BCH) CashAddr format. +-} +module Haskoin.Address.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.Constants +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 new file mode 100644 --- /dev/null +++ b/src/Haskoin/Block.hs @@ -0,0 +1,21 @@ +{-| +Module : Haskoin.Block +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Most functions relating to blocks are exported by this module. +-} +module Haskoin.Block + ( module Haskoin.Block.Common + -- * Block Header Chain + , module Haskoin.Block.Headers + -- * Merkle Blocks + , module Haskoin.Block.Merkle + ) where + +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 new file mode 100644 --- /dev/null +++ b/src/Haskoin/Block/Common.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-| +Module : Haskoin.Block.Common +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Common data types and functions to handle blocks from the block chain. +-} +module Haskoin.Block.Common + ( Block(..) + , BlockHeight + , Timestamp + , BlockHeader(..) + , headerHash + , BlockLocator + , GetBlocks(..) + , GetHeaders(..) + , BlockHeaderCount + , BlockHash(..) + , blockHashToHex + , hexToBlockHash + , Headers(..) + , decodeCompact + , encodeCompact + ) where + +import Control.DeepSeq +import Control.Monad (forM_, liftM2, mzero, replicateM) +import Data.Aeson (FromJSON (..), ToJSON (..), + Value (String), toJSON, withText) +import Data.Aeson.Encoding (unsafeToEncoding) +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) +import qualified Data.ByteString as B +import Data.ByteString.Builder (char7) +import Data.Hashable (Hashable) +import Data.Maybe (fromMaybe) +import Data.Serialize (Serialize, decode, encode, get, + put) +import Data.Serialize.Get (getWord32le) +import Data.Serialize.Put (Put, putWord32le) +import Data.String (IsString, fromString) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Word (Word32) +import GHC.Generics (Generic) +import Haskoin.Crypto.Hash +import Haskoin.Network.Common +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 + , blockTxns :: ![Tx] + } deriving (Eq, Show, Read, Generic, Hashable, NFData) + +instance Serialize Block where + get = do + header <- get + (VarInt c) <- get + txs <- replicateM (fromIntegral c) get + return $ Block header txs + put (Block h txs) = do + put h + putVarInt $ length txs + forM_ txs put + +instance ToJSON Block where + toJSON = String . encodeHex . encode + toEncoding s = + unsafeToEncoding $ char7 '"' <> hexBuilder (encode s) <> char7 '"' + +instance FromJSON Block where + parseJSON = + withText "Block" $ \t -> do + bin <- + case decodeHex t of + Nothing -> mzero + Just bin -> return bin + case decode bin of + Left e -> fail e + Right h -> return h + +instance ToJSON BlockHeader where + toJSON = String . encodeHex . encode + toEncoding s = + unsafeToEncoding $ char7 '"' <> hexBuilder (encode s) <> char7 '"' + +instance FromJSON BlockHeader where + parseJSON = + withText "BlockHeader" $ \t -> do + bin <- + case decodeHex t of + Nothing -> mzero + Just bin -> return bin + case decode bin of + Left e -> fail e + Right h -> return h + +-- | Block header hash. To be serialized reversed for display purposes. +newtype BlockHash = BlockHash + { getBlockHash :: Hash256 } + deriving (Eq, Ord, Generic, Hashable, Serialize, NFData) + +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 "block hash" $ + maybe mzero return . hexToBlockHash + +instance ToJSON BlockHash where + toJSON = String . blockHashToHex + toEncoding s = + unsafeToEncoding $ + char7 '"' <> hexBuilder (B.reverse (encode s)) <> char7 '"' + +-- | 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 (encode h)) + +-- | 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 (decode 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 BlockHeader = + BlockHeader { blockVersion :: !Word32 -- 4 bytes + -- | hash of the previous block (parent) + , prevBlock :: !BlockHash -- 32 bytes + -- | root of the merkle tree of transactions + , merkleRoot :: !Hash256 -- 32 bytes + -- | unix timestamp + , blockTimestamp :: !Timestamp -- 4 bytes + -- | difficulty target + , blockBits :: !Word32 -- 4 bytes + -- | random nonce + , bhNonce :: !Word32 -- 4 bytes + } deriving (Eq, Ord, Show, Read, Generic, Hashable, NFData) + -- 80 bytes + +-- | Compute hash of 'BlockHeader'. +headerHash :: BlockHeader -> BlockHash +headerHash = BlockHash . doubleSHA256 . encode + +instance Serialize BlockHeader where + get = do + v <- getWord32le + p <- get + m <- get + t <- getWord32le + b <- getWord32le + n <- getWord32le + return BlockHeader + { blockVersion = v + , prevBlock = p + , merkleRoot = m + , blockTimestamp = t + , blockBits = b + , bhNonce = n + } + + put (BlockHeader v p m bt bb n) = do + putWord32le v + put p + put m + putWord32le bt + putWord32le bb + putWord32le n + +-- | 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 GetBlocks = + GetBlocks { -- | protocol version. + getBlocksVersion :: !Word32 + -- | block locator object + , getBlocksLocator :: !BlockLocator + -- | hash of the last desired block + , getBlocksHashStop :: !BlockHash + } deriving (Eq, Show, Generic, NFData) + +instance Serialize GetBlocks where + + get = GetBlocks <$> getWord32le + <*> (repList =<< get) + <*> get + where + repList (VarInt c) = replicateM (fromIntegral c) get + + put (GetBlocks v xs h) = putGetBlockMsg v xs h + +putGetBlockMsg :: Word32 -> BlockLocator -> BlockHash -> Put +putGetBlockMsg v xs h = do + putWord32le v + putVarInt $ length xs + forM_ xs put + put 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. +data GetHeaders = + GetHeaders { + -- | protocol version + getHeadersVersion :: !Word32 + -- | block locator object + , getHeadersBL :: !BlockLocator + -- | hash of the last desired block header + , getHeadersHashStop :: !BlockHash + } deriving (Eq, Show, Generic, NFData) + +instance Serialize GetHeaders where + + get = GetHeaders <$> getWord32le + <*> (repList =<< get) + <*> get + where + repList (VarInt c) = replicateM (fromIntegral c) get + + put (GetHeaders v xs h) = putGetBlockMsg v xs h + +-- | '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. +newtype Headers = + Headers { -- | list of block headers with transaction count + headersList :: [BlockHeaderCount] + } + deriving (Eq, Show, Generic, NFData) + +instance Serialize Headers where + + get = Headers <$> (repList =<< get) + where + repList (VarInt c) = replicateM (fromIntegral c) action + action = liftM2 (,) get get + + put (Headers xs) = do + putVarInt $ length xs + forM_ xs $ \(a,b) -> put a >> put b + +-- | 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 -> (Integer, Bool) -- ^ true means overflow +decodeCompact nCompact = (if neg then res * (-1) else res, over) + where + nSize :: Int + nSize = fromIntegral nCompact `shiftR` 24 + nWord' :: Word32 + nWord' = nCompact .&. 0x007fffff + nWord :: Word32 + nWord | nSize <= 3 = nWord' `shiftR` (8 * (3 - nSize)) + | otherwise = nWord' + res :: Integer + res | nSize <= 3 = fromIntegral nWord + | otherwise = fromIntegral nWord `shiftL` (8 * (nSize - 3)) + neg = nWord /= 0 && (nCompact .&. 0x00800000) /= 0 + over = nWord /= 0 && (nSize > 34 || + nWord > 0xff && nSize > 33 || + nWord > 0xffff && nSize > 32) + +-- | Encode an 'Integer' to the compact number format used in the difficulty +-- target of a block. +encodeCompact :: Integer + -> Word32 +encodeCompact i = nCompact + where + i' = abs i + neg = i < 0 + nSize' :: Int + nSize' = let f 0 = 0 + f n = 1 + f (n `shiftR` 8) + in f i' + nCompact''' :: Word32 + nCompact''' + | nSize' <= 3 = fromIntegral $ (low64 .&. i') `shiftL` (8 * (3 - nSize')) + | otherwise = fromIntegral $ low64 .&. (i' `shiftR` (8 * (nSize' - 3))) + nCompact'' :: Word32 + nSize :: Int + (nCompact'', nSize) + | nCompact''' .&. 0x00800000 /= 0 = (nCompact''' `shiftR` 8, nSize' + 1) + | otherwise = (nCompact''', nSize') + nCompact' :: Word32 + nCompact' = nCompact'' .|. (fromIntegral nSize `shiftL` 24) + nCompact :: Word32 + nCompact | neg && (nCompact' .&. 0x007fffff /= 0) = nCompact' .|. 0x00800000 + | otherwise = nCompact' + low64 :: Integer + low64 = 0xffffffffffffffff diff --git a/src/Haskoin/Block/Headers.hs b/src/Haskoin/Block/Headers.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Block/Headers.hs @@ -0,0 +1,740 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-| +Module : Haskoin.Block.Headers +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Block chain header synchronization and proof-of-work consensus functions. +-} +module Haskoin.Block.Headers + ( BlockNode(..) + , BlockHeaders(..) + , BlockWork + , genesisNode + , genesisBlock + , isGenesis + , chooseBest + -- * Header Chain Storage Functions + , parentBlock + , getParents + , getAncestor + , splitPoint + , connectBlocks + , connectBlock + , blockLocator + -- * In-Memory Header Chain Store + , HeaderMemory(..) + , ShortBlockHash + , BlockMap + , shortBlockHash + , initialChain + , genesisMap + -- * Helper Functions + , appendBlocks + , validBlock + , validCP + , afterLastCP + , bip34 + , validVersion + , lastNoMinDiff + , nextWorkRequired + , nextEdaWorkRequired + , nextDaaWorkRequired + , computeTarget + , getSuitableBlock + , nextPowWorkRequired + , calcNextWork + , isValidPOW + , blockPOW + , headerWork + , diffInterval + , blockLocatorNodes + , mineBlock + , computeSubsidy + , ) where + +import Control.Applicative ((<|>)) +import Control.DeepSeq +import Control.Monad (guard, unless, when) +import Control.Monad.Except (ExceptT (..), runExceptT, + throwError) +import Control.Monad.State.Strict as State (StateT, get, gets, lift, + modify) +import Control.Monad.Trans.Maybe +import Data.Bits (shiftL, shiftR, (.&.)) +import qualified Data.ByteString as B +import Data.ByteString.Short (ShortByteString, fromShort, + toShort) +import Data.Function (on) +import Data.Hashable +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.List (sort, sortBy) +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Serialize as S (Serialize (..), decode, + encode, get, put) +import Data.Serialize.Get as S +import Data.Serialize.Put as S +import Data.Typeable (Typeable) +import Data.Word (Word32, Word64) +import GHC.Generics (Generic) +import Haskoin.Block.Common +import Haskoin.Constants +import Haskoin.Crypto +import Haskoin.Transaction.Common +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). +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. +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 BlockNode + -- | non-Genesis block header + = BlockNode { nodeHeader :: !BlockHeader + , nodeHeight :: !BlockHeight + -- | accumulated work so far + , nodeWork :: !BlockWork + -- | akip magic block hash + , nodeSkip :: !BlockHash } + -- | Genesis block header + | GenesisNode { nodeHeader :: !BlockHeader + , nodeHeight :: !BlockHeight + , nodeWork :: !BlockWork } + deriving (Show, Read, Generic, Hashable, NFData) + +instance Serialize BlockNode where + get = do + nodeHeader <- S.get + nodeHeight <- getWord32le + nodeWork <- S.get + if nodeHeight == 0 + then return GenesisNode {..} + else do + nodeSkip <- S.get + return BlockNode {..} + put bn = do + put $ nodeHeader bn + putWord32le $ nodeHeight bn + put $ nodeWork bn + case bn of + GenesisNode {} -> return () + BlockNode {} -> put $ nodeSkip bn + +instance Eq BlockNode where + (==) = (==) `on` nodeHeader + +instance Ord BlockNode where + compare = compare `on` nodeHeight + +-- | Memory-based header tree. +data HeaderMemory = HeaderMemory + { memoryHeaderMap :: !BlockMap + , memoryBestHeader :: !BlockNode + } deriving (Eq, Typeable, Show, Read, Generic, Hashable, NFData) + +-- | Typeclass for block header chain storage monad. +class Monad m => BlockHeaders m where + -- | Add a new 'BlockNode' to the chain. Does not validate. + addBlockHeader :: BlockNode -> m () + -- | 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 = HeaderMemory + { memoryHeaderMap = genesisMap net + , memoryBestHeader = genesisNode net + } + +-- | Initialize map for memory-based chain. +genesisMap :: Network -> BlockMap +genesisMap net = + HashMap.singleton + (shortBlockHash (headerHash (getGenesisHeader net))) + (toShort (encode (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 . decode $ 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. +shortBlockHash :: BlockHash -> ShortBlockHash +shortBlockHash = either error id . decode . B.take 8 . encode + +-- | Add a block to memory-based block map. +addBlockToMap :: BlockNode -> BlockMap -> BlockMap +addBlockToMap node = + HashMap.insert + (shortBlockHash $ headerHash $ nodeHeader node) + (toShort $ encode node) + +-- | Get the ancestor of the provided 'BlockNode' at the specified +-- 'BlockHeight'. +getAncestor :: BlockHeaders m + => BlockHeight + -> BlockNode + -> m (Maybe BlockNode) +getAncestor height node + | height > nodeHeight node = return Nothing + | otherwise = go node + where + e1 = error "Could not get skip header" + e2 = error "Could not get previous block header" + go walk + | nodeHeight walk > height = + let heightSkip = skipHeight (nodeHeight walk) + heightSkipPrev = skipHeight (nodeHeight walk - 1) + in if not (isGenesis walk) && + (heightSkip == height || + (heightSkip > height && + not + (heightSkipPrev < heightSkip - 2 && + heightSkipPrev >= height))) + then do + walk' <- fromMaybe e1 <$> getBlockHeader (nodeSkip walk) + go walk' + else do + walk' <- + fromMaybe e2 <$> + getBlockHeader (prevBlock (nodeHeader walk)) + go walk' + | otherwise = return $ Just walk + +-- | Is the provided 'BlockNode' the Genesis block? +isGenesis :: BlockNode -> Bool +isGenesis GenesisNode{} = True +isGenesis BlockNode{} = False + +-- | Build the genesis 'BlockNode' for the supplied 'Network'. +genesisNode :: Network -> BlockNode +genesisNode net = + GenesisNode + { nodeHeader = getGenesisHeader net + , nodeHeight = 0 + , nodeWork = headerWork (getGenesisHeader net) + } + +-- | 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 + -> Timestamp -- ^ current time + -> [BlockHeader] + -> m (Either String [BlockNode]) +connectBlocks _ _ [] = return $ Right [] +connectBlocks net t bhs@(bh:_) = + runExceptT $ do + unless (chained bhs) $ + throwError "Blocks to connect do not form a chain" + par <- + maybeToExceptT + "Could not get parent block" + (MaybeT (parentBlock bh)) + pars <- lift $ getParents 10 par + bb <- lift getBestBlockHeader + go par [] bb par pars bhs >>= \case + bns@(bn:_) -> do + lift $ addBlockHeaders bns + let bb' = chooseBest bn bb + when (bb' /= bb) $ lift $ setBestBlockHeader bb' + return bns + _ -> undefined + where + chained (h1:h2:hs) = headerHash h1 == prevBlock h2 && chained (h2 : hs) + chained _ = True + skipit lbh ls par + | sh == nodeHeight lbh = return lbh + | sh < nodeHeight lbh = do + skM <- lift $ getAncestor sh lbh + case skM of + Just sk -> return sk + Nothing -> + throwError $ + "BUG: Could not get skip for block " ++ + show (headerHash $ nodeHeader par) + | otherwise = do + let sn = ls !! fromIntegral (nodeHeight par - sh) + when (nodeHeight sn /= sh) $ + throwError "BUG: Node height not right in skip" + return sn + where + sh = skipHeight (nodeHeight par + 1) + go _ acc _ _ _ [] = return acc + go lbh acc bb par pars (h:hs) = do + sk <- skipit lbh acc par + bn <- ExceptT . return $ validBlock net t bb par pars h sk + go lbh (bn : acc) (chooseBest bn bb) bn (take 10 $ par : pars) hs + +-- | 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. +connectBlock :: + BlockHeaders m + => Network + -> Timestamp -- ^ current time + -> BlockHeader + -> m (Either String BlockNode) +connectBlock net t bh = + runExceptT $ do + par <- + maybeToExceptT + "Could not get parent block" + (MaybeT (parentBlock bh)) + pars <- lift $ getParents 10 par + skM <- lift $ getAncestor (skipHeight (nodeHeight par + 1)) par + sk <- + case skM of + Just sk -> return sk + Nothing -> + throwError $ + "BUG: Could not get skip for block " ++ + show (headerHash $ nodeHeader par) + bb <- lift getBestBlockHeader + bn <- ExceptT . return $ validBlock net t bb par pars bh sk + let bb' = chooseBest bb bn + lift $ addBlockHeader bn + when (bb /= bb') . lift $ setBestBlockHeader bb' + return bn + +-- | Validate this block header. Build a 'BlockNode' if successful. +validBlock :: Network + -> Timestamp -- ^ current time + -> BlockNode -- ^ best block + -> BlockNode -- ^ immediate parent + -> [BlockNode] -- ^ 10 parents above + -> BlockHeader -- ^ header to validate + -> BlockNode -- ^ skip node (black magic) + -> Either String BlockNode +validBlock net t bb par pars bh sk = do + let mt = medianTime . map (blockTimestamp . nodeHeader) $ par : pars + nt = blockTimestamp bh + hh = headerHash bh + nv = blockVersion bh + ng = nodeHeight par + 1 + aw = nodeWork par + headerWork bh + unless (isValidPOW net bh) $ + Left $ "Proof of work failed: " ++ show (headerHash bh) + unless (nt <= t + 2 * 60 * 60) $ + Left $ "Invalid header timestamp: " ++ show nt + unless (nt >= mt) $ + Left $ "Block timestamp too early: " ++ show nt + unless (afterLastCP net (nodeHeight bb) ng) $ + Left $ "Rewriting pre-checkpoint chain: " ++ show ng + unless (validCP net ng hh) $ + Left $ "Rejected checkpoint: " ++ show ng + unless (bip34 net ng hh) $ + Left $ "Rejected BIP-34 block: " ++ show hh + unless (validVersion net ng nv) $ + Left $ "Invalid block version: " ++ show nv + return BlockNode { nodeHeader = bh + , nodeHeight = ng + , nodeWork = aw + , nodeSkip = headerHash $ nodeHeader sk + } + +-- | 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. +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 + => Int + -> BlockNode + -> m [BlockNode] -- ^ starts from immediate parent +getParents = getpars [] + where + getpars acc 0 _ = return $ reverse acc + getpars acc _ GenesisNode{} = return $ reverse acc + getpars acc n BlockNode{..} = do + parM <- getBlockHeader $ prevBlock nodeHeader + case parM of + Just bn -> getpars (bn : acc) (n - 1) bn + Nothing -> error "BUG: All non-genesis blocks should have a parent" + +-- | Verify that checkpoint location is valid. +validCP :: Network + -> BlockHeight -- ^ new child height + -> BlockHash -- ^ new child hash + -> Bool +validCP net height newChildHash = + case lookup height (getCheckpoints net) of + Just cpHash -> cpHash == newChildHash + Nothing -> True + +-- | New block height above the last checkpoint imported. Used to prevent a +-- reorg below the highest checkpoint that was already imported. +afterLastCP :: Network + -> BlockHeight -- ^ best height + -> BlockHeight -- ^ new imported block height + -> Bool +afterLastCP net bestHeight newChildHeight = + case lM of + Just l -> l < newChildHeight + Nothing -> True + where + lM = + 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. +bip34 :: Network + -> BlockHeight -- ^ new child height + -> BlockHash -- ^ new child hash + -> Bool +bip34 net height hsh + | fst (getBip34Block net) == 0 = True + | fst (getBip34Block net) == height = snd (getBip34Block net) == hsh + | otherwise = True + +-- | Check if the provided block height and version are valid. +validVersion :: Network + -> BlockHeight -- ^ new child height + -> Word32 -- ^ new child version + -> Bool +validVersion net height version + | version < 2 = height < fst (getBip34Block net) + | version < 3 = height < getBip66Height net + | version < 4 = height < getBip65Height net + | otherwise = True + +-- | Find last block with normal, as opposed to minimum difficulty (for test +-- networks). +lastNoMinDiff :: BlockHeaders m => Network -> BlockNode -> m BlockNode +lastNoMinDiff net bn@BlockNode {..} = do + let i = nodeHeight `mod` diffInterval net /= 0 + c = encodeCompact (getPowLimit net) + l = blockBits nodeHeader == c + e1 = + error $ + "Could not get block header for parent of " ++ + show (headerHash nodeHeader) + if i && l + then do + bn' <- fromMaybe e1 <$> getBlockHeader (prevBlock nodeHeader) + lastNoMinDiff net bn' + else return bn + +lastNoMinDiff _ bn@GenesisNode{} = 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 + let mf = daa <|> eda <|> pow + case mf of + Just f -> f net par bh + Nothing -> + error + "Could not get an appropriate difficulty calculation algorithm" + where + daa = getDaaBlockHeight net >>= \daaHeight -> do + guard (nodeHeight par + 1 >= daaHeight) + return nextDaaWorkRequired + eda = getEdaBlockHeight net >>= \edaHeight -> do + guard (nodeHeight par + 1 >= edaHeight) + return nextEdaWorkRequired + pow = return nextPowWorkRequired + +-- | 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 + let height = nodeHeight par + 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 + e1 = error "Cannot get ancestor at parent - 144 height" + minDifficulty = + blockTimestamp bh > + blockTimestamp (nodeHeader par) + getTargetSpacing net * 2 + +-- | 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. +nextPowWorkRequired :: + BlockHeaders m => Network -> BlockNode -> BlockHeader -> m Word32 +nextPowWorkRequired net par bh + | nodeHeight par + 1 `mod` diffInterval net /= 0 = + if getAllowMinDifficultyBlocks net + then if ht > pt + delta + then return $ encodeCompact (getPowLimit net) + else do + d <- lastNoMinDiff net par + return $ blockBits $ nodeHeader d + else return $ blockBits $ nodeHeader par + | otherwise = do + let rh = nodeHeight par - (diffInterval net - 1) + a <- fromMaybe e1 <$> getAncestor rh par + let t = blockTimestamp $ nodeHeader a + return $ calcNextWork net (nodeHeader par) t + where + e1 = error "Could not get ancestor for block header" + pt = blockTimestamp $ nodeHeader par + ht = blockTimestamp bh + delta = getTargetSpacing net * 2 + +-- | Computes the work required for the first block in a new retarget period. +calcNextWork :: Network + -> BlockHeader -- ^ last block in previous retarget (parent) + -> Timestamp -- ^ timestamp of first block in previous retarget + -> Word32 +calcNextWork net header time + | getPowNoRetargetting net = blockBits header + | new > getPowLimit net = encodeCompact (getPowLimit net) + | otherwise = encodeCompact new + where + s = blockTimestamp header - time + n | s < getTargetTimespan net `div` 4 = getTargetTimespan net `div` 4 + | s > getTargetTimespan net * 4 = getTargetTimespan net * 4 + | otherwise = s + l = fst $ decodeCompact $ blockBits header + new = l * fromIntegral n `div` fromIntegral (getTargetTimespan net) + +-- | Returns True if the difficulty target (bits) of the header is valid and the +-- proof of work of the header matches the advertised difficulty target. This +-- function corresponds to the function @CheckProofOfWork@ from @bitcoind@ in +-- @main.cpp@. +isValidPOW :: Network -> BlockHeader -> Bool +isValidPOW net h + | target <= 0 || over || target > getPowLimit net = False + | otherwise = blockPOW (headerHash h) <= fromIntegral target + 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 . encode + +-- | 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 | nodeWork b1 == nodeWork b2 = + if nodeHeight b1 >= nodeHeight b2 + then b1 + else b2 + | nodeWork b1 > nodeWork b2 = b1 + | otherwise = b2 + +-- | Get list of blocks for a block locator. +blockLocatorNodes :: BlockHeaders m => BlockNode -> m [BlockNode] +blockLocatorNodes best = + reverse <$> go [] best 1 + where + e1 = error "Could not get ancestor" + go loc bn n = + let loc' = bn : loc + n' = if length loc' > 10 + then n * 2 + else 1 + in if nodeHeight bn < n' + then do a <- fromMaybe e1 <$> getAncestor 0 bn + return $ a : loc' + else do let h = nodeHeight bn - n' + bn' <- fromMaybe e1 <$> getAncestor h bn + go loc' bn' n' + +-- | 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 = + head + [ j + | i <- (+ seed) <$> [0 .. maxBound] + , let j = h {bhNonce = i} + , isValidPOW net j + ] + +-- | Generate and append new blocks (mining). Only practical in regtest network. +appendBlocks :: + Network + -> Word32 -- ^ random seed + -> BlockHeader + -> Int + -> [BlockHeader] +appendBlocks _ _ _ 0 = [] +appendBlocks net seed bh i = + bh' : appendBlocks net seed bh' (i - 1) + where + bh' = mineBlock net seed bh + { prevBlock = headerHash bh + -- Just to make it different in every header + , merkleRoot = sha256 $ encode seed + } + +-- | Find the last common block ancestor between provided block headers. +splitPoint :: BlockHeaders m => BlockNode -> BlockNode -> m BlockNode +splitPoint l r = do + let h = min (nodeHeight l) (nodeHeight r) + ll <- fromMaybe e <$> getAncestor h l + lr <- fromMaybe e <$> getAncestor h r + f ll lr + where + e = error "BUG: Could not get ancestor at lowest height" + f ll lr = + if ll == lr + then return lr + else do + let h = nodeHeight ll - 1 + pl <- fromMaybe e <$> getAncestor h ll + pr <- fromMaybe e <$> getAncestor h lr + f pl pr + +-- | 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 = + let halvings = height `div` getHalvingInterval net + ini = 50 * 100 * 1000 * 1000 + in if halvings >= 64 + then 0 + else ini `shiftR` fromIntegral halvings diff --git a/src/Haskoin/Block/Merkle.hs b/src/Haskoin/Block/Merkle.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Block/Merkle.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-| +Module : Haskoin.Block.Merkle +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Function to deal with Merkle trees inside blocks. +-} +module Haskoin.Block.Merkle + ( MerkleBlock(..) + , MerkleRoot + , FlagBits + , PartialMerkleTree + , buildMerkleRoot + , merkleBlockTxs + , testMerkleRoot + -- * Helper functions + , buildPartialMerkle + , decodeMerkleFlags + , encodeMerkleFlags + , calcTreeHeight + , calcTreeWidth + , hash2 + , calcHash + , traverseAndBuild + , traverseAndExtract + , extractMatches + , splitIn + , boolsToWord8 + ) where + +import Control.DeepSeq +import Control.Monad (forM_, replicateM, when) +import Data.Bits +import qualified Data.ByteString as BS +import Data.Either (isRight) +import Data.Hashable +import Data.Maybe +import Data.Serialize (Serialize, encode, get, put) +import Data.Serialize.Get (getWord32le, getWord8) +import Data.Serialize.Put (putWord32le, putWord8) +import Data.Word (Word32, Word8) +import GHC.Generics +import Haskoin.Block.Common +import Haskoin.Constants +import Haskoin.Crypto.Hash +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. +data MerkleBlock = + MerkleBlock { + -- | block header + merkleHeader :: !BlockHeader + -- | total number of transactions in block + , merkleTotalTxns :: !Word32 + -- | hashes in depth-first order + , mHashes :: !PartialMerkleTree + -- | bits to rebuild partial merkle tree + , mFlags :: !FlagBits + } deriving (Eq, Show, Read, Generic, Hashable, NFData) + +instance Serialize MerkleBlock where + + get = do + header <- get + ntx <- getWord32le + (VarInt matchLen) <- get + hashes <- replicateM (fromIntegral matchLen) get + (VarInt flagLen) <- get + ws <- replicateM (fromIntegral flagLen) getWord8 + return $ MerkleBlock header ntx hashes (decodeMerkleFlags ws) + + put (MerkleBlock h ntx hashes flags) = do + put h + putWord32le ntx + putVarInt $ length hashes + forM_ hashes put + let ws = encodeMerkleFlags flags + putVarInt $ length ws + forM_ ws putWord8 + +-- | 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 :: Int -- ^ number of transactions (leaf nodes) + -> Int -- ^ height of the merkle tree +calcTreeHeight ntx | ntx < 2 = 0 + | even ntx = 1 + calcTreeHeight (ntx `div` 2) + | otherwise = calcTreeHeight $ ntx + 1 + +-- | Computes the width of a Merkle tree at a specific height. The transactions +-- are at height 0. +calcTreeWidth :: Int -- ^ number of transactions (leaf nodes) + -> Int -- ^ height at which we want to compute the width + -> Int -- ^ width of the Merkle tree +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 :: [TxHash] -- ^ transaction hashes (leaf nodes) + -> MerkleRoot -- ^ root of the Merkle tree +buildMerkleRoot txs = calcHash (calcTreeHeight $ length txs) 0 txs + +-- | Concatenate and compute double SHA256. +hash2 :: Hash256 -> Hash256 -> Hash256 +hash2 a b = doubleSHA256 $ encode a `BS.append` encode b + +-- | Computes the hash of a specific node in a Merkle tree. +calcHash :: Int -- ^ height of the node + -> Int -- ^ position of the node (0 for the leftmost node) + -> [TxHash] -- ^ transaction hashes (leaf nodes) + -> Hash256 -- ^ hash of the node at the specified position +calcHash height pos txs + | height < 0 || pos < 0 = error "calcHash: Invalid parameters" + | height == 0 = getTxHash $ txs !! pos + | otherwise = hash2 left right + where + left = calcHash (height-1) (pos*2) txs + right | pos*2+1 < calcTreeWidth (length txs) (height-1) = + calcHash (height-1) (pos*2+1) txs + | otherwise = left + +-- | 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 :: + [(TxHash, Bool)] -- ^ transaction hash and whether to include + -> (FlagBits, PartialMerkleTree) -- ^ flag bits and partial Merkle tree +buildPartialMerkle hs = traverseAndBuild (calcTreeHeight $ length hs) 0 hs + +-- | Helper function to build partial Merkle tree. Used by 'buildPartialMerkle' +-- above. +traverseAndBuild :: + Int -> Int -> [(TxHash, Bool)] -> (FlagBits, PartialMerkleTree) +traverseAndBuild height pos txs + | height < 0 || pos < 0 = error "traverseAndBuild: Invalid parameters" + | height == 0 || not match = ([match], [calcHash height pos t]) + | otherwise = (match : lb ++ rb, lh ++ rh) + where + t = map fst txs + s = pos `shiftL` height + e = min (length txs) $ (pos + 1) `shiftL` height + match = any snd $ take (e - s) $ drop s txs + (lb, lh) = traverseAndBuild (height - 1) (pos * 2) txs + (rb, rh) + | (pos * 2 + 1) < calcTreeWidth (length txs) (height - 1) = + traverseAndBuild (height - 1) (pos * 2 + 1) txs + | otherwise = ([], []) + +-- | Helper function to extract transaction hashes from partial Merkle tree. +traverseAndExtract :: Int -> Int -> Int -> FlagBits -> PartialMerkleTree + -> Maybe (MerkleRoot, [TxHash], Int, Int) +traverseAndExtract height pos ntx flags hashes + | null flags = Nothing + | height == 0 || not match = leafResult + | isNothing leftM = Nothing + | (pos*2+1) >= calcTreeWidth ntx (height-1) = + Just (hash2 lh lh, lm, lcf+1, lch) + | isNothing rightM = Nothing + | otherwise = + Just (hash2 lh rh, lm ++ rm, lcf+rcf+1, lch+rch) + where + leafResult + | null hashes = Nothing + | otherwise = Just (h, [ TxHash h | height == 0 && match ], 1, 1) + (match:fs) = flags + (h:_) = hashes + leftM = traverseAndExtract (height-1) (pos*2) ntx fs hashes + (lh,lm,lcf,lch) = fromMaybe e leftM + rightM = traverseAndExtract (height-1) (pos*2+1) ntx + (drop lcf fs) (drop lch hashes) + (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'. +extractMatches :: Network + -> FlagBits + -> PartialMerkleTree + -> Int -- ^ number of transaction at height 0 (leaf nodes) + -> Either String (MerkleRoot, [TxHash]) + -- ^ Merkle root and list of matching transaction hashes +extractMatches net flags hashes ntx + | ntx == 0 = Left + "extractMatches: number of transactions can not be 0" + | ntx > getMaxBlockSize net `div` 60 = Left + "extractMatches: number of transactions excessively high" + | length hashes > ntx = Left + "extractMatches: More hashes provided than the number of transactions" + | length flags < length hashes = Left + "extractMatches: At least one bit per node and one bit per hash" + | isNothing resM = Left + "extractMatches: traverseAndExtract failed" + | (nBitsUsed+7) `div` 8 /= (length flags+7) `div` 8 = Left + "extractMatches: All bits were not consumed" + | nHashUsed /= length hashes = Left $ + "extractMatches: All hashes were not consumed: " ++ show nHashUsed + | otherwise = return (merkRoot, matches) + where + resM = traverseAndExtract (calcTreeHeight ntx) 0 ntx flags hashes + (merkRoot, matches, nBitsUsed, nHashUsed) = fromMaybe e resM + e = error "extractMatches: unexpected error extracting a Maybe value" + +-- | Helper function to split a list in chunks 'Int' length. Last chunk may be +-- smaller. +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 = + let flags = mFlags b + hs = mHashes b + n = fromIntegral $ merkleTotalTxns b + merkle = merkleRoot $ merkleHeader b + in do (root, ths) <- extractMatches net flags hs n + when (root /= merkle) $ Left "merkleBlockTxs: Merkle root incorrect" + return ths + +-- | 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 new file mode 100644 --- /dev/null +++ b/src/Haskoin/Constants.hs @@ -0,0 +1,540 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Haskoin.Constants +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Network constants for various networks, including Bitcoin SegWit (BTC), Bitcoin +Cash (BCH), and corresponding public test and private regression test networks. +-} +module Haskoin.Constants + ( Network(..) + , btc + , btcTest + , btcRegTest + , bch + , bchTest + , bchRegTest + , allNets + , netByName + , netByIdent + ) where + +import Control.DeepSeq +import Data.ByteString (ByteString) +import Data.List +import Data.Maybe +import Data.Serialize +import Data.String +import Data.Text (Text) +import Data.Version +import Data.Word (Word32, Word64, Word8) +import GHC.Generics (Generic) +import Haskoin.Block.Common +import Paths_haskoin_core +import Text.Read + +-- | Version of Haskoin Core package. +versionString :: IsString a => a +versionString = fromString (showVersion version) + +-- | Constants for network. +data Network = Network + { -- | lowercase alphanumeric and dashes + getNetworkName :: !String + -- | network Haskell identifier + , getNetworkIdent :: !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) + -- | segregated witness active + , getSegWit :: !Bool + -- | 'CashAddr' prefix (for Bitcoin Cash) + , getCashAddrPrefix :: !(Maybe Text) + -- | 'Bech32' prefix (for SegWit network) + , getBech32Prefix :: !(Maybe Text) + -- | Replace-By-Fee (BIP-125) + , getReplaceByFee :: !Bool + -- | Subsidy halving interval + , getHalvingInterval :: !Word32 + } deriving (Eq, Generic, NFData) + +instance Serialize Network where + put net = + putWord32be $ getNetworkMagic net + get = do + magic <- getWord32be + case find ((== magic) . getNetworkMagic) allNets of + Nothing -> fail $ "Network magic unknown: " <> show magic + Just net -> return net + +instance Show Network where + show = getNetworkIdent + +instance Read Network where + readPrec = do + Ident str <- lexP + maybe pfail return (netByIdent str) + +instance IsString Network where + fromString = fromMaybe (error "Network name invalid") . netByName + +-- | Query known networks by name. +netByName :: String -> Maybe Network +netByName str = find ((== str) . getNetworkName) allNets + +-- | Query known networks by Haskell identifier. +netByIdent :: String -> Maybe Network +netByIdent str = find ((== str) . getNetworkIdent) allNets + +-- | Bitcoin SegWit network. Symbol: BTC. +btc :: Network +btc = + Network + { getNetworkName = "btc" + , getNetworkIdent = "btc" + , getAddrPrefix = 0 + , getScriptPrefix = 5 + , getSecretPrefix = 128 + , getExtPubKeyPrefix = 0x0488b21e + , getExtSecretPrefix = 0x0488ade4 + , getNetworkMagic = 0xf9beb4d9 + , getGenesisHeader = + BlockHeader + 0x01 + "0000000000000000000000000000000000000000000000000000000000000000" + "3ba3edfd7a7b12b27ac72c3e67768f617fc81bc3888a51323a9fb8aa4b1e5e4a" + 1231006505 + 0x1d00ffff + 2083236893 + -- Hash 000000000019d6689c085ae165831e934ff763ae46a2a6c172b3f1b60a8ce26f + , getMaxBlockSize = 1000000 + , getMaxSatoshi = 2100000000000000 + , getHaskoinUserAgent = + "/haskoin-btc:" <> versionString <> "/" + , getDefaultPort = 8333 + , getAllowMinDifficultyBlocks = False + , getPowNoRetargetting = False + , getPowLimit = + 0x00000000ffffffffffffffffffffffffffffffffffffffffffffffffffffffff + , getBip34Block = + ( 227931 + , "000000000000024b89b42a942fe0d9fea3bb44ab7bd1b19115dd6a759c0808b8") + , getBip65Height = 388381 + , getBip66Height = 363725 + , getTargetTimespan = 14 * 24 * 60 * 60 + , getTargetSpacing = 10 * 60 + , getCheckpoints = + [ ( 11111 + , "0000000069e244f73d78e8fd29ba2fd2ed618bd6fa2ee92559f542fdb26e7c1d") + , ( 33333 + , "000000002dd5588a74784eaa7ab0507a18ad16a236e7b1ce69f00d7ddfb5d0a6") + , ( 74000 + , "0000000000573993a3c9e41ce34471c079dcf5f52a0e824a81e7f953b8661a20") + , ( 105000 + , "00000000000291ce28027faea320c8d2b054b2e0fe44a773f3eefb151d6bdc97") + , ( 134444 + , "00000000000005b12ffd4cd315cd34ffd4a594f430ac814c91184a0d42d2b0fe") + , ( 168000 + , "000000000000099e61ea72015e79632f216fe6cb33d7899acb35b75c8303b763") + , ( 193000 + , "000000000000059f452a5f7340de6682a977387c17010ff6e6c3bd83ca8b1317") + , ( 210000 + , "000000000000048b95347e83192f69cf0366076336c639f9b7228e9ba171342e") + , ( 216116 + , "00000000000001b4f4b433e81ee46494af945cf96014816a4e2370f11b23df4e") + , ( 225430 + , "00000000000001c108384350f74090433e7fcf79a606b8e797f065b130575932") + , ( 250000 + , "000000000000003887df1f29024b06fc2200b55f8af8f35453d7be294df2d214") + , ( 279000 + , "0000000000000001ae8c72a0b0c301f67e3afca10e819efa9041e458e9bd7e40") + , ( 295000 + , "00000000000000004d9b4ef50f0f9d686fd69db2e03af35a100370c64632a983") + ] + , getSeeds = + [ "seed.bitcoin.sipa.be" -- Pieter Wuille + , "dnsseed.bluematt.me" -- Matt Corallo + , "dnsseed.bitcoin.dashjr.org" -- Luke Dashjr + , "seed.bitcoinstats.com" -- Chris Decker + , "seed.bitcoin.jonasschnelli.ch" -- Jonas Schnelli + , "seed.btc.petertodd.org" -- Peter Todd + , "seed.bitcoin.sprovoost.nl" -- Sjors Provoost + ] + , getBip44Coin = 0 + , getSigHashForkId = Nothing + , getEdaBlockHeight = Nothing + , getDaaBlockHeight = Nothing + , getSegWit = True + , getCashAddrPrefix = Nothing + , getBech32Prefix = Just "bc" + , getReplaceByFee = True + , getHalvingInterval = 210000 + } + +-- | Testnet for Bitcoin SegWit network. +btcTest :: Network +btcTest = + Network + { getNetworkName = "btctest" + , getNetworkIdent = "btcTest" + , getAddrPrefix = 111 + , getScriptPrefix = 196 + , getSecretPrefix = 239 + , getExtPubKeyPrefix = 0x043587cf + , getExtSecretPrefix = 0x04358394 + , getNetworkMagic = 0x0b110907 + , getGenesisHeader = + BlockHeader + 0x01 + "0000000000000000000000000000000000000000000000000000000000000000" + "3ba3edfd7a7b12b27ac72c3e67768f617fc81bc3888a51323a9fb8aa4b1e5e4a" + 1296688602 + 486604799 + 414098458 + -- Hash 000000000933ea01ad0ee984209779baaec3ced90fa3f408719526f8d77f4943 + , getMaxBlockSize = 1000000 + , getMaxSatoshi = 2100000000000000 + , getHaskoinUserAgent = "/haskoin-btc-test:" <> versionString <> "/" + , getDefaultPort = 18333 + , getAllowMinDifficultyBlocks = True + , getPowNoRetargetting = False + , getPowLimit = + 0x00000000ffffffffffffffffffffffffffffffffffffffffffffffffffffffff + , getBip34Block = + ( 21111 + , "0000000023b3a96d3484e5abb3755c413e7d41500f8e2a5c3f0dd01299cd8ef8") + , getBip65Height = 581885 + , getBip66Height = 330776 + , getTargetTimespan = 14 * 24 * 60 * 60 + , getTargetSpacing = 10 * 60 + , getCheckpoints = + [ ( 546 + , "000000002a936ca763904c3c35fce2f3556c559c0214345d31b1bcebf76acb70") + ] + , getSeeds = + [ "testnet-seed.bitcoin.jonasschnelli.ch" + , "seed.tbtc.petertodd.org" + , "seed.testnet.bitcoin.sprovoost.nl" + , "testnet-seed.bluematt.me" + ] + , getBip44Coin = 1 + , getSigHashForkId = Nothing + , getEdaBlockHeight = Nothing + , getDaaBlockHeight = Nothing + , getSegWit = True + , getCashAddrPrefix = Nothing + , getBech32Prefix = Just "tb" + , getReplaceByFee = True + , getHalvingInterval = 210000 + } + +-- | RegTest for Bitcoin SegWit network. +btcRegTest :: Network +btcRegTest = + Network + { getNetworkName = "btcreg" + , getNetworkIdent = "btcRegTest" + , getAddrPrefix = 111 + , getScriptPrefix = 196 + , getSecretPrefix = 239 + , getExtPubKeyPrefix = 0x043587cf + , getExtSecretPrefix = 0x04358394 + , getNetworkMagic = 0xfabfb5da + , getGenesisHeader = + BlockHeader + -- 0f9188f13cb7b2c71f2a335e3a4fc328bf5beb436012afca590b1a11466e2206 + 0x01 + "0000000000000000000000000000000000000000000000000000000000000000" + "3ba3edfd7a7b12b27ac72c3e67768f617fc81bc3888a51323a9fb8aa4b1e5e4a" + 1296688602 + 0x207fffff + 2 + , getMaxBlockSize = 1000000 + , getMaxSatoshi = 2100000000000000 + , getHaskoinUserAgent = "/haskoin-btc-regtest:" <> versionString <> "/" + , getDefaultPort = 18444 + , getAllowMinDifficultyBlocks = True + , getPowNoRetargetting = True + , getPowLimit = + 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + , getBip34Block = + ( 100000000 + , "0000000000000000000000000000000000000000000000000000000000000000") + , getBip65Height = 1351 + , getBip66Height = 1251 + , getTargetTimespan = 14 * 24 * 60 * 60 + , getTargetSpacing = 10 * 60 + , getCheckpoints = [] + , getSeeds = ["localhost"] + , getBip44Coin = 1 + , getSigHashForkId = Nothing + , getEdaBlockHeight = Nothing + , getDaaBlockHeight = Nothing + , getSegWit = True + , getCashAddrPrefix = Nothing + , getBech32Prefix = Just "bcrt" + , getReplaceByFee = True + , getHalvingInterval = 150 + } + +-- | Bitcoin Cash network. Symbol: BCH. +bch :: Network +bch = + Network + { getNetworkName = "bch" + , getNetworkIdent = "bch" + , getAddrPrefix = 0 + , getScriptPrefix = 5 + , getSecretPrefix = 128 + , getExtPubKeyPrefix = 0x0488b21e + , getExtSecretPrefix = 0x0488ade4 + , getNetworkMagic = 0xe3e1f3e8 + , getGenesisHeader = + BlockHeader + 0x01 + "0000000000000000000000000000000000000000000000000000000000000000" + "3ba3edfd7a7b12b27ac72c3e67768f617fc81bc3888a51323a9fb8aa4b1e5e4a" + 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-abc.bitcoinforks.org" + , "btccash-seeder.bitcoinunlimited.info" + , "seed.bitprim.org" + , "seed.deadalnix.me" + , "seeder.criptolayer.net" + ] + , getBip44Coin = 145 + , getSigHashForkId = Just 0 + , getEdaBlockHeight = Just 478559 + , getDaaBlockHeight = Just 404031 + , getSegWit = False + , getCashAddrPrefix = Just "bitcoincash" + , getBech32Prefix = Nothing + , getReplaceByFee = False + , getHalvingInterval = 210000 + } + +-- | Testnet for Bitcoin Cash network. +bchTest :: Network +bchTest = + Network + { getNetworkName = "bchtest" + , getNetworkIdent = "bchTest" + , getAddrPrefix = 111 + , getScriptPrefix = 196 + , getSecretPrefix = 239 + , getExtPubKeyPrefix = 0x043587cf + , getExtSecretPrefix = 0x04358394 + , getNetworkMagic = 0xf4e5f3f4 + , getGenesisHeader = + BlockHeader + 0x01 + "0000000000000000000000000000000000000000000000000000000000000000" + "3ba3edfd7a7b12b27ac72c3e67768f617fc81bc3888a51323a9fb8aa4b1e5e4a" + 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-abc.bitcoinforks.org" + , "testnet-seed.bitprim.org" + , "testnet-seed.deadalnix.me" + , "testnet-seeder.criptolayer.net" + ] + , getBip44Coin = 1 + , getSigHashForkId = Just 0 + , getEdaBlockHeight = Just 1155876 + , getDaaBlockHeight = Just 1188697 + , getSegWit = False + , getCashAddrPrefix = Just "bchtest" + , getBech32Prefix = Nothing + , getReplaceByFee = False + , getHalvingInterval = 210000 + } + +-- | RegTest for Bitcoin Cash network. +bchRegTest :: Network +bchRegTest = + Network + { getNetworkName = "bchreg" + , getNetworkIdent = "bchRegTest" + , getAddrPrefix = 111 + , getScriptPrefix = 196 + , getSecretPrefix = 239 + , getExtPubKeyPrefix = 0x043587cf + , getExtSecretPrefix = 0x04358394 + , getNetworkMagic = 0xdab5bffa + , getGenesisHeader = + BlockHeader + -- 0f9188f13cb7b2c71f2a335e3a4fc328bf5beb436012afca590b1a11466e2206 + 0x01 + "0000000000000000000000000000000000000000000000000000000000000000" + "3ba3edfd7a7b12b27ac72c3e67768f617fc81bc3888a51323a9fb8aa4b1e5e4a" + 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 + , 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, bchTest, btcRegTest, bchRegTest] diff --git a/src/Haskoin/Crypto.hs b/src/Haskoin/Crypto.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Crypto.hs @@ -0,0 +1,22 @@ +{-| +Module : Haskoin.Crypto +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Hashing functions and ECDSA signatures. +-} +module Haskoin.Crypto + ( -- * Hashes + module Hash + -- * Signatures + , module Signature + -- * Secp256k1 (re-exported) + , module Secp256k1 + ) where + +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 new file mode 100644 --- /dev/null +++ b/src/Haskoin/Crypto/Hash.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-| +Module : Haskoin.Crypto.Hash +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Hashing functions and corresponding data types. Uses functions from the +cryptonite library. +-} +module Haskoin.Crypto.Hash + ( -- * Hashes + Hash512(getHash512) + , Hash256(getHash256) + , Hash160(getHash160) + , CheckSum32(getCheckSum32) + , sha512 + , sha256 + , ripemd160 + , sha1 + , doubleSHA256 + , addressHash + , checkSum32 + , hmac512 + , hmac256 + , split512 + , join512 + ) where + +import Control.DeepSeq +import Crypto.Hash (RIPEMD160 (..), SHA1 (..), + SHA256 (..), SHA512 (..), hashWith) +import Crypto.MAC.HMAC (HMAC, hmac) +import Data.ByteArray (ByteArrayAccess) +import qualified Data.ByteArray as BA +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as BSS +import Data.Either (fromRight) +import Data.Hashable (Hashable) +import Data.Serialize (Serialize (..), decode) +import qualified Data.Serialize.Get as Get +import qualified Data.Serialize.Put as Put +import Data.String (IsString, fromString) +import Data.String.Conversions (cs) +import Data.Word (Word32) +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, Serialize, Show, Read, Hashable, Generic, NFData) + +-- | 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 + Nothing -> e + Just bs -> + case BS.length bs of + 64 -> Hash512 (BSS.toShort bs) + _ -> e + where + e = error "Could not decode hash from hex string" + +instance Serialize Hash512 where + get = Hash512 <$> Get.getShortByteString 64 + put = Put.putShortByteString . getHash512 + +instance IsString Hash256 where + fromString str = + case decodeHex $ cs str of + Nothing -> e + Just bs -> + case BS.length bs of + 32 -> Hash256 (BSS.toShort bs) + _ -> e + where + e = error "Could not decode hash from hex string" + +instance Serialize Hash256 where + get = Hash256 <$> Get.getShortByteString 32 + put = Put.putShortByteString . getHash256 + +instance IsString Hash160 where + fromString str = + case decodeHex $ cs str of + Nothing -> e + Just bs -> + case BS.length bs of + 20 -> Hash160 (BSS.toShort bs) + _ -> e + where + e = error "Could not decode hash from hex string" + +instance Serialize Hash160 where + get = Hash160 <$> Get.getShortByteString 20 + put = Put.putShortByteString . getHash160 + +-- | 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. +checkSum32 :: ByteArrayAccess b => b -> CheckSum32 +checkSum32 = fromRight (error "Could not decode bytes as CheckSum32") + . decode + . BS.take 4 + . BA.convert + . hashWith SHA256 + . hashWith SHA256 + +{- HMAC -} + +-- | Computes HMAC over SHA-512. +hmac512 :: ByteString -> ByteString -> Hash512 +hmac512 key msg = + Hash512 $ BSS.toShort $ BA.convert (hmac key msg :: HMAC SHA512) + +-- | 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 = + (Hash256 (BSS.toShort a), Hash256 (BSS.toShort b)) + 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) = + Hash512 . + BSS.toShort $ + BSS.fromShort (getHash256 a) `BS.append` BSS.fromShort (getHash256 b) diff --git a/src/Haskoin/Crypto/Signature.hs b/src/Haskoin/Crypto/Signature.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Crypto/Signature.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Haskoin.Crypto.Signature +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +ECDSA signatures using secp256k1 curve. Uses functions from upstream secp256k1 +library. +-} +module Haskoin.Crypto.Signature + ( putSig + , getSig + , signHash + , verifyHashSig + , isCanonicalHalfOrder + , decodeStrictSig + , exportSig + ) where + +import Control.Monad (guard, unless, when) +import Crypto.Secp256k1 +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.ByteString.Short (toShort) +import Data.Maybe (fromMaybe) +import Data.Serialize as S +import Data.Serialize.Put (Putter, putByteString) +import Haskoin.Crypto.Hash +import Numeric (showHex) + +-- | Convert 256-bit hash into a 'Msg' for signing or verification. +hashToMsg :: Hash256 -> Msg +hashToMsg = + fromMaybe e . msg . encode + 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 g m + where + (g, _) = normalizeSig s + m = hashToMsg h + +-- | Deserialize an ECDSA signature as commonly encoded in Bitcoin. +getSig :: Get Sig +getSig = do + l <- lookAhead $ do + t <- getWord8 + -- 0x30 is DER sequence type + unless (t == 0x30) $ fail $ + "Bad DER identifier byte 0x" ++ showHex t ". Expecting 0x30" + l <- getWord8 + when (l == 0x00) $ fail "Indeterminate form unsupported" + when (l >= 0x80) $ fail "Multi-octect length not supported" + return $ fromIntegral l + bs <- getByteString $ l + 2 + case decodeStrictSig bs of + Just s -> return s + Nothing -> fail "Invalid signature" + +-- | Serialize an ECDSA signature for Bitcoin use. +putSig :: Putter Sig +putSig s = putByteString $ exportSig s + +-- | Is canonical half order. +isCanonicalHalfOrder :: Sig -> Bool +isCanonicalHalfOrder = not . snd . normalizeSig + +-- | Decode signature strictly. +decodeStrictSig :: ByteString -> Maybe Sig +decodeStrictSig bs = do + g <- importSig bs + let compact = exportCompactSig g + -- + -- 4.1.4.1 (r and s can not be zero) + guard $ getCompactSigR compact /= zero + guard $ getCompactSigS compact /= zero + guard $ isCanonicalHalfOrder g + return g + where + zero = toShort $ BS.replicate 32 0 diff --git a/src/Haskoin/Keys.hs b/src/Haskoin/Keys.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Keys.hs @@ -0,0 +1,22 @@ +{-| +Module : Haskoin.Keys +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +ECDSA private and public keys, extended keys (BIP-32) and mnemonic sentences +(BIP-39). +-} +module Haskoin.Keys + ( module Haskoin.Keys.Common + -- * Extended Keys + , module Haskoin.Keys.Extended + -- * Mnemonic + , module Haskoin.Keys.Mnemonic + ) where + +import Haskoin.Keys.Common +import Haskoin.Keys.Extended +import Haskoin.Keys.Mnemonic diff --git a/src/Haskoin/Keys/Common.hs b/src/Haskoin/Keys/Common.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Keys/Common.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Haskoin.Keys.Common +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +ECDSA private and public key functions. +-} +module Haskoin.Keys.Common + ( -- * Public & Private Keys + PubKeyI(..) + , SecKeyI(..) + , exportPubKey + , importPubKey + , wrapPubKey + , derivePubKeyI + , wrapSecKey + , fromMiniKey + , tweakPubKey + , tweakSecKey + , secKeyPut + , secKeyGet + , getSecKey + , secKey + ) where + +import Control.Applicative ((<|>)) +import Control.DeepSeq +import Control.Monad (guard, mzero, (<=<)) +import Crypto.Secp256k1 +import Data.Aeson (FromJSON, ToJSON (..), Value (String), + parseJSON, withText) +import Data.Aeson.Encoding (unsafeToEncoding) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.ByteString.Builder (char7) +import Data.Hashable +import Data.Maybe (fromMaybe) +import Data.Serialize (Serialize, decode, encode, get, put) +import Data.Serialize.Get (Get, getByteString) +import Data.Serialize.Put (Putter, putByteString) +import Data.String (IsString, fromString) +import Data.String.Conversions (cs) +import GHC.Generics (Generic) +import Haskoin.Crypto.Hash +import Haskoin.Util + +-- | Elliptic curve public key type with expected serialized compression flag. +data PubKeyI = PubKeyI + { pubKeyPoint :: !PubKey + , pubKeyCompressed :: !Bool + } deriving (Generic, Eq, Show, Read, Hashable, NFData) + +instance IsString PubKeyI where + fromString str = + fromMaybe e $ eitherToMaybe . decode <=< decodeHex $ cs str + where + e = error "Could not decode public key" + +instance ToJSON PubKeyI where + toJSON = String . encodeHex . encode + toEncoding s = unsafeToEncoding $ char7 '"' <> hexBuilder (encode s) <> char7 '"' + +instance FromJSON PubKeyI where + parseJSON = withText "PubKeyI" $ + maybe mzero return . (eitherToMaybe . decode =<<) . decodeHex + +instance Serialize PubKeyI where + get = c <|> u + where + c = do + bs <- getByteString 33 + guard $ BS.head bs `BS.elem` BS.pack [0x02, 0x03] + maybe mzero return $ PubKeyI <$> importPubKey bs <*> pure True + u = do + bs <- getByteString 65 + guard $ BS.head bs == 0x04 + maybe mzero return $ PubKeyI <$> importPubKey bs <*> pure False + + put pk = putByteString $ exportPubKey (pubKeyCompressed pk) (pubKeyPoint pk) + +-- | Wrap a public key from secp256k1 library adding information about compression. +wrapPubKey :: Bool -> PubKey -> PubKeyI +wrapPubKey c p = PubKeyI p c + +-- | Derives a public key from a private key. This function will preserve +-- compression flag. +derivePubKeyI :: SecKeyI -> PubKeyI +derivePubKeyI (SecKeyI d c) = PubKeyI (derivePubKey d) c + +-- | Tweak a public key. +tweakPubKey :: PubKey -> Hash256 -> Maybe PubKey +tweakPubKey p h = tweakAddPubKey p =<< tweak (encode h) + +-- | Elliptic curve private key type with expected public key compression +-- information. Compression information is stored in private key WIF formats and +-- needs to be preserved to generate the correct address from the corresponding +-- public key. +data SecKeyI = SecKeyI + { secKeyData :: !SecKey + , secKeyCompressed :: !Bool + } deriving (Eq, Show, Read, Generic, NFData) + +-- | Wrap private key with corresponding public key compression flag. +wrapSecKey :: Bool -> SecKey -> SecKeyI +wrapSecKey c d = SecKeyI d c + +-- | Deserialize 'SecKey'. +secKeyGet :: Get SecKey +secKeyGet = do + bs <- getByteString 32 + maybe (fail "invalid private key") return (secKey bs) + +-- | Serialize 'SecKey'. +secKeyPut :: Putter SecKey +secKeyPut = putByteString . getSecKey + +-- | Decode Casascius mini private keys (22 or 30 characters). +fromMiniKey :: ByteString -> Maybe SecKeyI +fromMiniKey bs = do + guard checkShortKey + wrapSecKey False <$> secKey (encode (sha256 bs)) + where + checkHash = encode $ sha256 $ bs `BS.append` "?" + checkShortKey = BS.length bs `elem` [22, 30] && BS.head checkHash == 0x00 + +-- | Tweak a private key. +tweakSecKey :: SecKey -> Hash256 -> Maybe SecKey +tweakSecKey key h = tweakAddSecKey key =<< tweak (encode h) diff --git a/src/Haskoin/Keys/Extended.hs b/src/Haskoin/Keys/Extended.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Keys/Extended.hs @@ -0,0 +1,918 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Haskoin.Keys.Extended +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +BIP-32 extended keys. +-} +module Haskoin.Keys.Extended + ( + -- * Extended Keys + XPubKey(..) + , XPrvKey(..) + , ChainCode + , KeyIndex + , Fingerprint + , DerivationException(..) + , makeXPrvKey + , deriveXPubKey + , prvSubKey + , pubSubKey + , hardSubKey + , xPrvIsHard + , xPubIsHard + , xPrvChild + , xPubChild + , xPubID + , xPrvID + , xPubFP + , xPrvFP + , xPubAddr + , xPubWitnessAddr + , xPubCompatWitnessAddr + , xPubExport + , xPubToJSON + , xPubToEncoding + , xPubFromJSON + , xPrvExport + , xPrvToJSON + , xPrvToEncoding + , xPrvFromJSON + , xPubImport + , xPrvImport + , xPrvWif + , putXPrvKey + , putXPubKey + , getXPrvKey + , getXPubKey + + -- ** Helper Functions + , prvSubKeys + , pubSubKeys + , hardSubKeys + , deriveAddr + , deriveWitnessAddr + , deriveCompatWitnessAddr + , deriveAddrs + , deriveWitnessAddrs + , deriveCompatWitnessAddrs + , deriveMSAddr + , deriveMSAddrs + , cycleIndex + + -- ** Derivation Paths + , DerivPathI(..) + , AnyDeriv, HardDeriv, SoftDeriv + , HardOrAny + , AnyOrSoft + , DerivPath + , HardPath + , SoftPath + , Bip32PathIndex (..) + , derivePath + , derivePubPath + , toHard + , toSoft + , toGeneric + , (++/) + , pathToStr + , listToPath + , pathToList + + -- *** Derivation Path Parser + , XKey(..) + , ParsedPath(..) + , parsePath + , parseHard + , parseSoft + , applyPath + , derivePathAddr + , derivePathAddrs + , derivePathMSAddr + , derivePathMSAddrs + , concatBip32Segments + ) where + +import Control.Applicative +import Control.DeepSeq +import Control.Exception (Exception, throw) +import Control.Monad (guard, mzero, unless, (<=<)) +import Crypto.Secp256k1 +import Data.Aeson as A (FromJSON, ToJSON (..), + Value (String), parseJSON, + toJSON, withText) +import Data.Aeson.Encoding (Encoding, text) +import Data.Aeson.Types (Parser) +import Data.Bits (clearBit, setBit, testBit) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Either (fromRight) +import Data.List (foldl') +import Data.List.Split (splitOn) +import Data.Maybe (fromMaybe) +import Data.Serialize as S (Serialize, decode, encode, get, + put) +import Data.Serialize.Get (Get, getWord32be, getWord8, runGet) +import Data.Serialize.Put (Putter, putWord32be, putWord8, runPut) +import Data.String (IsString, fromString) +import Data.String.Conversions (cs) +import Data.Typeable (Typeable) +import Data.Word (Word32, Word8) +import GHC.Generics (Generic) +import Haskoin.Address +import Haskoin.Constants +import Haskoin.Crypto.Hash +import Haskoin.Keys.Common +import Haskoin.Script +import Haskoin.Util +import Text.Read as R +import Text.Read.Lex + + +-- | A derivation exception is thrown in the very unlikely event that a +-- derivation is invalid. +newtype DerivationException = DerivationException String + deriving (Eq, Read, Show, Typeable, Generic, NFData) + +instance Exception DerivationException + +-- | Chain code as specified in BIP-32. +type ChainCode = Hash256 + +-- | Index of key as specified in BIP-32. +type KeyIndex = Word32 + +-- | Fingerprint of parent +type Fingerprint = Word32 + +-- | Data type representing an extended BIP32 private key. An extended key +-- is a node in a tree of key derivations. It has a depth in the tree, a +-- parent node and an index to differentiate it from other siblings. +data XPrvKey = XPrvKey + { xPrvDepth :: !Word8 -- ^ depth in the tree + , xPrvParent :: !Fingerprint -- ^ fingerprint of parent + , xPrvIndex :: !KeyIndex -- ^ derivation index + , xPrvChain :: !ChainCode -- ^ chain code + , xPrvKey :: !SecKey -- ^ private key of this node + } deriving (Generic, Eq, Show, Read, NFData) + +xPrvToJSON :: Network -> XPrvKey -> Value +xPrvToJSON net = A.String . xPrvExport net + +xPrvToEncoding :: Network -> XPrvKey -> Encoding +xPrvToEncoding net = text . xPrvExport net + +-- | Data type representing an extended BIP32 public key. +data XPubKey = XPubKey + { xPubDepth :: !Word8 -- ^ depth in the tree + , xPubParent :: !Fingerprint -- ^ fingerprint of parent + , xPubIndex :: !KeyIndex -- ^ derivation index + , xPubChain :: !ChainCode -- ^ chain code + , xPubKey :: !PubKey -- ^ public key of this node + } deriving (Generic, Eq, Show, Read, NFData) + + +-- | Decode an extended public key from a JSON string +xPubFromJSON :: Network -> Value -> Parser XPubKey +xPubFromJSON net = + withText "xpub" $ \t -> + case xPubImport net t of + Nothing -> fail "could not read xpub" + Just x -> return x + +-- | Get JSON 'Value' from 'XPubKey'. +xPubToJSON :: Network -> XPubKey -> Value +xPubToJSON net = A.String . xPubExport net + +xPubToEncoding :: Network -> XPubKey -> Encoding +xPubToEncoding net = text . xPubExport net + +-- | Decode an extended private key from a JSON string +xPrvFromJSON :: Network -> Value -> Parser XPrvKey +xPrvFromJSON net = + withText "xprv" $ \t -> + case xPrvImport net t of + Nothing -> fail "could not read xprv" + Just x -> return x + +-- | 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 0 0 c k + where + (p, c) = split512 $ hmac512 "Bitcoin seed" bs + k = fromMaybe err (secKey (encode p)) + err = throw $ DerivationException "Invalid seed" + +-- | Derive an extended public key from an extended private key. This function +-- will preserve the depth, parent, index and chaincode fields of the extended +-- private keys. +deriveXPubKey :: XPrvKey -> XPubKey +deriveXPubKey (XPrvKey d p i c k) = XPubKey d p i c (derivePubKey k) + +-- | Compute a private, soft child key derivation. A private soft derivation +-- will allow the equivalent extended public key to derive the public key for +-- this child. Given a parent key /m/ and a derivation index /i/, this function +-- will compute /m\/i/. +-- +-- Soft derivations allow for more flexibility such as read-only wallets. +-- However, care must be taken not the leak both the parent extended public key +-- and one of the extended child private keys as this would compromise the +-- extended parent private key. +prvSubKey :: XPrvKey -- ^ extended parent private key + -> KeyIndex -- ^ child derivation index + -> XPrvKey -- ^ extended child private key +prvSubKey xkey child + | child >= 0 && child < 0x80000000 = + XPrvKey (xPrvDepth xkey + 1) (xPrvFP xkey) child c k + | otherwise = error "Invalid child derivation index" + where + pK = xPubKey $ deriveXPubKey xkey + m = B.append (exportPubKey True pK) (encode child) + (a, c) = split512 $ hmac512 (encode $ xPrvChain xkey) m + k = fromMaybe err $ tweakSecKey (xPrvKey xkey) a + err = throw $ DerivationException "Invalid prvSubKey derivation" + +-- | Compute a public, soft child key derivation. Given a parent key /M/ +-- and a derivation index /i/, this function will compute /M\/i/. +pubSubKey :: XPubKey -- ^ extended parent public key + -> KeyIndex -- ^ child derivation index + -> XPubKey -- ^ extended child public key +pubSubKey xKey child + | child >= 0 && child < 0x80000000 = + XPubKey (xPubDepth xKey + 1) (xPubFP xKey) child c pK + | otherwise = error "Invalid child derivation index" + where + m = B.append (exportPubKey True (xPubKey xKey)) (encode child) + (a, c) = split512 $ hmac512 (encode $ xPubChain xKey) m + pK = fromMaybe err $ tweakPubKey (xPubKey xKey) a + err = throw $ DerivationException "Invalid pubSubKey derivation" + +-- | Compute a hard child key derivation. Hard derivations can only be computed +-- for private keys. Hard derivations do not allow the parent public key to +-- derive the child public keys. However, they are safer as a breach of the +-- parent public key and child private keys does not lead to a breach of the +-- parent private key. Given a parent key /m/ and a derivation index /i/, this +-- function will compute /m\/i'/. +hardSubKey :: XPrvKey -- ^ extended parent private key + -> KeyIndex -- ^ child derivation index + -> XPrvKey -- ^ extended child private key +hardSubKey xkey child + | child >= 0 && child < 0x80000000 = + XPrvKey (xPrvDepth xkey + 1) (xPrvFP xkey) i c k + | otherwise = error "Invalid child derivation index" + where + i = setBit child 31 + m = B.append (bsPadPrvKey $ xPrvKey xkey) (encode i) + (a, c) = split512 $ hmac512 (encode $ xPrvChain xkey) m + k = fromMaybe err $ tweakSecKey (xPrvKey xkey) a + err = throw $ DerivationException "Invalid hardSubKey derivation" + +-- | Returns true if the extended private key was derived through a hard +-- derivation. +xPrvIsHard :: XPrvKey -> Bool +xPrvIsHard k = testBit (xPrvIndex k) 31 + +-- | Returns true if the extended public key was derived through a hard +-- derivation. +xPubIsHard :: XPubKey -> Bool +xPubIsHard k = testBit (xPubIndex k) 31 + +-- | Returns the derivation index of this extended private key without the hard +-- bit set. +xPrvChild :: XPrvKey -> KeyIndex +xPrvChild k = clearBit (xPrvIndex k) 31 + +-- | Returns the derivation index of this extended public key without the hard +-- bit set. +xPubChild :: XPubKey -> KeyIndex +xPubChild k = clearBit (xPubIndex k) 31 + +-- | Computes the key identifier of an extended private key. +xPrvID :: XPrvKey -> Hash160 +xPrvID = xPubID . deriveXPubKey + +-- | Computes the key identifier of an extended public key. +xPubID :: XPubKey -> Hash160 +xPubID = ripemd160 . encode . sha256 . exportPubKey True . xPubKey + +-- | Computes the key fingerprint of an extended private key. +xPrvFP :: XPrvKey -> Fingerprint +xPrvFP = + fromRight err . decode . B.take 4 . encode . xPrvID + where + err = error "Could not decode xPrvFP" + +-- | Computes the key fingerprint of an extended public key. +xPubFP :: XPubKey -> Fingerprint +xPubFP = + fromRight err . decode . B.take 4 . encode . xPubID + where + err = error "Could not decode xPubFP" + +-- | Compute a standard P2PKH address for an extended public key. +xPubAddr :: XPubKey -> Address +xPubAddr xkey = pubKeyAddr (wrapPubKey True (xPubKey xkey)) + +-- | Compute a SegWit P2WPKH address for an extended public key. +xPubWitnessAddr :: XPubKey -> Address +xPubWitnessAddr xkey = pubKeyWitnessAddr (wrapPubKey True (xPubKey xkey)) + +-- | Compute a backwards-compatible SegWit P2SH-P2WPKH address for an extended +-- public key. +xPubCompatWitnessAddr :: XPubKey -> Address +xPubCompatWitnessAddr xkey = + pubKeyCompatWitnessAddr (wrapPubKey True (xPubKey xkey)) + +-- | Exports an extended private key to the BIP32 key export format ('Base58'). +xPrvExport :: Network -> XPrvKey -> Base58 +xPrvExport net = encodeBase58Check . runPut . putXPrvKey net + +-- | Exports an extended public key to the BIP32 key export format ('Base58'). +xPubExport :: Network -> XPubKey -> Base58 +xPubExport net = encodeBase58Check . runPut . putXPubKey net + +-- | Decodes a BIP32 encoded extended private key. This function will fail if +-- invalid base 58 characters are detected or if the checksum fails. +xPrvImport :: Network -> Base58 -> Maybe XPrvKey +xPrvImport net = eitherToMaybe . runGet (getXPrvKey net) <=< decodeBase58Check + +-- | Decodes a BIP32 encoded extended public key. This function will fail if +-- invalid base 58 characters are detected or if the checksum fails. +xPubImport :: Network -> Base58 -> Maybe XPubKey +xPubImport net = eitherToMaybe . runGet (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 :: Network -> Get XPrvKey +getXPrvKey net = do + ver <- getWord32be + unless (ver == getExtSecretPrefix net) $ fail + "Get: Invalid version for extended private key" + XPrvKey <$> getWord8 + <*> getWord32be + <*> getWord32be + <*> S.get + <*> getPadPrvKey + +-- | Serialize an extended private key. +putXPrvKey :: Network -> Putter XPrvKey +putXPrvKey net k = do + putWord32be $ getExtSecretPrefix net + putWord8 $ xPrvDepth k + putWord32be $ xPrvParent k + putWord32be $ xPrvIndex k + put $ xPrvChain k + putPadPrvKey $ xPrvKey k + +-- | Parse a binary extended public key. +getXPubKey :: Network -> Get XPubKey +getXPubKey net = do + ver <- getWord32be + unless (ver == getExtPubKeyPrefix net) $ fail + "Get: Invalid version for extended public key" + XPubKey <$> getWord8 + <*> getWord32be + <*> getWord32be + <*> S.get + <*> (pubKeyPoint <$> S.get) + +-- | Serialize an extended public key. +putXPubKey :: Network -> Putter XPubKey +putXPubKey net k = do + putWord32be $ getExtPubKeyPrefix net + putWord8 $ xPubDepth k + putWord32be $ xPubParent k + putWord32be $ xPubIndex k + put $ xPubChain k + put $ wrapPubKey True (xPubKey k) + +{- Derivation helpers -} + +-- | Cyclic list of all private soft child key derivations of a parent key +-- starting from an offset index. +prvSubKeys :: XPrvKey -> KeyIndex -> [(XPrvKey, KeyIndex)] +prvSubKeys k = map (\i -> (prvSubKey k i, i)) . cycleIndex + +-- | Cyclic list of all public soft child key derivations of a parent key +-- starting from an offset index. +pubSubKeys :: XPubKey -> KeyIndex -> [(XPubKey, KeyIndex)] +pubSubKeys k = map (\i -> (pubSubKey k i, i)) . cycleIndex + +-- | Cyclic list of all hard child key derivations of a parent key starting +-- from an offset index. +hardSubKeys :: XPrvKey -> KeyIndex -> [(XPrvKey, KeyIndex)] +hardSubKeys k = map (\i -> (hardSubKey k i, i)) . cycleIndex + +-- | Derive a standard address from an extended public key and an index. +deriveAddr :: XPubKey -> KeyIndex -> (Address, PubKey) +deriveAddr k i = + (xPubAddr key, xPubKey key) + where + key = pubSubKey k i + +-- | Derive a SegWit P2WPKH address from an extended public key and an index. +deriveWitnessAddr :: XPubKey -> KeyIndex -> (Address, PubKey) +deriveWitnessAddr k i = + (xPubWitnessAddr key, xPubKey key) + where + key = pubSubKey k i + +-- | Derive a backwards-compatible SegWit P2SH-P2WPKH address from an extended +-- public key and an index. +deriveCompatWitnessAddr :: XPubKey -> KeyIndex -> (Address, PubKey) +deriveCompatWitnessAddr k i = + (xPubCompatWitnessAddr key, xPubKey key) + where + key = pubSubKey k i + +-- | Cyclic list of all addresses derived from a public key starting from an +-- offset index. +deriveAddrs :: XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)] +deriveAddrs k = + map f . cycleIndex + where + f i = let (a, key) = deriveAddr k i in (a, key, i) + +-- | Cyclic list of all SegWit P2WPKH addresses derived from a public key +-- starting from an offset index. +deriveWitnessAddrs :: XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)] +deriveWitnessAddrs k = + map f . cycleIndex + where + f i = let (a, key) = deriveWitnessAddr k i in (a, key, i) + +-- | Cyclic list of all backwards-compatible SegWit P2SH-P2WPKH addresses +-- derived from a public key starting from an offset index. +deriveCompatWitnessAddrs :: XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)] +deriveCompatWitnessAddrs k = + map f . cycleIndex + where + f i = let (a, key) = deriveCompatWitnessAddr k i in (a, key, i) + +-- | Derive a multisig address from a list of public keys, the number of +-- required signatures /m/ and a derivation index. The derivation type is a +-- public, soft derivation. +deriveMSAddr :: [XPubKey] -> Int -> KeyIndex -> (Address, RedeemScript) +deriveMSAddr keys m i = (payToScriptAddress rdm, rdm) + where + rdm = sortMulSig $ PayMulSig k m + k = map (wrapPubKey True . xPubKey . flip pubSubKey i) keys + +-- | Cyclic list of all multisig addresses derived from a list of public keys, +-- a number of required signatures /m/ and starting from an offset index. The +-- derivation type is a public, soft derivation. +deriveMSAddrs :: [XPubKey] -> Int -> KeyIndex + -> [(Address, RedeemScript, KeyIndex)] +deriveMSAddrs keys m = map f . cycleIndex + where + f i = + let (a, rdm) = deriveMSAddr keys m i + in (a, rdm, i) + +-- | Helper function to go through derivation indices. +cycleIndex :: KeyIndex -> [KeyIndex] +cycleIndex i + | i == 0 = cycle [0..0x7fffffff] + | i < 0x80000000 = cycle $ [i..0x7fffffff] ++ [0..(i-1)] + | otherwise = error $ "cycleIndex: invalid index " ++ show i + +{- Derivation Paths -} + +-- | Phantom type signaling a hardened derivation path that can only be computed +-- from private extended key. +data HardDeriv deriving (Generic, NFData) + +-- | Phantom type signaling no knowledge about derivation path: can be hardened or not. +data AnyDeriv deriving (Generic, NFData) + +-- | Phantom type signaling derivation path including only non-hardened paths +-- that can be computed from an extended public key. +data SoftDeriv deriving (Generic, NFData) + +-- | Hardened derivation path. Can be computed from extended private key only. +type HardPath = DerivPathI HardDeriv + +-- | Any derivation path. +type DerivPath = DerivPathI AnyDeriv + +-- | Non-hardened derivation path can be computed from extended public key. +type SoftPath = DerivPathI SoftDeriv + +-- | Helper class to perform validations on a hardened derivation path. +class HardOrAny a +instance HardOrAny HardDeriv +instance HardOrAny AnyDeriv + +-- | Helper class to perform validations on a non-hardened derivation path. +class AnyOrSoft a +instance AnyOrSoft AnyDeriv +instance AnyOrSoft SoftDeriv + +-- | Data type representing a derivation path. Two constructors are provided +-- for specifying soft or hard derivations. The path /\/0\/1'\/2/ for example can be +-- expressed as @'Deriv' :\/ 0 :| 1 :\/ 2@. The 'HardOrAny' and 'AnyOrSoft' type +-- classes are used to constrain the valid values for the phantom type /t/. If +-- you mix hard '(:|)' and soft '(:\/)' paths, the only valid type for /t/ is 'AnyDeriv'. +-- Otherwise, /t/ can be 'HardDeriv' if you only have hard derivation or 'SoftDeriv' +-- if you only have soft derivations. +-- +-- Using this type is as easy as writing the required derivation like in these +-- example: +-- +-- > Deriv :/ 0 :/ 1 :/ 2 :: SoftPath +-- > Deriv :| 0 :| 1 :| 2 :: HardPath +-- > Deriv :| 0 :/ 1 :/ 2 :: DerivPath +data DerivPathI t where + (:|) :: HardOrAny t => !(DerivPathI t) -> !KeyIndex -> DerivPathI t + (:/) :: AnyOrSoft t => !(DerivPathI t) -> !KeyIndex -> DerivPathI t + Deriv :: DerivPathI t + +instance NFData (DerivPathI t) where + rnf (a :| b) = rnf a `seq` rnf b `seq` () + rnf (a :/ b) = rnf a `seq` rnf b `seq` () + rnf Deriv = () + +instance Eq (DerivPathI t) where + (nextA :| iA) == (nextB :| iB) = iA == iB && nextA == nextB + (nextA :/ iA) == (nextB :/ iB) = iA == iB && nextA == nextB + Deriv == Deriv = True + _ == _ = False + +instance Ord (DerivPathI t) where + -- Same hardness on each side + (nextA :| iA) `compare` (nextB :| iB) = + if nextA == nextB then iA `compare` iB else nextA `compare` nextB + (nextA :/ iA) `compare` (nextB :/ iB) = + if nextA == nextB then iA `compare` iB else nextA `compare` nextB + + -- Different hardness: hard paths are LT soft paths + (nextA :/ _iA) `compare` (nextB :| _iB) = + if nextA == nextB then LT else nextA `compare` nextB + (nextA :| _iA) `compare` (nextB :/ _iB) = + if nextA == nextB then GT else nextA `compare` nextB + + Deriv `compare` Deriv = EQ + Deriv `compare` _ = LT + _ `compare` Deriv = GT + + +instance Serialize DerivPath where + get = listToPath <$> S.get + put = put . pathToList + +-- | Get a list of derivation indices from a derivation path. +pathToList :: DerivPathI t -> [KeyIndex] +pathToList = + reverse . go + where + go (next :| i) = setBit i 31 : go next + go (next :/ i) = i : go next + go _ = [] + +-- | Convert a list of derivation indices to a derivation path. +listToPath :: [KeyIndex] -> DerivPath +listToPath = + go . reverse + where + go (i:is) + | testBit i 31 = go is :| clearBit i 31 + | otherwise = go is :/ i + go [] = Deriv + +-- | Convert a derivation path to a human-readable string. +pathToStr :: DerivPathI t -> String +pathToStr p = + case p of + next :| i -> concat [ pathToStr next, "/", show i, "'" ] + next :/ i -> concat [ pathToStr next, "/", show i ] + Deriv -> "" + +-- | Turn a derivation path into a hard derivation path. Will fail if the path +-- contains soft derivations. +toHard :: DerivPathI t -> Maybe HardPath +toHard p = case p of + next :| i -> (:| i) <$> toHard next + Deriv -> Just Deriv + _ -> Nothing + +-- | Turn a derivation path into a soft derivation path. Will fail if the path +-- has hard derivations. +toSoft :: DerivPathI t -> Maybe SoftPath +toSoft p = case p of + next :/ i -> (:/ i) <$> toSoft next + Deriv -> Just Deriv + _ -> Nothing + +-- | Make a derivation path generic. +toGeneric :: DerivPathI t -> DerivPath +toGeneric p = case p of + next :/ i -> toGeneric next :/ i + next :| i -> toGeneric next :| i + Deriv -> Deriv + +-- | Append two derivation paths together. The result will be a mixed +-- derivation path. +(++/) :: DerivPathI t1 -> DerivPathI t2 -> DerivPath +(++/) p1 p2 = + go id (toGeneric p2) $ toGeneric p1 + where + go f p = case p of + next :/ i -> go (f . (:/ i)) $ toGeneric next + next :| i -> go (f . (:| i)) $ toGeneric next + _ -> f + +-- | Derive a private key from a derivation path +derivePath :: DerivPathI t -> XPrvKey -> XPrvKey +derivePath = go id + where + -- Build the full derivation function starting from the end + go f p = case p of + next :| i -> go (f . flip hardSubKey i) next + next :/ i -> go (f . flip prvSubKey i) next + _ -> f + +-- | Derive a public key from a soft derivation path +derivePubPath :: SoftPath -> XPubKey -> XPubKey +derivePubPath = go id + where + -- Build the full derivation function starting from the end + go f p = case p of + next :/ i -> go (f . flip pubSubKey i) next + _ -> f + +instance Show DerivPath where + showsPrec d p = showParen (d > 10) $ + showString "DerivPath " . shows (pathToStr p) + +instance Read DerivPath where + readPrec = parens $ do + R.Ident "DerivPath" <- lexP + R.String str <- lexP + maybe pfail return $ getParsedPath <$> parsePath str + +instance Show HardPath where + showsPrec d p = showParen (d > 10) $ + showString "HardPath " . shows (pathToStr p) + +instance Read HardPath where + readPrec = parens $ do + R.Ident "HardPath" <- lexP + R.String str <- lexP + maybe pfail return $ parseHard str + +instance Show SoftPath where + showsPrec d p = showParen (d > 10) $ + showString "SoftPath " . shows (pathToStr p) + +instance Read SoftPath where + readPrec = parens $ do + R.Ident "SoftPath" <- lexP + R.String str <- lexP + maybe pfail return $ parseSoft str + +instance IsString ParsedPath where + fromString = + fromMaybe e . parsePath + where + e = error "Could not parse derivation path" + +instance IsString DerivPath where + fromString = + getParsedPath . fromMaybe e . parsePath + where + e = error "Could not parse derivation path" + +instance IsString HardPath where + fromString = + fromMaybe e . parseHard + where + e = error "Could not parse hard derivation path" + +instance IsString SoftPath where + fromString = + fromMaybe e . parseSoft + where + e = error "Could not parse soft derivation path" + +instance FromJSON ParsedPath where + parseJSON = withText "ParsedPath" $ \str -> case parsePath $ cs str of + Just p -> return p + _ -> mzero + +instance FromJSON DerivPath where + parseJSON = withText "DerivPath" $ \str -> case parsePath $ cs str of + Just p -> return $ getParsedPath p + _ -> mzero + +instance FromJSON HardPath where + parseJSON = withText "HardPath" $ \str -> case parseHard $ cs str of + Just p -> return p + _ -> mzero + +instance FromJSON SoftPath where + parseJSON = withText "SoftPath" $ \str -> case parseSoft $ cs str of + Just p -> return p + _ -> mzero + +instance ToJSON (DerivPathI t) where + toJSON = A.String . cs . pathToStr + +instance ToJSON ParsedPath where + toJSON (ParsedPrv p) = A.String . cs . ("m" ++) . pathToStr $ p + toJSON (ParsedPub p) = A.String . cs . ("M" ++) . pathToStr $ p + toJSON (ParsedEmpty p) = A.String . cs . ("" ++) . pathToStr $ p + +{- Parsing derivation paths of the form m/1/2'/3 or M/1/2'/3 -} + +-- | Type for parsing derivation paths of the form /m\/1\/2'\/3/ or +-- /M\/1\/2'\/3/. +data ParsedPath = ParsedPrv { getParsedPath :: !DerivPath } + | ParsedPub { getParsedPath :: !DerivPath } + | ParsedEmpty { getParsedPath :: !DerivPath } + deriving (Eq, Generic, NFData) + +instance Show ParsedPath where + showsPrec d p = showParen (d > 10) $ showString "ParsedPath " . shows f + where + f = + case p of + ParsedPrv d' -> "m" <> pathToStr d' + ParsedPub d' -> "M" <> pathToStr d' + ParsedEmpty d' -> pathToStr d' + +instance Read ParsedPath where + readPrec = parens $ do + R.Ident "ParsedPath" <- lexP + R.String str <- lexP + maybe pfail return $ parsePath str + +-- | Parse derivation path string for extended key. +-- Forms: /m\/0'\/2/, /M\/2\/3\/4/. +parsePath :: String -> Maybe ParsedPath +parsePath str = do + res <- concatBip32Segments <$> mapM parseBip32PathIndex xs + case x of + "m" -> Just $ ParsedPrv res + "M" -> Just $ ParsedPub res + "" -> Just $ ParsedEmpty res + _ -> Nothing + where + (x : xs) = splitOn "/" str + +-- | Concatenate derivation path indices into a derivation path. +concatBip32Segments :: [Bip32PathIndex] -> DerivPath +concatBip32Segments = foldl' appendBip32Segment Deriv + +-- | Append an extra derivation path index element into an existing path. +appendBip32Segment :: DerivPath -> Bip32PathIndex -> DerivPath +appendBip32Segment d (Bip32SoftIndex i) = d :/ i +appendBip32Segment d (Bip32HardIndex i) = d :| i + +-- | Parse a BIP32 derivation path index element from a string. +parseBip32PathIndex :: String -> Maybe Bip32PathIndex +parseBip32PathIndex segment = case reads segment of + [(i, "" )] -> guard (is31Bit i) >> return (Bip32SoftIndex i) + [(i, "'")] -> guard (is31Bit i) >> return (Bip32HardIndex i) + _ -> Nothing + +-- | Type for BIP32 path index element. +data Bip32PathIndex = Bip32HardIndex KeyIndex + | Bip32SoftIndex KeyIndex + deriving (Eq, Generic, NFData) + +instance Show Bip32PathIndex where + showsPrec d (Bip32HardIndex i) = showParen (d > 10) $ + showString "Bip32HardIndex " . shows i + showsPrec d (Bip32SoftIndex i) = showParen (d > 10) $ + showString "Bip32SoftIndex " . shows i + +instance Read Bip32PathIndex where + readPrec = h <|> s + where + h = + parens $ do + R.Ident "Bip32HardIndex" <- lexP + R.Number n <- lexP + maybe pfail return $ + Bip32HardIndex . fromIntegral <$> numberToInteger n + s = + parens $ do + R.Ident "Bip32SoftIndex" <- lexP + R.Number n <- lexP + maybe pfail return $ + Bip32SoftIndex . fromIntegral <$> numberToInteger n + +-- | Test whether the number could be a valid BIP32 derivation index. +is31Bit :: (Integral a) => a -> Bool +is31Bit i = i >= 0 && i < 0x80000000 + +-- | Helper function to parse a hard path. +parseHard :: String -> Maybe HardPath +parseHard = toHard . getParsedPath <=< parsePath + +-- | Helper function to parse a soft path. +parseSoft :: String -> Maybe SoftPath +parseSoft = toSoft . getParsedPath <=< parsePath + +-- | Data type representing a private or public key with its respective network. +data XKey + = XPrv { getXKeyPrv :: !XPrvKey + , getXKeyNet :: !Network } + | XPub { getXKeyPub :: !XPubKey + , getXKeyNet :: !Network } + deriving (Eq, Show, Generic, NFData) + +-- | Apply a parsed path to an extended key to derive the new key defined in the +-- path. If the path starts with /m/, a private key will be returned and if the +-- path starts with /M/, a public key will be returned. Private derivations on a +-- public key, and public derivations with a hard segment, return an error +-- value. +applyPath :: ParsedPath -> XKey -> Either String XKey +applyPath path key = + case (path, key) of + (ParsedPrv _, XPrv k n) -> return $ XPrv (derivPrvF k) n + (ParsedPrv _, XPub {}) -> Left "applyPath: Invalid public key" + (ParsedPub _, XPrv k n) -> return $ XPub (deriveXPubKey (derivPrvF k)) n + (ParsedPub _, XPub k n) -> derivPubFE >>= \f -> return $ XPub (f k) n + -- For empty parsed paths, we take a hint from the provided key + (ParsedEmpty _, XPrv k n) -> return $ XPrv (derivPrvF k) n + (ParsedEmpty _, XPub k n) -> derivPubFE >>= \f -> return $ XPub (f k) n + where + derivPrvF = goPrv id $ getParsedPath path + derivPubFE = goPubE id $ getParsedPath path + -- Build the full private derivation function starting from the end + goPrv f p = + case p of + next :| i -> goPrv (f . flip hardSubKey i) next + next :/ i -> goPrv (f . flip prvSubKey i) next + Deriv -> f + -- Build the full public derivation function starting from the end + goPubE f p = + case p of + next :/ i -> goPubE (f . flip pubSubKey i) next + Deriv -> Right f + _ -> Left "applyPath: Invalid hard derivation" + +{- Helpers for derivation paths and addresses -} + +-- | Derive an address from a given parent path. +derivePathAddr :: XPubKey -> SoftPath -> KeyIndex -> (Address, PubKey) +derivePathAddr key path = deriveAddr (derivePubPath path key) + +-- | Cyclic list of all addresses derived from a given parent path and starting +-- from the given offset index. +derivePathAddrs :: + XPubKey -> SoftPath -> KeyIndex -> [(Address, PubKey, KeyIndex)] +derivePathAddrs key path = deriveAddrs (derivePubPath path key) + +-- | Derive a multisig address from a given parent path. The number of required +-- signatures (m in m of n) is also needed. +derivePathMSAddr :: + [XPubKey] + -> SoftPath + -> Int + -> KeyIndex + -> (Address, RedeemScript) +derivePathMSAddr keys path = + deriveMSAddr $ map (derivePubPath path) keys + +-- | Cyclic list of all multisig addresses derived from a given parent path and +-- starting from the given offset index. The number of required signatures +-- (m in m of n) is also needed. +derivePathMSAddrs :: + [XPubKey] + -> SoftPath + -> Int + -> KeyIndex + -> [(Address, RedeemScript, KeyIndex)] +derivePathMSAddrs keys path = + deriveMSAddrs $ map (derivePubPath path) keys + +{- Utilities for extended keys -} + +-- | De-serialize HDW-specific private key. +getPadPrvKey :: Get SecKey +getPadPrvKey = do + pad <- getWord8 + unless (pad == 0x00) $ fail "Private key must be padded with 0x00" + secKeyGet + +-- | Serialize HDW-specific private key. +putPadPrvKey :: Putter SecKey +putPadPrvKey p = putWord8 0x00 >> secKeyPut p + +bsPadPrvKey :: SecKey -> ByteString +bsPadPrvKey = runPut . putPadPrvKey diff --git a/src/Haskoin/Keys/Mnemonic.hs b/src/Haskoin/Keys/Mnemonic.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Keys/Mnemonic.hs @@ -0,0 +1,516 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Haskoin.Keys.Mnemonic +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Mnemonic keys (BIP-39). Only English dictionary. +-} +module Haskoin.Keys.Mnemonic + ( -- * Mnemonic Sentences + Entropy + , Mnemonic + , Passphrase + , Seed + , toMnemonic + , fromMnemonic + , mnemonicToSeed + ) where + +import Control.Monad (when) +import Crypto.Hash (SHA256 (..), hashWith) +import Crypto.KDF.PBKDF2 (Parameters (..), fastPBKDF2_SHA512) +import Data.Bits (shiftL, shiftR) +import qualified Data.ByteArray as BA +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.List +import qualified Data.Map.Strict as M +import Data.Maybe +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import Data.Vector (Vector, (!)) +import qualified Data.Vector as V +import Haskoin.Util + +-- | Random data used to create a mnemonic sentence. Use a good entropy source. +-- You will get your coins stolen if you don't. You have been warned. +type Entropy = ByteString + +-- | Human-readable mnemonic sentence. +type Mnemonic = Text + +-- | Optional passphrase for mnemnoic sentence. +type Passphrase = ByteString + +-- | Seed for a private key from a mnemonic sentence. +type Seed = ByteString + +-- | Mnemonic key checksum. +type Checksum = ByteString + +-- | Paremeters for PBKDF2 function. +pbkdfParams :: Parameters +pbkdfParams = Parameters {iterCounts = 2048, outputLength = 64} + +-- | Provide intial 'Entropy' as a 'ByteString' of length multiple of 4 bytes. +-- Output a 'Mnemonic' sentence. +toMnemonic :: Entropy -> Either String Mnemonic +toMnemonic ent = do + when (BS.null ent) $ + Left "toMnemonic: entropy can not be empty" + when (remainder /= 0) $ + Left "toMnemonic: entropy must be multiples of 4 bytes" + when (cs_len > 16) $ + Left "toMnemonic: maximum entropy is 64 bytes (512 bits)" + return ms + where + (cs_len, remainder) = BS.length ent `quotRem` 4 + c = calcCS cs_len ent + indices = bsToIndices $ ent `BS.append` c + ms = T.unwords $ map (wl!) indices + +-- | Revert 'toMnemonic'. Do not use this to generate a 'Seed'. Instead use +-- 'mnemonicToSeed'. This outputs the original 'Entropy' used to generate a +-- 'Mnemonic' sentence. +fromMnemonic :: Mnemonic -> Either String Entropy +fromMnemonic ms = do + when (T.null ms) $ + Left "fromMnemonic: empty mnemonic" + when (word_count > 48) $ + Left $ "fromMnemonic: too many words: " ++ show word_count + when (word_count `mod` 3 /= 0) $ + Left $ "fromMnemonic: wrong number of words:" ++ show word_count + ms_bs <- indicesToBS =<< getIndices ms_words + let (ms_ent, ms_cs) = BS.splitAt (ent_len * 4) ms_bs + ms_cs_num = numCS cs_len ms_cs + ent_cs_num = numCS cs_len $ calcCS cs_len ms_ent + when (ent_cs_num /= ms_cs_num) $ + Left $ "fromMnemonic: checksum failed: " ++ sh ent_cs_num ms_cs_num + return ms_ent + where + ms_words = T.words ms + word_count = length ms_words + (ent_len, cs_len) = (word_count * 11) `quotRem` 32 + sh cs_a cs_b = show cs_a ++ " /= " ++ show cs_b + +-- | Compute 'Checksum'. +calcCS :: Int -> Entropy -> Checksum +calcCS len = getBits len . BA.convert . hashWith SHA256 + +numCS :: Int -> Entropy -> Integer +numCS len = + shiftCS . bsToInteger + where + shiftCS = case 8 - len `mod` 8 of + 8 -> id + x -> flip shiftR x + +-- | Turn an arbitrary sequence of characters into a 512-bit 'Seed'. Use +-- 'mnemonicToSeed' to get a seed from a 'Mnemonic' sentence. Warning: Does not +-- perform NFKD normalization. +anyToSeed :: Passphrase -> Mnemonic -> Seed +anyToSeed pf ms = + fastPBKDF2_SHA512 pbkdfParams (E.encodeUtf8 ms) ("mnemonic" `mappend` pf) + +-- | Get a 512-bit 'Seed' from a 'Mnemonic' sentence. Will validate checksum. +-- 'Passphrase' can be used to protect the 'Mnemonic'. Use an empty string as +-- 'Passphrase' if none is required. +mnemonicToSeed :: Passphrase -> Mnemonic -> Either String Seed +mnemonicToSeed pf ms = do + ent <- fromMnemonic ms + mnm <- toMnemonic ent + return $ anyToSeed pf mnm + +-- | Get indices of words in word list. +getIndices :: [Text] -> Either String [Int] +getIndices ws + | null n = return $ catMaybes i + | otherwise = Left $ "getIndices: words not found: " ++ cs w + where + i = map (`M.lookup` wl') ws + n = elemIndices Nothing i + w = T.unwords $ map (ws !!) n + +-- | Turn a list of 11-bit numbers into a 'ByteString' +indicesToBS :: [Int] -> Either String ByteString +indicesToBS is = do + when lrg $ Left "indicesToBS: index larger or equal than 2048" + return . pad . integerToBS $ foldl' f 0 is `shiftL` shift_width + where + lrg = isJust $ find (>= 2048) is + (q, r) = (length is * 11) `quotRem` 8 + shift_width = + if r == 0 + then 0 + else 8 - r + bl = + if r == 0 + then q + else q + 1 -- length of resulting ByteString + pad bs = BS.append (BS.replicate (bl - BS.length bs) 0x00) bs + f acc x = (acc `shiftL` 11) + fromIntegral x + +-- | Turn a 'ByteString' into a list of 11-bit numbers. +bsToIndices :: ByteString -> [Int] +bsToIndices bs = + reverse . go q $ bsToInteger bs `shiftR` r + where + (q, r) = (BS.length bs * 8) `quotRem` 11 + go 0 _ = [] + go n i = fromIntegral (i `mod` 2048) : go (n - 1) (i `shiftR` 11) + +wl' :: M.Map Text Int +wl' = V.ifoldr' (\i w m -> M.insert w i m) M.empty wl + +-- | Standard English dictionary from BIP-39 specification. +wl :: Vector Text +wl = V.fromListN 2048 + [ "abandon", "ability", "able", "about", "above", "absent" + , "absorb", "abstract", "absurd", "abuse", "access", "accident" + , "account", "accuse", "achieve", "acid", "acoustic", "acquire" + , "across", "act", "action", "actor", "actress", "actual" + , "adapt", "add", "addict", "address", "adjust", "admit" + , "adult", "advance", "advice", "aerobic", "affair", "afford" + , "afraid", "again", "age", "agent", "agree", "ahead" + , "aim", "air", "airport", "aisle", "alarm", "album" + , "alcohol", "alert", "alien", "all", "alley", "allow" + , "almost", "alone", "alpha", "already", "also", "alter" + , "always", "amateur", "amazing", "among", "amount", "amused" + , "analyst", "anchor", "ancient", "anger", "angle", "angry" + , "animal", "ankle", "announce", "annual", "another", "answer" + , "antenna", "antique", "anxiety", "any", "apart", "apology" + , "appear", "apple", "approve", "april", "arch", "arctic" + , "area", "arena", "argue", "arm", "armed", "armor" + , "army", "around", "arrange", "arrest", "arrive", "arrow" + , "art", "artefact", "artist", "artwork", "ask", "aspect" + , "assault", "asset", "assist", "assume", "asthma", "athlete" + , "atom", "attack", "attend", "attitude", "attract", "auction" + , "audit", "august", "aunt", "author", "auto", "autumn" + , "average", "avocado", "avoid", "awake", "aware", "away" + , "awesome", "awful", "awkward", "axis", "baby", "bachelor" + , "bacon", "badge", "bag", "balance", "balcony", "ball" + , "bamboo", "banana", "banner", "bar", "barely", "bargain" + , "barrel", "base", "basic", "basket", "battle", "beach" + , "bean", "beauty", "because", "become", "beef", "before" + , "begin", "behave", "behind", "believe", "below", "belt" + , "bench", "benefit", "best", "betray", "better", "between" + , "beyond", "bicycle", "bid", "bike", "bind", "biology" + , "bird", "birth", "bitter", "black", "blade", "blame" + , "blanket", "blast", "bleak", "bless", "blind", "blood" + , "blossom", "blouse", "blue", "blur", "blush", "board" + , "boat", "body", "boil", "bomb", "bone", "bonus" + , "book", "boost", "border", "boring", "borrow", "boss" + , "bottom", "bounce", "box", "boy", "bracket", "brain" + , "brand", "brass", "brave", "bread", "breeze", "brick" + , "bridge", "brief", "bright", "bring", "brisk", "broccoli" + , "broken", "bronze", "broom", "brother", "brown", "brush" + , "bubble", "buddy", "budget", "buffalo", "build", "bulb" + , "bulk", "bullet", "bundle", "bunker", "burden", "burger" + , "burst", "bus", "business", "busy", "butter", "buyer" + , "buzz", "cabbage", "cabin", "cable", "cactus", "cage" + , "cake", "call", "calm", "camera", "camp", "can" + , "canal", "cancel", "candy", "cannon", "canoe", "canvas" + , "canyon", "capable", "capital", "captain", "car", "carbon" + , "card", "cargo", "carpet", "carry", "cart", "case" + , "cash", "casino", "castle", "casual", "cat", "catalog" + , "catch", "category", "cattle", "caught", "cause", "caution" + , "cave", "ceiling", "celery", "cement", "census", "century" + , "cereal", "certain", "chair", "chalk", "champion", "change" + , "chaos", "chapter", "charge", "chase", "chat", "cheap" + , "check", "cheese", "chef", "cherry", "chest", "chicken" + , "chief", "child", "chimney", "choice", "choose", "chronic" + , "chuckle", "chunk", "churn", "cigar", "cinnamon", "circle" + , "citizen", "city", "civil", "claim", "clap", "clarify" + , "claw", "clay", "clean", "clerk", "clever", "click" + , "client", "cliff", "climb", "clinic", "clip", "clock" + , "clog", "close", "cloth", "cloud", "clown", "club" + , "clump", "cluster", "clutch", "coach", "coast", "coconut" + , "code", "coffee", "coil", "coin", "collect", "color" + , "column", "combine", "come", "comfort", "comic", "common" + , "company", "concert", "conduct", "confirm", "congress", "connect" + , "consider", "control", "convince", "cook", "cool", "copper" + , "copy", "coral", "core", "corn", "correct", "cost" + , "cotton", "couch", "country", "couple", "course", "cousin" + , "cover", "coyote", "crack", "cradle", "craft", "cram" + , "crane", "crash", "crater", "crawl", "crazy", "cream" + , "credit", "creek", "crew", "cricket", "crime", "crisp" + , "critic", "crop", "cross", "crouch", "crowd", "crucial" + , "cruel", "cruise", "crumble", "crunch", "crush", "cry" + , "crystal", "cube", "culture", "cup", "cupboard", "curious" + , "current", "curtain", "curve", "cushion", "custom", "cute" + , "cycle", "dad", "damage", "damp", "dance", "danger" + , "daring", "dash", "daughter", "dawn", "day", "deal" + , "debate", "debris", "decade", "december", "decide", "decline" + , "decorate", "decrease", "deer", "defense", "define", "defy" + , "degree", "delay", "deliver", "demand", "demise", "denial" + , "dentist", "deny", "depart", "depend", "deposit", "depth" + , "deputy", "derive", "describe", "desert", "design", "desk" + , "despair", "destroy", "detail", "detect", "develop", "device" + , "devote", "diagram", "dial", "diamond", "diary", "dice" + , "diesel", "diet", "differ", "digital", "dignity", "dilemma" + , "dinner", "dinosaur", "direct", "dirt", "disagree", "discover" + , "disease", "dish", "dismiss", "disorder", "display", "distance" + , "divert", "divide", "divorce", "dizzy", "doctor", "document" + , "dog", "doll", "dolphin", "domain", "donate", "donkey" + , "donor", "door", "dose", "double", "dove", "draft" + , "dragon", "drama", "drastic", "draw", "dream", "dress" + , "drift", "drill", "drink", "drip", "drive", "drop" + , "drum", "dry", "duck", "dumb", "dune", "during" + , "dust", "dutch", "duty", "dwarf", "dynamic", "eager" + , "eagle", "early", "earn", "earth", "easily", "east" + , "easy", "echo", "ecology", "economy", "edge", "edit" + , "educate", "effort", "egg", "eight", "either", "elbow" + , "elder", "electric", "elegant", "element", "elephant", "elevator" + , "elite", "else", "embark", "embody", "embrace", "emerge" + , "emotion", "employ", "empower", "empty", "enable", "enact" + , "end", "endless", "endorse", "enemy", "energy", "enforce" + , "engage", "engine", "enhance", "enjoy", "enlist", "enough" + , "enrich", "enroll", "ensure", "enter", "entire", "entry" + , "envelope", "episode", "equal", "equip", "era", "erase" + , "erode", "erosion", "error", "erupt", "escape", "essay" + , "essence", "estate", "eternal", "ethics", "evidence", "evil" + , "evoke", "evolve", "exact", "example", "excess", "exchange" + , "excite", "exclude", "excuse", "execute", "exercise", "exhaust" + , "exhibit", "exile", "exist", "exit", "exotic", "expand" + , "expect", "expire", "explain", "expose", "express", "extend" + , "extra", "eye", "eyebrow", "fabric", "face", "faculty" + , "fade", "faint", "faith", "fall", "false", "fame" + , "family", "famous", "fan", "fancy", "fantasy", "farm" + , "fashion", "fat", "fatal", "father", "fatigue", "fault" + , "favorite", "feature", "february", "federal", "fee", "feed" + , "feel", "female", "fence", "festival", "fetch", "fever" + , "few", "fiber", "fiction", "field", "figure", "file" + , "film", "filter", "final", "find", "fine", "finger" + , "finish", "fire", "firm", "first", "fiscal", "fish" + , "fit", "fitness", "fix", "flag", "flame", "flash" + , "flat", "flavor", "flee", "flight", "flip", "float" + , "flock", "floor", "flower", "fluid", "flush", "fly" + , "foam", "focus", "fog", "foil", "fold", "follow" + , "food", "foot", "force", "forest", "forget", "fork" + , "fortune", "forum", "forward", "fossil", "foster", "found" + , "fox", "fragile", "frame", "frequent", "fresh", "friend" + , "fringe", "frog", "front", "frost", "frown", "frozen" + , "fruit", "fuel", "fun", "funny", "furnace", "fury" + , "future", "gadget", "gain", "galaxy", "gallery", "game" + , "gap", "garage", "garbage", "garden", "garlic", "garment" + , "gas", "gasp", "gate", "gather", "gauge", "gaze" + , "general", "genius", "genre", "gentle", "genuine", "gesture" + , "ghost", "giant", "gift", "giggle", "ginger", "giraffe" + , "girl", "give", "glad", "glance", "glare", "glass" + , "glide", "glimpse", "globe", "gloom", "glory", "glove" + , "glow", "glue", "goat", "goddess", "gold", "good" + , "goose", "gorilla", "gospel", "gossip", "govern", "gown" + , "grab", "grace", "grain", "grant", "grape", "grass" + , "gravity", "great", "green", "grid", "grief", "grit" + , "grocery", "group", "grow", "grunt", "guard", "guess" + , "guide", "guilt", "guitar", "gun", "gym", "habit" + , "hair", "half", "hammer", "hamster", "hand", "happy" + , "harbor", "hard", "harsh", "harvest", "hat", "have" + , "hawk", "hazard", "head", "health", "heart", "heavy" + , "hedgehog", "height", "hello", "helmet", "help", "hen" + , "hero", "hidden", "high", "hill", "hint", "hip" + , "hire", "history", "hobby", "hockey", "hold", "hole" + , "holiday", "hollow", "home", "honey", "hood", "hope" + , "horn", "horror", "horse", "hospital", "host", "hotel" + , "hour", "hover", "hub", "huge", "human", "humble" + , "humor", "hundred", "hungry", "hunt", "hurdle", "hurry" + , "hurt", "husband", "hybrid", "ice", "icon", "idea" + , "identify", "idle", "ignore", "ill", "illegal", "illness" + , "image", "imitate", "immense", "immune", "impact", "impose" + , "improve", "impulse", "inch", "include", "income", "increase" + , "index", "indicate", "indoor", "industry", "infant", "inflict" + , "inform", "inhale", "inherit", "initial", "inject", "injury" + , "inmate", "inner", "innocent", "input", "inquiry", "insane" + , "insect", "inside", "inspire", "install", "intact", "interest" + , "into", "invest", "invite", "involve", "iron", "island" + , "isolate", "issue", "item", "ivory", "jacket", "jaguar" + , "jar", "jazz", "jealous", "jeans", "jelly", "jewel" + , "job", "join", "joke", "journey", "joy", "judge" + , "juice", "jump", "jungle", "junior", "junk", "just" + , "kangaroo", "keen", "keep", "ketchup", "key", "kick" + , "kid", "kidney", "kind", "kingdom", "kiss", "kit" + , "kitchen", "kite", "kitten", "kiwi", "knee", "knife" + , "knock", "know", "lab", "label", "labor", "ladder" + , "lady", "lake", "lamp", "language", "laptop", "large" + , "later", "latin", "laugh", "laundry", "lava", "law" + , "lawn", "lawsuit", "layer", "lazy", "leader", "leaf" + , "learn", "leave", "lecture", "left", "leg", "legal" + , "legend", "leisure", "lemon", "lend", "length", "lens" + , "leopard", "lesson", "letter", "level", "liar", "liberty" + , "library", "license", "life", "lift", "light", "like" + , "limb", "limit", "link", "lion", "liquid", "list" + , "little", "live", "lizard", "load", "loan", "lobster" + , "local", "lock", "logic", "lonely", "long", "loop" + , "lottery", "loud", "lounge", "love", "loyal", "lucky" + , "luggage", "lumber", "lunar", "lunch", "luxury", "lyrics" + , "machine", "mad", "magic", "magnet", "maid", "mail" + , "main", "major", "make", "mammal", "man", "manage" + , "mandate", "mango", "mansion", "manual", "maple", "marble" + , "march", "margin", "marine", "market", "marriage", "mask" + , "mass", "master", "match", "material", "math", "matrix" + , "matter", "maximum", "maze", "meadow", "mean", "measure" + , "meat", "mechanic", "medal", "media", "melody", "melt" + , "member", "memory", "mention", "menu", "mercy", "merge" + , "merit", "merry", "mesh", "message", "metal", "method" + , "middle", "midnight", "milk", "million", "mimic", "mind" + , "minimum", "minor", "minute", "miracle", "mirror", "misery" + , "miss", "mistake", "mix", "mixed", "mixture", "mobile" + , "model", "modify", "mom", "moment", "monitor", "monkey" + , "monster", "month", "moon", "moral", "more", "morning" + , "mosquito", "mother", "motion", "motor", "mountain", "mouse" + , "move", "movie", "much", "muffin", "mule", "multiply" + , "muscle", "museum", "mushroom", "music", "must", "mutual" + , "myself", "mystery", "myth", "naive", "name", "napkin" + , "narrow", "nasty", "nation", "nature", "near", "neck" + , "need", "negative", "neglect", "neither", "nephew", "nerve" + , "nest", "net", "network", "neutral", "never", "news" + , "next", "nice", "night", "noble", "noise", "nominee" + , "noodle", "normal", "north", "nose", "notable", "note" + , "nothing", "notice", "novel", "now", "nuclear", "number" + , "nurse", "nut", "oak", "obey", "object", "oblige" + , "obscure", "observe", "obtain", "obvious", "occur", "ocean" + , "october", "odor", "off", "offer", "office", "often" + , "oil", "okay", "old", "olive", "olympic", "omit" + , "once", "one", "onion", "online", "only", "open" + , "opera", "opinion", "oppose", "option", "orange", "orbit" + , "orchard", "order", "ordinary", "organ", "orient", "original" + , "orphan", "ostrich", "other", "outdoor", "outer", "output" + , "outside", "oval", "oven", "over", "own", "owner" + , "oxygen", "oyster", "ozone", "pact", "paddle", "page" + , "pair", "palace", "palm", "panda", "panel", "panic" + , "panther", "paper", "parade", "parent", "park", "parrot" + , "party", "pass", "patch", "path", "patient", "patrol" + , "pattern", "pause", "pave", "payment", "peace", "peanut" + , "pear", "peasant", "pelican", "pen", "penalty", "pencil" + , "people", "pepper", "perfect", "permit", "person", "pet" + , "phone", "photo", "phrase", "physical", "piano", "picnic" + , "picture", "piece", "pig", "pigeon", "pill", "pilot" + , "pink", "pioneer", "pipe", "pistol", "pitch", "pizza" + , "place", "planet", "plastic", "plate", "play", "please" + , "pledge", "pluck", "plug", "plunge", "poem", "poet" + , "point", "polar", "pole", "police", "pond", "pony" + , "pool", "popular", "portion", "position", "possible", "post" + , "potato", "pottery", "poverty", "powder", "power", "practice" + , "praise", "predict", "prefer", "prepare", "present", "pretty" + , "prevent", "price", "pride", "primary", "print", "priority" + , "prison", "private", "prize", "problem", "process", "produce" + , "profit", "program", "project", "promote", "proof", "property" + , "prosper", "protect", "proud", "provide", "public", "pudding" + , "pull", "pulp", "pulse", "pumpkin", "punch", "pupil" + , "puppy", "purchase", "purity", "purpose", "purse", "push" + , "put", "puzzle", "pyramid", "quality", "quantum", "quarter" + , "question", "quick", "quit", "quiz", "quote", "rabbit" + , "raccoon", "race", "rack", "radar", "radio", "rail" + , "rain", "raise", "rally", "ramp", "ranch", "random" + , "range", "rapid", "rare", "rate", "rather", "raven" + , "raw", "razor", "ready", "real", "reason", "rebel" + , "rebuild", "recall", "receive", "recipe", "record", "recycle" + , "reduce", "reflect", "reform", "refuse", "region", "regret" + , "regular", "reject", "relax", "release", "relief", "rely" + , "remain", "remember", "remind", "remove", "render", "renew" + , "rent", "reopen", "repair", "repeat", "replace", "report" + , "require", "rescue", "resemble", "resist", "resource", "response" + , "result", "retire", "retreat", "return", "reunion", "reveal" + , "review", "reward", "rhythm", "rib", "ribbon", "rice" + , "rich", "ride", "ridge", "rifle", "right", "rigid" + , "ring", "riot", "ripple", "risk", "ritual", "rival" + , "river", "road", "roast", "robot", "robust", "rocket" + , "romance", "roof", "rookie", "room", "rose", "rotate" + , "rough", "round", "route", "royal", "rubber", "rude" + , "rug", "rule", "run", "runway", "rural", "sad" + , "saddle", "sadness", "safe", "sail", "salad", "salmon" + , "salon", "salt", "salute", "same", "sample", "sand" + , "satisfy", "satoshi", "sauce", "sausage", "save", "say" + , "scale", "scan", "scare", "scatter", "scene", "scheme" + , "school", "science", "scissors", "scorpion", "scout", "scrap" + , "screen", "script", "scrub", "sea", "search", "season" + , "seat", "second", "secret", "section", "security", "seed" + , "seek", "segment", "select", "sell", "seminar", "senior" + , "sense", "sentence", "series", "service", "session", "settle" + , "setup", "seven", "shadow", "shaft", "shallow", "share" + , "shed", "shell", "sheriff", "shield", "shift", "shine" + , "ship", "shiver", "shock", "shoe", "shoot", "shop" + , "short", "shoulder", "shove", "shrimp", "shrug", "shuffle" + , "shy", "sibling", "sick", "side", "siege", "sight" + , "sign", "silent", "silk", "silly", "silver", "similar" + , "simple", "since", "sing", "siren", "sister", "situate" + , "six", "size", "skate", "sketch", "ski", "skill" + , "skin", "skirt", "skull", "slab", "slam", "sleep" + , "slender", "slice", "slide", "slight", "slim", "slogan" + , "slot", "slow", "slush", "small", "smart", "smile" + , "smoke", "smooth", "snack", "snake", "snap", "sniff" + , "snow", "soap", "soccer", "social", "sock", "soda" + , "soft", "solar", "soldier", "solid", "solution", "solve" + , "someone", "song", "soon", "sorry", "sort", "soul" + , "sound", "soup", "source", "south", "space", "spare" + , "spatial", "spawn", "speak", "special", "speed", "spell" + , "spend", "sphere", "spice", "spider", "spike", "spin" + , "spirit", "split", "spoil", "sponsor", "spoon", "sport" + , "spot", "spray", "spread", "spring", "spy", "square" + , "squeeze", "squirrel", "stable", "stadium", "staff", "stage" + , "stairs", "stamp", "stand", "start", "state", "stay" + , "steak", "steel", "stem", "step", "stereo", "stick" + , "still", "sting", "stock", "stomach", "stone", "stool" + , "story", "stove", "strategy", "street", "strike", "strong" + , "struggle", "student", "stuff", "stumble", "style", "subject" + , "submit", "subway", "success", "such", "sudden", "suffer" + , "sugar", "suggest", "suit", "summer", "sun", "sunny" + , "sunset", "super", "supply", "supreme", "sure", "surface" + , "surge", "surprise", "surround", "survey", "suspect", "sustain" + , "swallow", "swamp", "swap", "swarm", "swear", "sweet" + , "swift", "swim", "swing", "switch", "sword", "symbol" + , "symptom", "syrup", "system", "table", "tackle", "tag" + , "tail", "talent", "talk", "tank", "tape", "target" + , "task", "taste", "tattoo", "taxi", "teach", "team" + , "tell", "ten", "tenant", "tennis", "tent", "term" + , "test", "text", "thank", "that", "theme", "then" + , "theory", "there", "they", "thing", "this", "thought" + , "three", "thrive", "throw", "thumb", "thunder", "ticket" + , "tide", "tiger", "tilt", "timber", "time", "tiny" + , "tip", "tired", "tissue", "title", "toast", "tobacco" + , "today", "toddler", "toe", "together", "toilet", "token" + , "tomato", "tomorrow", "tone", "tongue", "tonight", "tool" + , "tooth", "top", "topic", "topple", "torch", "tornado" + , "tortoise", "toss", "total", "tourist", "toward", "tower" + , "town", "toy", "track", "trade", "traffic", "tragic" + , "train", "transfer", "trap", "trash", "travel", "tray" + , "treat", "tree", "trend", "trial", "tribe", "trick" + , "trigger", "trim", "trip", "trophy", "trouble", "truck" + , "true", "truly", "trumpet", "trust", "truth", "try" + , "tube", "tuition", "tumble", "tuna", "tunnel", "turkey" + , "turn", "turtle", "twelve", "twenty", "twice", "twin" + , "twist", "two", "type", "typical", "ugly", "umbrella" + , "unable", "unaware", "uncle", "uncover", "under", "undo" + , "unfair", "unfold", "unhappy", "uniform", "unique", "unit" + , "universe", "unknown", "unlock", "until", "unusual", "unveil" + , "update", "upgrade", "uphold", "upon", "upper", "upset" + , "urban", "urge", "usage", "use", "used", "useful" + , "useless", "usual", "utility", "vacant", "vacuum", "vague" + , "valid", "valley", "valve", "van", "vanish", "vapor" + , "various", "vast", "vault", "vehicle", "velvet", "vendor" + , "venture", "venue", "verb", "verify", "version", "very" + , "vessel", "veteran", "viable", "vibrant", "vicious", "victory" + , "video", "view", "village", "vintage", "violin", "virtual" + , "virus", "visa", "visit", "visual", "vital", "vivid" + , "vocal", "voice", "void", "volcano", "volume", "vote" + , "voyage", "wage", "wagon", "wait", "walk", "wall" + , "walnut", "want", "warfare", "warm", "warrior", "wash" + , "wasp", "waste", "water", "wave", "way", "wealth" + , "weapon", "wear", "weasel", "weather", "web", "wedding" + , "weekend", "weird", "welcome", "west", "wet", "whale" + , "what", "wheat", "wheel", "when", "where", "whip" + , "whisper", "wide", "width", "wife", "wild", "will" + , "win", "window", "wine", "wing", "wink", "winner" + , "winter", "wire", "wisdom", "wise", "wish", "witness" + , "wolf", "woman", "wonder", "wood", "wool", "word" + , "work", "world", "worry", "worth", "wrap", "wreck" + , "wrestle", "wrist", "write", "wrong", "yard", "year" + , "yellow", "you", "young", "youth", "zebra", "zero" + , "zone", "zoo" + ] diff --git a/src/Haskoin/Network.hs b/src/Haskoin/Network.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Network.hs @@ -0,0 +1,21 @@ +{-| +Module : Haskoin.Network +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +This module provides basic types used for the Bitcoin networking protocol +together with 'Data.Serialize' instances for efficiently serializing and +de-serializing them. +-} +module Haskoin.Network + ( module Common + , module Message + , module Bloom + ) where + +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 new file mode 100644 --- /dev/null +++ b/src/Haskoin/Network/Bloom.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-| +Module : Haskoin.Network.Bloom +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Bloom filters are used to reduce data transfer when synchronizing thin cients. +When bloom filters are used a client will obtain filtered blocks that only +contain transactions that pass the bloom filter. Transactions announced via inv +messages also pass the filter. +-} +module Haskoin.Network.Bloom + ( -- * Bloom Filters + BloomFlags(..) + , BloomFilter(..) + , FilterLoad(..) + , FilterAdd(..) + , bloomCreate + , bloomInsert + , bloomContains + , isBloomValid + , isBloomEmpty + , isBloomFull + , acceptsFilters + , bloomRelevantUpdate + ) where + +import Control.DeepSeq +import Control.Monad (forM_, replicateM) +import Data.Bits +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.Foldable as F +import Data.Hash.Murmur (murmur3) +import Data.List (foldl') +import qualified Data.Sequence as S +import Data.Serialize (Serialize, encode, get, put) +import Data.Serialize.Get (getByteString, getWord32le, + getWord8) +import Data.Serialize.Put (putByteString, putWord32le, + putWord8) +import Data.Word +import GHC.Generics (Generic) +import Haskoin.Network.Common +import Haskoin.Script.Common +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. +data BloomFlags + = BloomUpdateNone -- ^ never update + | BloomUpdateAll -- ^ auto-update on all outputs + | BloomUpdateP2PubKeyOnly + -- ^ auto-update on pay-to-pubkey or pay-to-multisig (default) + deriving (Eq, Show, Read, Generic, NFData) + +instance Serialize BloomFlags where + get = go =<< getWord8 + where + go 0 = return BloomUpdateNone + go 1 = return BloomUpdateAll + go 2 = return BloomUpdateP2PubKeyOnly + go _ = fail "BloomFlags get: Invalid bloom flag" + + put f = putWord8 $ case f of + BloomUpdateNone -> 0 + BloomUpdateAll -> 1 + BloomUpdateP2PubKeyOnly -> 2 + +-- | 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 + { 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 Serialize BloomFilter where + + get = BloomFilter <$> (S.fromList <$> (readDat =<< get)) + <*> getWord32le <*> getWord32le + <*> get + where + readDat (VarInt len) = replicateM (fromIntegral len) getWord8 + + put (BloomFilter dat hashFuncs tweak flags) = do + putVarInt $ S.length dat + forM_ (F.toList dat) putWord8 + putWord32le hashFuncs + putWord32le tweak + put flags + +-- | Set a new bloom filter on the peer connection. +newtype FilterLoad = FilterLoad { filterLoadBloomFilter :: BloomFilter } + deriving (Eq, Show, Read, Generic, NFData) + +instance Serialize FilterLoad where + get = FilterLoad <$> get + put (FilterLoad f) = put f + +-- | 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 Serialize FilterAdd where + get = do + (VarInt len) <- get + dat <- getByteString $ fromIntegral len + return $ FilterAdd dat + + put (FilterAdd bs) = do + putVarInt $ BS.length bs + putByteString bs + + +-- | Build a bloom filter that will provide the given false positive rate when +-- the given number of elements have been inserted. +bloomCreate :: Int -- ^ number of elements + -> Double -- ^ false positive rate + -> Word32 -- ^ random nonce (tweak) for the hash function + -> BloomFlags -- ^ bloom filter flags + -> BloomFilter -- ^ bloom filter +bloomCreate numElem fpRate = + BloomFilter (S.replicate bloomSize 0) numHashF + where + -- Bloom filter size in bytes + bloomSize = truncate $ min a b / 8 + -- Suggested size in bits + a = -1 / ln2Squared * fromIntegral numElem * log fpRate + -- Maximum size in bits + b = fromIntegral $ maxBloomSize * 8 + numHashF = truncate $ min c (fromIntegral maxHashFuncs) + -- 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. +bloomInsert :: BloomFilter -- ^ Original bloom filter + -> ByteString -- ^ New data to insert + -> BloomFilter -- ^ Bloom filter containing the new data +bloomInsert bfilter bs + | isBloomFull bfilter = bfilter + | otherwise = bfilter { bloomData = newData } + where + idxs = map (\i -> bloomHash bfilter i bs) [0..bloomHashFuncs bfilter - 1] + upd s i = S.adjust (.|. bitMask !! fromIntegral (7 .&. i)) + (fromIntegral $ i `shiftR` 3) 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. +bloomContains :: BloomFilter -- ^ Bloom filter + -> ByteString + -- ^ Data that will be checked against the given bloom filter + -> Bool + -- ^ Returns True if the data matches the filter +bloomContains bfilter bs + | isBloomFull bfilter = True + | isBloomEmpty bfilter = False + | otherwise = all isSet idxs + where + s = bloomData bfilter + 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 + +-- | 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 :: BloomFilter + -- ^ Bloom filter + -> Tx + -- ^ Tx that may (or may not) have relevant outputs + -> Maybe BloomFilter + -- ^ Returns an updated bloom filter adding relevant output +bloomRelevantUpdate bfilter tx + | isBloomFull bfilter || isBloomEmpty bfilter = Nothing + | bloomFlags bfilter == BloomUpdateNone = Nothing + | length matchOuts > 0 = Just $ foldl' (addRelevant) bfilter matchOuts + | otherwise = Nothing + where + -- TxHash if we end up inserting an outpoint + h = txHash tx + -- Decode the scriptOutpus and add vOuts in case we make them outpoints + decodedOutputScripts = traverse (decodeOutputBS . scriptOutput) $ txOut tx + err = error $ "Error Decoding output script" + idxOutputScripts = either (const err) (zip [0..]) decodedOutputScripts + -- Check if any txOuts were contained in the bloom filter + matchFilter = filter (\(_,op) -> bloomContains bfilter $ encodeScriptOut op) + matchOuts = matchFilter idxOutputScripts + + addRelevant :: BloomFilter -> (Word32,ScriptOutput) -> BloomFilter + addRelevant bfilter (id,scriptOut) = case (bloomFlags bfilter,scriptType) of + -- We filtered out BloomUpdateNone so we insert any PayPk or PayMulSig + (_, True) -> bloomInsert bfilter outpoint + (BloomUpdateAll, _ ) -> bloomInsert bfilter outpoint + _ -> error "Error Updating Bloom Filter with relevant outpoint" + where + outpoint = encode $ OutPoint{ outPointHash = h, outPointIndex = id} + scriptType = (\s -> isPayPK s ||isPayMulSig s) scriptOut + + -- Encodes a scriptOutput so it can be checked agains the Bloom Filter + encodeScriptOut :: ScriptOutput -> ByteString + encodeScriptOut (PayMulSig outputMuSig _) = encode outputMuSig + encodeScriptOut (PayWitnessScriptHash scriptHash) = encode scriptHash + encodeScriptOut (DataCarrier getOutputData) = encode getOutputData + encodeScriptOut outputHash = (encode . 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 :: BloomFilter -- ^ Bloom filter to test + -> Bool -- ^ True if the given filter is valid +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 new file mode 100644 --- /dev/null +++ b/src/Haskoin/Network/Common.hs @@ -0,0 +1,613 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Haskoin.Network.Common +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Common functions and data types related to peer-to-peer network. +-} +module Haskoin.Network.Common + ( -- * Network Data Types + Addr(..) + , NetworkAddressTime + , Alert(..) + , GetData(..) + , Inv(..) + , InvVector(..) + , InvType(..) + , HostAddress + , hostToSockAddr + , sockToHostAddress + , NetworkAddress(..) + , NotFound(..) + , Ping(..) + , Pong(..) + , Reject(..) + , RejectCode(..) + , VarInt(..) + , VarString(..) + , Version(..) + , MessageCommand(..) + -- ** Useful Functions + , reject + , nodeNone + , nodeNetwork + , nodeGetUTXO + , nodeBloom + , nodeWitness + , nodeXThin + , commandToString + , stringToCommand + , putVarInt + ) where + +import Control.DeepSeq +import Control.Monad (forM_, liftM2, replicateM, unless) +import Data.Bits (shiftL) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.ByteString.Char8 as C (replicate) +import Data.Serialize as S +import Data.String +import Data.String.Conversions (cs) +import Data.Word (Word32, Word64) +import GHC.Generics (Generic) +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. +newtype Addr = + Addr { -- List of addresses of other nodes on the network with timestamps. + addrList :: [NetworkAddressTime] + } + deriving (Eq, Show, Generic, NFData) + +instance Serialize Addr where + + get = Addr <$> (repList =<< S.get) + where + repList (VarInt c) = replicateM (fromIntegral c) action + action = liftM2 (,) getWord32le S.get + + put (Addr xs) = do + putVarInt $ length xs + forM_ xs $ \(a,b) -> putWord32le a >> put b + +-- | Data type describing signed messages that can be sent between bitcoin +-- nodes to display important notifications to end users about the health of +-- the network. +data Alert = + Alert { + -- | Alert payload. + alertPayload :: !VarString + -- | ECDSA signature of the payload + , alertSignature :: !VarString + } deriving (Eq, Show, Read, Generic, NFData) + +instance Serialize Alert where + get = Alert <$> S.get <*> S.get + put (Alert p s) = put p >> put s + +-- | The 'GetData' type is used to retrieve information on a specific object +-- ('Block' or 'Tx') identified by the objects hash. The payload of a 'GetData' +-- request is a list of 'InvVector' which represent all the hashes of objects +-- that a node wants. The response to a 'GetBlock' message will be either a +-- 'Block' or a 'Tx' message depending on the type of the object referenced by +-- the hash. Usually, 'GetData' messages are sent after a node receives an 'Inv' +-- message that contains unknown object hashes. +newtype GetData = + GetData { -- | list of object hashes + getDataList :: [InvVector] + } deriving (Eq, Show, Generic, NFData) + +instance Serialize GetData where + + get = GetData <$> (repList =<< S.get) + where + repList (VarInt c) = replicateM (fromIntegral c) S.get + + put (GetData xs) = do + putVarInt $ length xs + forM_ xs put + +-- | 'Inv' messages are used by nodes to advertise their knowledge of new +-- objects by publishing a list of hashes to a peer. 'Inv' messages can be sent +-- unsolicited or in response to a 'GetBlocks' message. +newtype Inv = + Inv { + -- | inventory + invList :: [InvVector] + } deriving (Eq, Show, Generic, NFData) + +instance Serialize Inv where + + get = Inv <$> (repList =<< S.get) + where + repList (VarInt c) = replicateM (fromIntegral c) S.get + + put (Inv xs) = do + putVarInt $ length xs + forM_ xs put + +-- | Data type identifying the type of an inventory vector. SegWit types are +-- only used in 'GetData' messages, not 'Inv'. +data InvType + = InvError -- ^ error + | InvTx -- ^ transaction + | InvBlock -- ^ block + | InvMerkleBlock -- ^ filtered block + | InvWitnessTx -- ^ segwit transaction + | InvWitnessBlock -- ^ segwit block + | InvWitnessMerkleBlock -- ^ segwit filtere block + deriving (Eq, Show, Read, Generic, NFData) + +instance Serialize InvType where + get = go =<< getWord32le + where + go x = + case x of + 0 -> return InvError + 1 -> return InvTx + 2 -> return InvBlock + 3 -> return InvMerkleBlock + _ + | x == 1 `shiftL` 30 + 1 -> return InvWitnessTx + | x == 1 `shiftL` 30 + 2 -> return InvWitnessBlock + | x == 1 `shiftL` 30 + 3 -> return InvWitnessMerkleBlock + | otherwise -> fail "bitcoinGet InvType: Invalid Type" + put x = + putWord32le $ + case x of + InvError -> 0 + InvTx -> 1 + InvBlock -> 2 + InvMerkleBlock -> 3 + InvWitnessTx -> 1 `shiftL` 30 + 1 + InvWitnessBlock -> 1 `shiftL` 30 + 2 + InvWitnessMerkleBlock -> 1 `shiftL` 30 + 3 + +-- | Invectory vectors represent hashes identifying objects such as a 'Block' or +-- a 'Tx'. They notify other peers about new data or data they have otherwise +-- requested. +data InvVector = + InvVector { + -- | type of object + invType :: !InvType + -- | 256-bit hash of object + , invHash :: !Hash256 + } deriving (Eq, Show, Generic, NFData) + +instance Serialize InvVector where + get = InvVector <$> S.get <*> S.get + put (InvVector t h) = put t >> put h + +newtype HostAddress = + HostAddress ByteString + deriving (Eq, Show, Ord, Generic, NFData) + +instance Serialize HostAddress where + put (HostAddress bs) = putByteString bs + get = HostAddress <$> getByteString 18 + +-- | Data type describing a bitcoin network address. Addresses are stored in +-- IPv6 format. IPv4 addresses are mapped to IPv6 using IPv4 mapped IPv6 +-- addresses: . +data NetworkAddress = + NetworkAddress { -- | bitmask of services available for this address + naServices :: !Word64 + -- | address and port information + , naAddress :: !HostAddress + } deriving (Eq, Show, Generic, NFData) + +hostToSockAddr :: HostAddress -> SockAddr +hostToSockAddr (HostAddress bs) = + case runGet getSockAddr bs of + Left e -> error e + Right x -> x + +sockToHostAddress :: SockAddr -> HostAddress +sockToHostAddress = HostAddress . runPut . putSockAddr + +putSockAddr :: SockAddr -> Put +putSockAddr (SockAddrInet6 p _ (a, b, c, d) _) = do + putWord32be a + putWord32be b + putWord32be c + putWord32be d + putWord16be (fromIntegral p) + +putSockAddr (SockAddrInet p a) = do + putWord32be 0x00000000 + putWord32be 0x00000000 + putWord32be 0x0000ffff + putWord32host a + putWord16be (fromIntegral p) + +putSockAddr _ = error "Invalid address type" + +getSockAddr :: Get SockAddr +getSockAddr = do + a <- getWord32be + b <- getWord32be + c <- getWord32be + if a == 0x00000000 && b == 0x00000000 && c == 0x0000ffff + then do + d <- getWord32host + p <- getWord16be + return $ SockAddrInet (fromIntegral p) d + else do + d <- getWord32be + p <- getWord16be + return $ SockAddrInet6 (fromIntegral p) 0 (a, b, c, d) 0 + +instance Serialize NetworkAddress where + get = NetworkAddress <$> getWord64le <*> S.get + put (NetworkAddress s a) = putWord64le s >> put a + +-- | A 'NotFound' message is returned as a response to a 'GetData' message +-- whe one of the requested objects could not be retrieved. This could happen, +-- for example, if a tranasaction was requested and was not available in the +-- memory pool of the receiving node. +newtype NotFound = + NotFound { -- | Inventory vectors related to this request + notFoundList :: [InvVector] + } deriving (Eq, Show, Generic, NFData) + +instance Serialize NotFound where + + get = NotFound <$> (repList =<< S.get) + where + repList (VarInt c) = replicateM (fromIntegral c) S.get + + put (NotFound xs) = do + putVarInt $ length xs + forM_ xs put + +-- | A 'Ping' message is sent to bitcoin peers to check if a connection is still +-- open. +newtype Ping = + Ping { -- | A random nonce used to identify the recipient of the ping + -- request once a Pong response is received. + pingNonce :: Word64 + } deriving (Eq, Show, Read, Generic, NFData) + +-- | A Pong message is sent as a response to a ping message. +newtype Pong = + Pong { + -- | nonce from corresponding 'Ping' + pongNonce :: Word64 + } deriving (Eq, Show, Read, Generic, NFData) + +instance Serialize Ping where + get = Ping <$> getWord64le + put (Ping n) = putWord64le n + +instance Serialize Pong where + get = Pong <$> getWord64le + put (Pong n) = putWord64le n + +-- | The 'Reject' message is sent when messages are rejected by a peer. +data Reject = + Reject { + -- | type of message rejected + rejectMessage :: !MessageCommand + -- | rejection code + , rejectCode :: !RejectCode + -- | text reason for rejection + , rejectReason :: !VarString + -- | extra data such as block or tx hash + , rejectData :: !ByteString + } deriving (Eq, Show, Read, Generic, NFData) + +-- | Rejection code associated to the 'Reject' message. +data RejectCode + = RejectMalformed + | RejectInvalid + | RejectObsolete + | RejectDuplicate + | RejectNonStandard + | RejectDust + | RejectInsufficientFee + | RejectCheckpoint + deriving (Eq, Show, Read, Generic, NFData) + +instance Serialize RejectCode where + + get = getWord8 >>= \code -> case code of + 0x01 -> return RejectMalformed + 0x10 -> return RejectInvalid + 0x11 -> return RejectObsolete + 0x12 -> return RejectDuplicate + 0x40 -> return RejectNonStandard + 0x41 -> return RejectDust + 0x42 -> return RejectInsufficientFee + 0x43 -> return RejectCheckpoint + _ -> fail $ unwords + [ "Reject get: Invalid code" + , show code + ] + + put code = putWord8 $ case code of + RejectMalformed -> 0x01 + RejectInvalid -> 0x10 + RejectObsolete -> 0x11 + RejectDuplicate -> 0x12 + RejectNonStandard -> 0x40 + RejectDust -> 0x41 + RejectInsufficientFee -> 0x42 + RejectCheckpoint -> 0x43 + +-- | Convenience function to build a 'Reject' message. +reject :: MessageCommand -> RejectCode -> ByteString -> Reject +reject cmd code reason = + Reject cmd code (VarString reason) B.empty + +instance Serialize Reject where + get = + S.get >>= \(VarString bs) -> + Reject (stringToCommand bs) <$> S.get <*> S.get <*> maybeData + where + maybeData = + isEmpty >>= \done -> + if done + then return B.empty + else getByteString 32 + put (Reject cmd code reason dat) = do + put $ VarString $ commandToString cmd + put code + put reason + unless (B.null dat) $ putByteString dat + +-- | 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 Serialize VarInt where + + get = VarInt <$> ( getWord8 >>= go ) + where + go 0xff = getWord64le + go 0xfe = fromIntegral <$> getWord32le + go 0xfd = fromIntegral <$> getWord16le + go x = fromIntegral <$> return x + + put (VarInt x) + | x < 0xfd = + putWord8 $ fromIntegral x + | x <= 0xffff = do + putWord8 0xfd + putWord16le $ fromIntegral x + | x <= 0xffffffff = do + putWord8 0xfe + putWord32le $ fromIntegral x + | otherwise = do + putWord8 0xff + putWord64le x + +putVarInt :: Integral a => a -> Put +putVarInt = put . VarInt . fromIntegral + +-- | Data type for serialization of variable-length strings. +newtype VarString = VarString { getVarString :: ByteString } + deriving (Eq, Show, Read, Generic, NFData) + +instance Serialize VarString where + + get = VarString <$> (readBS =<< S.get) + where + readBS (VarInt len) = getByteString (fromIntegral len) + + put (VarString bs) = do + putVarInt $ B.length bs + putByteString bs + +-- | When a bitcoin node creates an outgoing connection to another node, +-- the first message it will send is a 'Version' message. The other node +-- will similarly respond with it's own 'Version' message. +data Version = + Version { + -- | protocol version + version :: !Word32 + -- | features supported by this connection + , services :: !Word64 + -- | unix timestamp + , timestamp :: !Word64 + -- | network address of remote node + , addrRecv :: !NetworkAddress + -- | network address of sending node + , addrSend :: !NetworkAddress + -- | random nonce to detect connection to self + , verNonce :: !Word64 + -- | user agent string + , userAgent :: !VarString + -- | height of the last block in sending node + , startHeight :: !Word32 + -- | relay transactions flag (BIP-37) + , relay :: !Bool + } deriving (Eq, Show, Generic, NFData) + +instance Serialize Version where + + get = Version <$> getWord32le + <*> getWord64le + <*> getWord64le + <*> S.get + <*> S.get + <*> getWord64le + <*> S.get + <*> getWord32le + <*> (go =<< isEmpty) + where + go True = return True + go False = getBool + + put (Version v s t ar as n ua sh r) = do + putWord32le v + putWord64le s + putWord64le t + put ar + put as + putWord64le n + put ua + putWord32le sh + putBool r + +-- | 0x00 is 'False', anything else is 'True'. +getBool :: Get Bool +getBool = go =<< getWord8 + where + go 0 = return False + go _ = return True + +putBool :: Bool -> Put +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. +data MessageCommand + = MCVersion + | MCVerAck + | MCAddr + | MCInv + | MCGetData + | MCNotFound + | MCGetBlocks + | MCGetHeaders + | MCTx + | MCBlock + | MCMerkleBlock + | MCHeaders + | MCGetAddr + | MCFilterLoad + | MCFilterAdd + | MCFilterClear + | MCPing + | MCPong + | MCAlert + | MCMempool + | MCReject + | MCSendHeaders + | MCOther ByteString + deriving (Eq, Generic, NFData) + +instance Show MessageCommand where + showsPrec _ = shows . commandToString + +instance Read MessageCommand where + readPrec = do + String str <- lexP + return (stringToCommand (cs str)) + +instance Serialize MessageCommand where + get = go <$> getByteString 12 + where + go bs = + let str = unpackCommand bs + in stringToCommand str + put mc = putByteString $ packCommand $ commandToString mc + +instance IsString MessageCommand where + fromString str = stringToCommand (cs str) + +-- | Read a 'MessageCommand' from its string representation. +stringToCommand :: ByteString -> MessageCommand +stringToCommand str = case str of + "version" -> MCVersion + "verack" -> MCVerAck + "addr" -> MCAddr + "inv" -> MCInv + "getdata" -> MCGetData + "notfound" -> MCNotFound + "getblocks" -> MCGetBlocks + "getheaders" -> MCGetHeaders + "tx" -> MCTx + "block" -> MCBlock + "merkleblock" -> MCMerkleBlock + "headers" -> MCHeaders + "getaddr" -> MCGetAddr + "filterload" -> MCFilterLoad + "filteradd" -> MCFilterAdd + "filterclear" -> MCFilterClear + "ping" -> MCPing + "pong" -> MCPong + "alert" -> MCAlert + "mempool" -> MCMempool + "reject" -> MCReject + "sendheaders" -> MCSendHeaders + _ -> MCOther str + +-- | Convert a 'MessageCommand' to its string representation. +commandToString :: MessageCommand -> ByteString +commandToString mc = case mc of + MCVersion -> "version" + MCVerAck -> "verack" + MCAddr -> "addr" + MCInv -> "inv" + MCGetData -> "getdata" + MCNotFound -> "notfound" + MCGetBlocks -> "getblocks" + MCGetHeaders -> "getheaders" + MCTx -> "tx" + MCBlock -> "block" + MCMerkleBlock -> "merkleblock" + MCHeaders -> "headers" + MCGetAddr -> "getaddr" + MCFilterLoad -> "filterload" + MCFilterAdd -> "filteradd" + MCFilterClear -> "filterclear" + MCPing -> "ping" + MCPong -> "pong" + MCAlert -> "alert" + MCMempool -> "mempool" + MCReject -> "reject" + MCSendHeaders -> "sendheaders" + MCOther c -> c + +-- | 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 new file mode 100644 --- /dev/null +++ b/src/Haskoin/Network/Message.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-| +Module : Haskoin.Network.Message +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Peer-to-peer network message serialization. +-} +module Haskoin.Network.Message + ( -- * Network Message + Message(..) + , MessageHeader(..) + , msgType + , putMessage + , getMessage + ) where + +import Control.DeepSeq +import Control.Monad (unless) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Serialize (Serialize, encode, get, put) +import Data.Serialize.Get (Get, getByteString, getWord32be, + getWord32le, isolate, lookAhead) +import Data.Serialize.Put (Putter, putByteString, putWord32be, + putWord32le) +import Data.Word (Word32) +import GHC.Generics (Generic) +import Haskoin.Block.Common +import Haskoin.Block.Merkle +import Haskoin.Constants +import Haskoin.Crypto.Hash +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 MessageHeader = MessageHeader + { -- | magic bytes identify network + headMagic :: !Word32 + -- | message type + , headCmd :: !MessageCommand + -- | length of payload + , headPayloadSize :: !Word32 + -- | checksum of payload + , headChecksum :: !CheckSum32 + } deriving (Eq, Show, Generic, NFData) + +instance Serialize MessageHeader where + + get = MessageHeader <$> getWord32be + <*> get + <*> getWord32le + <*> get + + put (MessageHeader m c l chk) = do + putWord32be m + put c + putWord32le l + put chk + +-- | The 'Message' type is used to identify all the valid messages that can be +-- sent between bitcoin peers. Only values of type 'Message' will be accepted +-- by other bitcoin peers as bitcoin protocol messages need to be correctly +-- serialized with message headers. Serializing a 'Message' value will +-- include the 'MessageHeader' with the correct checksum value automatically. +-- No need to add the 'MessageHeader' separately. +data Message + = MVersion !Version + | MVerAck + | MAddr !Addr + | MInv !Inv + | MGetData !GetData + | MNotFound !NotFound + | MGetBlocks !GetBlocks + | MGetHeaders !GetHeaders + | MTx !Tx + | MBlock !Block + | MMerkleBlock !MerkleBlock + | MHeaders !Headers + | MGetAddr + | MFilterLoad !FilterLoad + | MFilterAdd !FilterAdd + | MFilterClear + | MPing !Ping + | MPong !Pong + | MAlert !Alert + | MMempool + | MReject !Reject + | MSendHeaders + | MOther !ByteString !ByteString + deriving (Eq, Show, Generic, NFData) + +-- | Get 'MessageCommand' assocated with a message. +msgType :: Message -> MessageCommand +msgType (MVersion _) = MCVersion +msgType MVerAck = MCVerAck +msgType (MAddr _) = MCAddr +msgType (MInv _) = MCInv +msgType (MGetData _) = MCGetData +msgType (MNotFound _) = MCNotFound +msgType (MGetBlocks _) = MCGetBlocks +msgType (MGetHeaders _) = MCGetHeaders +msgType (MTx _) = MCTx +msgType (MBlock _) = MCBlock +msgType (MMerkleBlock _) = MCMerkleBlock +msgType (MHeaders _) = MCHeaders + +msgType (MFilterLoad _) = MCFilterLoad +msgType (MFilterAdd _) = MCFilterAdd +msgType MFilterClear = MCFilterClear +msgType (MPing _) = MCPing +msgType (MPong _) = MCPong +msgType (MAlert _) = MCAlert +msgType MMempool = MCMempool +msgType (MReject _) = MCReject +msgType MSendHeaders = MCSendHeaders +msgType MGetAddr = MCGetAddr +msgType (MOther c _) = MCOther c + +-- | Deserializer for network messages. +getMessage :: Network -> Get Message +getMessage net = do + (MessageHeader mgc cmd len chk) <- get + bs <- lookAhead $ getByteString $ fromIntegral len + unless + (mgc == getNetworkMagic net) + (fail $ "get: Invalid network magic bytes: " ++ show mgc) + unless + (checkSum32 bs == chk) + (fail $ "get: Invalid message checksum: " ++ show chk) + if len > 0 + then isolate (fromIntegral len) $ + case cmd of + MCVersion -> MVersion <$> get + MCAddr -> MAddr <$> get + MCInv -> MInv <$> get + MCGetData -> MGetData <$> get + MCNotFound -> MNotFound <$> get + MCGetBlocks -> MGetBlocks <$> get + MCGetHeaders -> MGetHeaders <$> get + MCTx -> MTx <$> get + MCBlock -> MBlock <$> get + MCMerkleBlock -> MMerkleBlock <$> get + MCHeaders -> MHeaders <$> get + MCFilterLoad -> MFilterLoad <$> get + MCFilterAdd -> MFilterAdd <$> get + MCPing -> MPing <$> get + MCPong -> MPong <$> get + MCAlert -> MAlert <$> get + MCReject -> MReject <$> get + MCOther c -> MOther c <$> getByteString (fromIntegral len) + _ -> fail $ "get: command " ++ show cmd ++ + " should not carry a payload" + else case cmd of + MCGetAddr -> return MGetAddr + MCVerAck -> return MVerAck + MCFilterClear -> return MFilterClear + MCMempool -> return MMempool + MCSendHeaders -> return MSendHeaders + _ -> fail $ "get: command " ++ show cmd ++ + " is expected to carry a payload" + +-- | Serializer for network messages. +putMessage :: Network -> Putter Message +putMessage net msg = do + let (cmd, payload) = + case msg of + MVersion m -> (MCVersion, encode m) + MVerAck -> (MCVerAck, BS.empty) + MAddr m -> (MCAddr, encode m) + MInv m -> (MCInv, encode m) + MGetData m -> (MCGetData, encode m) + MNotFound m -> (MCNotFound, encode m) + MGetBlocks m -> (MCGetBlocks, encode m) + MGetHeaders m -> (MCGetHeaders, encode m) + MTx m -> (MCTx, encode m) + MBlock m -> (MCBlock, encode m) + MMerkleBlock m -> (MCMerkleBlock, encode m) + MHeaders m -> (MCHeaders, encode m) + MGetAddr -> (MCGetAddr, BS.empty) + MFilterLoad m -> (MCFilterLoad, encode m) + MFilterAdd m -> (MCFilterAdd, encode m) + MFilterClear -> (MCFilterClear, BS.empty) + MPing m -> (MCPing, encode m) + MPong m -> (MCPong, encode m) + MAlert m -> (MCAlert, encode m) + MMempool -> (MCMempool, BS.empty) + MReject m -> (MCReject, encode m) + MSendHeaders -> (MCSendHeaders, BS.empty) + MOther c p -> (MCOther c, p) + chk = checkSum32 payload + len = fromIntegral $ BS.length payload + header = MessageHeader (getNetworkMagic net) cmd len chk + put header + putByteString payload diff --git a/src/Haskoin/Script.hs b/src/Haskoin/Script.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Script.hs @@ -0,0 +1,19 @@ +{-| +Module : Haskoin.Script +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +This module provides functions for parsing and evaluating bitcoin +transaction scripts. Data types are provided for building and +deconstructing all of the standard input and output script types. +-} +module Haskoin.Script + ( module X + ) where + +import Haskoin.Script.Common as X +import Haskoin.Script.SigHash as X +import Haskoin.Script.Standard as X diff --git a/src/Haskoin/Script/Common.hs b/src/Haskoin/Script/Common.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Script/Common.hs @@ -0,0 +1,731 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Haskoin.Script.Common +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Common script-related functions and data types. +-} +module Haskoin.Script.Common + ( ScriptOp(..) + , Script(..) + , PushDataType(..) + , ScriptOutput(..) + , isPayPK + , isPayPKHash + , isPayMulSig + , isPayScriptHash + , isPayWitnessPKHash + , isPayWitnessScriptHash + , isDataCarrier + , encodeOutput + , encodeOutputBS + , decodeOutput + , decodeOutputBS + , toP2SH + , toP2WSH + , isPushOp + , opPushData + , intToScriptOp + , scriptOpToInt + ) where + +import Control.DeepSeq +import Control.Monad +import Data.Aeson as A +import Data.Aeson.Encoding (text) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Hashable +import Data.Serialize as S +import Data.Word (Word8) +import GHC.Generics (Generic) +import Haskoin.Crypto.Hash +import Haskoin.Keys.Common +import Haskoin.Util + +-- | Data type representing a transaction script. Scripts are defined as lists +-- of script operators 'ScriptOp'. Scripts are used to: +-- +-- * Define the spending conditions in the output of a transaction. +-- * Provide signatures in the input of a transaction (except SegWit). +-- +-- SigWit only: the segregated witness data structure, and not the input script, +-- contains signatures and redeem script for pay-to-witness-script and +-- pay-to-witness-public-key-hash transactions. +newtype Script = + Script { + -- | script operators defining this script + scriptOps :: [ScriptOp] + } + deriving (Eq, Show, Read, Generic, Hashable, NFData) + +instance Serialize Script where + get = + Script <$> getScriptOps + where + getScriptOps = do + empty <- isEmpty + if empty + then return [] + else (:) <$> get <*> getScriptOps + + put (Script ops) = forM_ ops put + +-- | Data type representing the type of an OP_PUSHDATA opcode. +data PushDataType + = + -- | next opcode bytes is data to be pushed + OPCODE + -- | next byte contains number of bytes of data to be pushed + | OPDATA1 + -- | next two bytes contains number of bytes to be pushed + | OPDATA2 + -- | next four bytes contains the number of bytes to be pushed + | OPDATA4 + deriving (Show, Read, Eq, Generic, Hashable, NFData) + +-- | Data type representing an operator allowed inside a 'Script'. +data ScriptOp + -- Pushing Data + = OP_PUSHDATA !ByteString + !PushDataType + | OP_0 + | OP_1NEGATE + | OP_RESERVED + | OP_1 + | OP_2 + | OP_3 + | OP_4 + | OP_5 + | OP_6 + | OP_7 + | OP_8 + | OP_9 + | OP_10 + | OP_11 + | OP_12 + | OP_13 + | OP_14 + | OP_15 + | OP_16 + -- Flow control + | OP_NOP + | OP_VER -- reserved + | OP_IF + | OP_NOTIF + | OP_VERIF -- resreved + | OP_VERNOTIF -- reserved + | OP_ELSE + | OP_ENDIF + | OP_VERIFY + | OP_RETURN + -- Stack operations + | OP_TOALTSTACK + | OP_FROMALTSTACK + | OP_IFDUP + | OP_DEPTH + | OP_DROP + | OP_DUP + | OP_NIP + | OP_OVER + | OP_PICK + | OP_ROLL + | OP_ROT + | OP_SWAP + | OP_TUCK + | OP_2DROP + | OP_2DUP + | OP_3DUP + | OP_2OVER + | OP_2ROT + | OP_2SWAP + -- Splice + | OP_CAT + | OP_SUBSTR + | OP_LEFT + | OP_RIGHT + | OP_SIZE + -- Bitwise logic + | OP_INVERT + | OP_AND + | OP_OR + | OP_XOR + | OP_EQUAL + | OP_EQUALVERIFY + | OP_RESERVED1 + | OP_RESERVED2 + -- Arithmetic + | OP_1ADD + | OP_1SUB + | OP_2MUL + | OP_2DIV + | OP_NEGATE + | OP_ABS + | OP_NOT + | OP_0NOTEQUAL + | OP_ADD + | OP_SUB + | OP_MUL + | OP_DIV + | OP_MOD + | OP_LSHIFT + | OP_RSHIFT + | OP_BOOLAND + | OP_BOOLOR + | OP_NUMEQUAL + | OP_NUMEQUALVERIFY + | OP_NUMNOTEQUAL + | OP_LESSTHAN + | OP_GREATERTHAN + | OP_LESSTHANOREQUAL + | OP_GREATERTHANOREQUAL + | OP_MIN + | OP_MAX + | OP_WITHIN + -- Crypto + | OP_RIPEMD160 + | OP_SHA1 + | OP_SHA256 + | OP_HASH160 + | OP_HASH256 + | OP_CODESEPARATOR + | OP_CHECKSIG + | OP_CHECKSIGVERIFY + | OP_CHECKMULTISIG + | OP_CHECKMULTISIGVERIFY + -- Expansion + | OP_NOP1 + | OP_NOP2 + | OP_NOP3 + | OP_NOP4 + | OP_NOP5 + | OP_NOP6 + | OP_NOP7 + | OP_NOP8 + | OP_NOP9 + | OP_NOP10 + -- Bitcoin Cash Nov 2018 hard fork + | OP_CHECKDATASIG + | OP_CHECKDATASIGVERIFY + -- Other + | OP_PUBKEYHASH + | OP_PUBKEY + | OP_INVALIDOPCODE !Word8 + deriving (Show, Read, Eq, Generic, Hashable, NFData) + +instance Serialize ScriptOp where + get = go =<< (fromIntegral <$> getWord8) + where + go op + | op == 0x00 = return OP_0 + | op <= 0x4b = do + payload <- getByteString (fromIntegral op) + return $ OP_PUSHDATA payload OPCODE + | op == 0x4c = do + len <- getWord8 + payload <- getByteString (fromIntegral len) + return $ OP_PUSHDATA payload OPDATA1 + | op == 0x4d = do + len <- getWord16le + payload <- getByteString (fromIntegral len) + return $ OP_PUSHDATA payload OPDATA2 + | op == 0x4e = do + len <- getWord32le + payload <- getByteString (fromIntegral len) + return $ OP_PUSHDATA payload OPDATA4 + + | op == 0x4f = return OP_1NEGATE + | op == 0x50 = return OP_RESERVED + | op == 0x51 = return OP_1 + | op == 0x52 = return OP_2 + | op == 0x53 = return OP_3 + | op == 0x54 = return OP_4 + | op == 0x55 = return OP_5 + | op == 0x56 = return OP_6 + | op == 0x57 = return OP_7 + | op == 0x58 = return OP_8 + | op == 0x59 = return OP_9 + | op == 0x5a = return OP_10 + | op == 0x5b = return OP_11 + | op == 0x5c = return OP_12 + | op == 0x5d = return OP_13 + | op == 0x5e = return OP_14 + | op == 0x5f = return OP_15 + | op == 0x60 = return OP_16 + + -- Flow control + | op == 0x61 = return OP_NOP + | op == 0x62 = return OP_VER -- reserved + | op == 0x63 = return OP_IF + | op == 0x64 = return OP_NOTIF + | op == 0x65 = return OP_VERIF -- reserved + | op == 0x66 = return OP_VERNOTIF -- reserved + | op == 0x67 = return OP_ELSE + | op == 0x68 = return OP_ENDIF + | op == 0x69 = return OP_VERIFY + | op == 0x6a = return OP_RETURN + + -- Stack + | op == 0x6b = return OP_TOALTSTACK + | op == 0x6c = return OP_FROMALTSTACK + | op == 0x6d = return OP_2DROP + | op == 0x6e = return OP_2DUP + | op == 0x6f = return OP_3DUP + | op == 0x70 = return OP_2OVER + | op == 0x71 = return OP_2ROT + | op == 0x72 = return OP_2SWAP + | op == 0x73 = return OP_IFDUP + | op == 0x74 = return OP_DEPTH + | op == 0x75 = return OP_DROP + | op == 0x76 = return OP_DUP + | op == 0x77 = return OP_NIP + | op == 0x78 = return OP_OVER + | op == 0x79 = return OP_PICK + | op == 0x7a = return OP_ROLL + | op == 0x7b = return OP_ROT + | op == 0x7c = return OP_SWAP + | op == 0x7d = return OP_TUCK + + -- Splice + | op == 0x7e = return OP_CAT + | op == 0x7f = return OP_SUBSTR + | op == 0x80 = return OP_LEFT + | op == 0x81 = return OP_RIGHT + | op == 0x82 = return OP_SIZE + + -- Bitwise logic + | op == 0x83 = return OP_INVERT + | op == 0x84 = return OP_AND + | op == 0x85 = return OP_OR + | op == 0x86 = return OP_XOR + | op == 0x87 = return OP_EQUAL + | op == 0x88 = return OP_EQUALVERIFY + | op == 0x89 = return OP_RESERVED1 + | op == 0x8a = return OP_RESERVED2 + + -- Arithmetic + | op == 0x8b = return OP_1ADD + | op == 0x8c = return OP_1SUB + | op == 0x8d = return OP_2MUL + | op == 0x8e = return OP_2DIV + | op == 0x8f = return OP_NEGATE + | op == 0x90 = return OP_ABS + | op == 0x91 = return OP_NOT + | op == 0x92 = return OP_0NOTEQUAL + | op == 0x93 = return OP_ADD + | op == 0x94 = return OP_SUB + | op == 0x95 = return OP_MUL + | op == 0x96 = return OP_DIV + | op == 0x97 = return OP_MOD + | op == 0x98 = return OP_LSHIFT + | op == 0x99 = return OP_RSHIFT + | op == 0x9a = return OP_BOOLAND + | op == 0x9b = return OP_BOOLOR + | op == 0x9c = return OP_NUMEQUAL + | op == 0x9d = return OP_NUMEQUALVERIFY + | op == 0x9e = return OP_NUMNOTEQUAL + | op == 0x9f = return OP_LESSTHAN + | op == 0xa0 = return OP_GREATERTHAN + | op == 0xa1 = return OP_LESSTHANOREQUAL + | op == 0xa2 = return OP_GREATERTHANOREQUAL + | op == 0xa3 = return OP_MIN + | op == 0xa4 = return OP_MAX + | op == 0xa5 = return OP_WITHIN + + -- Crypto + | op == 0xa6 = return OP_RIPEMD160 + | op == 0xa7 = return OP_SHA1 + | op == 0xa8 = return OP_SHA256 + | op == 0xa9 = return OP_HASH160 + | op == 0xaa = return OP_HASH256 + | op == 0xab = return OP_CODESEPARATOR + | op == 0xac = return OP_CHECKSIG + | op == 0xad = return OP_CHECKSIGVERIFY + | op == 0xae = return OP_CHECKMULTISIG + | op == 0xaf = return OP_CHECKMULTISIGVERIFY + + -- More NOPs + | op == 0xb0 = return OP_NOP1 + | op == 0xb1 = return OP_NOP2 + | op == 0xb2 = return OP_NOP3 + | op == 0xb3 = return OP_NOP4 + | op == 0xb4 = return OP_NOP5 + | op == 0xb5 = return OP_NOP6 + | op == 0xb6 = return OP_NOP7 + | op == 0xb7 = return OP_NOP8 + | op == 0xb8 = return OP_NOP9 + | op == 0xb9 = return OP_NOP10 + + -- Bitcoin Cash Nov 2018 hard fork + | op == 0xba = return OP_CHECKDATASIG + | op == 0xbb = return OP_CHECKDATASIGVERIFY + + -- Constants + | op == 0xfd = return OP_PUBKEYHASH + | op == 0xfe = return OP_PUBKEY + + | otherwise = return $ OP_INVALIDOPCODE op + + put op = case op of + + (OP_PUSHDATA payload optype)-> do + let len = B.length payload + case optype of + OPCODE -> do + unless (len <= 0x4b) $ + error "OP_PUSHDATA OPCODE: Payload size too big" + putWord8 $ fromIntegral len + OPDATA1 -> do + unless (len <= 0xff) $ + error "OP_PUSHDATA OPDATA1: Payload size too big" + putWord8 0x4c + putWord8 $ fromIntegral len + OPDATA2 -> do + unless (len <= 0xffff) $ + error "OP_PUSHDATA OPDATA2: Payload size too big" + putWord8 0x4d + putWord16le $ fromIntegral len + OPDATA4 -> do + unless (len <= 0x7fffffff) $ + error "OP_PUSHDATA OPDATA4: Payload size too big" + putWord8 0x4e + putWord32le $ fromIntegral len + putByteString payload + + -- Constants + OP_0 -> putWord8 0x00 + OP_1NEGATE -> putWord8 0x4f + OP_RESERVED -> putWord8 0x50 + OP_1 -> putWord8 0x51 + OP_2 -> putWord8 0x52 + OP_3 -> putWord8 0x53 + OP_4 -> putWord8 0x54 + OP_5 -> putWord8 0x55 + OP_6 -> putWord8 0x56 + OP_7 -> putWord8 0x57 + OP_8 -> putWord8 0x58 + OP_9 -> putWord8 0x59 + OP_10 -> putWord8 0x5a + OP_11 -> putWord8 0x5b + OP_12 -> putWord8 0x5c + OP_13 -> putWord8 0x5d + OP_14 -> putWord8 0x5e + OP_15 -> putWord8 0x5f + OP_16 -> putWord8 0x60 + + -- Crypto Constants + OP_PUBKEY -> putWord8 0xfe + OP_PUBKEYHASH -> putWord8 0xfd + + -- Invalid Opcodes + (OP_INVALIDOPCODE x) -> putWord8 x + + -- Flow Control + OP_NOP -> putWord8 0x61 + OP_VER -> putWord8 0x62 + OP_IF -> putWord8 0x63 + OP_NOTIF -> putWord8 0x64 + OP_VERIF -> putWord8 0x65 + OP_VERNOTIF -> putWord8 0x66 + OP_ELSE -> putWord8 0x67 + OP_ENDIF -> putWord8 0x68 + OP_VERIFY -> putWord8 0x69 + OP_RETURN -> putWord8 0x6a + + -- Stack Operations + OP_TOALTSTACK -> putWord8 0x6b + OP_FROMALTSTACK -> putWord8 0x6c + OP_2DROP -> putWord8 0x6d + OP_2DUP -> putWord8 0x6e + OP_3DUP -> putWord8 0x6f + OP_2OVER -> putWord8 0x70 + OP_2ROT -> putWord8 0x71 + OP_2SWAP -> putWord8 0x72 + OP_IFDUP -> putWord8 0x73 + OP_DEPTH -> putWord8 0x74 + OP_DROP -> putWord8 0x75 + OP_DUP -> putWord8 0x76 + OP_NIP -> putWord8 0x77 + OP_OVER -> putWord8 0x78 + OP_PICK -> putWord8 0x79 + OP_ROLL -> putWord8 0x7a + OP_ROT -> putWord8 0x7b + OP_SWAP -> putWord8 0x7c + OP_TUCK -> putWord8 0x7d + + -- Splice + OP_CAT -> putWord8 0x7e + OP_SUBSTR -> putWord8 0x7f + OP_LEFT -> putWord8 0x80 + OP_RIGHT -> putWord8 0x81 + OP_SIZE -> putWord8 0x82 + + -- Bitwise Logic + OP_INVERT -> putWord8 0x83 + OP_AND -> putWord8 0x84 + OP_OR -> putWord8 0x85 + OP_XOR -> putWord8 0x86 + OP_EQUAL -> putWord8 0x87 + OP_EQUALVERIFY -> putWord8 0x88 + OP_RESERVED1 -> putWord8 0x89 + OP_RESERVED2 -> putWord8 0x8a + + -- Arithmetic + OP_1ADD -> putWord8 0x8b + OP_1SUB -> putWord8 0x8c + OP_2MUL -> putWord8 0x8d + OP_2DIV -> putWord8 0x8e + OP_NEGATE -> putWord8 0x8f + OP_ABS -> putWord8 0x90 + OP_NOT -> putWord8 0x91 + OP_0NOTEQUAL -> putWord8 0x92 + OP_ADD -> putWord8 0x93 + OP_SUB -> putWord8 0x94 + OP_MUL -> putWord8 0x95 + OP_DIV -> putWord8 0x96 + OP_MOD -> putWord8 0x97 + OP_LSHIFT -> putWord8 0x98 + OP_RSHIFT -> putWord8 0x99 + OP_BOOLAND -> putWord8 0x9a + OP_BOOLOR -> putWord8 0x9b + OP_NUMEQUAL -> putWord8 0x9c + OP_NUMEQUALVERIFY -> putWord8 0x9d + OP_NUMNOTEQUAL -> putWord8 0x9e + OP_LESSTHAN -> putWord8 0x9f + OP_GREATERTHAN -> putWord8 0xa0 + OP_LESSTHANOREQUAL -> putWord8 0xa1 + OP_GREATERTHANOREQUAL-> putWord8 0xa2 + OP_MIN -> putWord8 0xa3 + OP_MAX -> putWord8 0xa4 + OP_WITHIN -> putWord8 0xa5 + + -- Crypto + OP_RIPEMD160 -> putWord8 0xa6 + OP_SHA1 -> putWord8 0xa7 + OP_SHA256 -> putWord8 0xa8 + OP_HASH160 -> putWord8 0xa9 + OP_HASH256 -> putWord8 0xaa + OP_CODESEPARATOR -> putWord8 0xab + OP_CHECKSIG -> putWord8 0xac + OP_CHECKSIGVERIFY -> putWord8 0xad + OP_CHECKMULTISIG -> putWord8 0xae + OP_CHECKMULTISIGVERIFY -> putWord8 0xaf + + -- More NOPs + OP_NOP1 -> putWord8 0xb0 + OP_NOP2 -> putWord8 0xb1 + OP_NOP3 -> putWord8 0xb2 + OP_NOP4 -> putWord8 0xb3 + OP_NOP5 -> putWord8 0xb4 + OP_NOP6 -> putWord8 0xb5 + OP_NOP7 -> putWord8 0xb6 + OP_NOP8 -> putWord8 0xb7 + OP_NOP9 -> putWord8 0xb8 + OP_NOP10 -> putWord8 0xb9 + + -- Bitcoin Cash Nov 2018 hard fork + OP_CHECKDATASIG -> putWord8 0xba + OP_CHECKDATASIGVERIFY -> putWord8 0xbb + + +-- | Check whether opcode is only data. +isPushOp :: ScriptOp -> Bool +isPushOp op = case op of + OP_PUSHDATA _ _ -> True + OP_0 -> True + OP_1NEGATE -> True + OP_1 -> True + OP_2 -> True + OP_3 -> True + OP_4 -> True + OP_5 -> True + OP_6 -> True + OP_7 -> True + OP_8 -> True + OP_9 -> True + OP_10 -> True + OP_11 -> True + OP_12 -> True + OP_13 -> True + OP_14 -> True + OP_15 -> True + OP_16 -> True + _ -> False + +-- | Optimally encode data using one of the 4 types of data pushing opcodes. +opPushData :: ByteString -> ScriptOp +opPushData bs + | len <= 0x4b = OP_PUSHDATA bs OPCODE + | len <= 0xff = OP_PUSHDATA bs OPDATA1 + | len <= 0xffff = OP_PUSHDATA bs OPDATA2 + | len <= 0xffffffff = OP_PUSHDATA bs OPDATA4 + | otherwise = error "opPushData: payload size too big" + where + len = B.length bs + +-- | Transforms integers @[1 .. 16]@ to 'ScriptOp' @[OP_1 .. OP_16]@. +intToScriptOp :: Int -> ScriptOp +intToScriptOp i + | i `elem` [1 .. 16] = op + | otherwise = err + where + op = either (const err) id . S.decode . B.singleton . fromIntegral $ i + 0x50 + err = error $ "intToScriptOp: Invalid integer " ++ show i + +-- | Decode 'ScriptOp' @[OP_1 .. OP_16]@ to integers @[1 .. 16]@. This functions +-- fails for other values of 'ScriptOp' +scriptOpToInt :: ScriptOp -> Either String Int +scriptOpToInt s + | res `elem` [1..16] = return res + | otherwise = Left $ "scriptOpToInt: invalid opcode " ++ show s + where + res = fromIntegral (B.head $ S.encode s) - 0x50 + +-- | Data type describing standard transaction output scripts. Output scripts +-- provide the conditions that must be fulfilled for someone to spend the funds +-- in a transaction output. +data ScriptOutput + -- | pay to public key + = PayPK { getOutputPubKey :: !PubKeyI } + -- | pay to public key hash + | PayPKHash { getOutputHash :: !Hash160 } + -- | multisig + | PayMulSig { getOutputMulSigKeys :: ![PubKeyI] + , getOutputMulSigRequired :: !Int } + -- | pay to a script hash + | PayScriptHash { getOutputHash :: !Hash160 } + -- | pay to witness public key hash + | PayWitnessPKHash { getOutputHash :: !Hash160 } + -- | pay to witness script hash + | PayWitnessScriptHash { getScriptHash :: !Hash256 } + -- | provably unspendable data carrier + | DataCarrier { getOutputData :: !ByteString } + deriving (Eq, Show, Read, Generic, Hashable, NFData) + +instance FromJSON ScriptOutput where + parseJSON = withText "scriptoutput" $ \t -> either fail return $ + maybeToEither "scriptoutput not hex" (decodeHex t) >>= + decodeOutputBS + +instance ToJSON ScriptOutput where + toJSON = String . encodeHex . encodeOutputBS + toEncoding = 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 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. +decodeOutput :: Script -> Either String ScriptOutput +decodeOutput s = case scriptOps s of + -- Pay to PubKey + [OP_PUSHDATA bs _, OP_CHECKSIG] -> PayPK <$> S.decode bs + -- Pay to PubKey Hash + [OP_DUP, OP_HASH160, OP_PUSHDATA bs _, OP_EQUALVERIFY, OP_CHECKSIG] -> + PayPKHash <$> S.decode bs + -- Pay to Script Hash + [OP_HASH160, OP_PUSHDATA bs _, OP_EQUAL] -> + PayScriptHash <$> S.decode bs + -- Pay to Witness + [OP_0, OP_PUSHDATA bs OPCODE] + | B.length bs == 20 -> PayWitnessPKHash <$> S.decode bs + | B.length bs == 32 -> PayWitnessScriptHash <$> S.decode bs + -- Provably unspendable data carrier output + [OP_RETURN, OP_PUSHDATA bs _] -> Right $ DataCarrier bs + -- Pay to MultiSig Keys + _ -> matchPayMulSig s + +-- | Similar to 'decodeOutput' but decodes from a 'ByteString'. +decodeOutputBS :: ByteString -> Either String ScriptOutput +decodeOutputBS = decodeOutput <=< S.decode + +-- | Computes a 'Script' from a standard 'ScriptOutput'. +encodeOutput :: ScriptOutput -> Script +encodeOutput s = Script $ case s of + -- Pay to PubKey + (PayPK k) -> [opPushData $ S.encode k, OP_CHECKSIG] + -- Pay to PubKey Hash Address + (PayPKHash h) -> + [ OP_DUP, OP_HASH160, opPushData $ S.encode h, OP_EQUALVERIFY, OP_CHECKSIG] + -- Pay to MultiSig Keys + (PayMulSig ps r) + | r <= length ps -> + let opM = intToScriptOp r + opN = intToScriptOp $ length ps + keys = map (opPushData . S.encode) ps + in opM : keys ++ [opN, OP_CHECKMULTISIG] + | otherwise -> error "encodeOutput: PayMulSig r must be <= than pkeys" + -- Pay to Script Hash Address + (PayScriptHash h) -> + [ OP_HASH160, opPushData $ S.encode h, OP_EQUAL] + -- Pay to Witness PubKey Hash Address + (PayWitnessPKHash h) -> + [ OP_0, opPushData $ S.encode h ] + (PayWitnessScriptHash h) -> + [ OP_0, opPushData $ S.encode h ] + -- Provably unspendable output + (DataCarrier d) -> [OP_RETURN, opPushData d] + +-- | Similar to 'encodeOutput' but encodes to a ByteString +encodeOutputBS :: ScriptOutput -> ByteString +encodeOutputBS = S.encode . encodeOutput + +-- | Encode script as pay-to-script-hash script +toP2SH :: Script -> ScriptOutput +toP2SH = PayScriptHash . addressHash . S.encode + +-- | Encode script as a pay-to-witness-script-hash script +toP2WSH :: Script -> ScriptOutput +toP2WSH = PayWitnessScriptHash . sha256 . S.encode + +-- | Match @[OP_N, PubKey1, ..., PubKeyM, OP_M, OP_CHECKMULTISIG]@ +matchPayMulSig :: Script -> Either String ScriptOutput +matchPayMulSig (Script ops) = case splitAt (length ops - 2) ops of + (m:xs,[n,OP_CHECKMULTISIG]) -> do + (intM,intN) <- liftM2 (,) (scriptOpToInt m) (scriptOpToInt n) + if intM <= intN && length xs == intN + then liftM2 PayMulSig (go xs) (return intM) + else Left "matchPayMulSig: Invalid M or N parameters" + _ -> Left "matchPayMulSig: script did not match output template" + where + go (OP_PUSHDATA bs _:xs) = liftM2 (:) (S.decode bs) (go xs) + go [] = return [] + go _ = Left "matchPayMulSig: invalid multisig opcode" diff --git a/src/Haskoin/Script/SigHash.hs b/src/Haskoin/Script/SigHash.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Script/SigHash.hs @@ -0,0 +1,319 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Haskoin.Script.SigHash +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Transaction signatures and related functions. +-} +module Haskoin.Script.SigHash +( SigHash +, SigHashFlag(..) +, sigHashAll +, sigHashNone +, sigHashSingle +, hasAnyoneCanPayFlag +, hasForkIdFlag +, setAnyoneCanPayFlag +, setForkIdFlag +, isSigHashAll +, isSigHashNone +, isSigHashSingle +, isSigHashUnknown +, sigHashAddForkId +, sigHashGetForkId +, sigHashAddNetworkId +, txSigHash +, txSigHashForkId +, TxSignature(..) +, encodeTxSig +, decodeTxSig +) where + +import Control.DeepSeq +import Control.Monad +import Crypto.Secp256k1 +import qualified Data.Aeson as J +import Data.Bits +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Hashable +import Data.Maybe +import Data.Scientific +import Data.Serialize +import Data.Word +import GHC.Generics (Generic) +import Haskoin.Constants +import Haskoin.Crypto.Hash +import Haskoin.Crypto.Signature +import Haskoin.Network +import Haskoin.Script.Common +import Haskoin.Transaction.Common +import Haskoin.Util + +-- | Constant representing a SIGHASH flag that controls what is being signed. +data SigHashFlag + = SIGHASH_ALL + -- ^ sign all outputs + | SIGHASH_NONE + -- ^ sign no outputs + | SIGHASH_SINGLE + -- ^ sign the output index corresponding to the input + | SIGHASH_FORKID + -- ^ replay protection for Bitcoin Cash transactions + | SIGHASH_ANYONECANPAY + -- ^ new inputs can be added + 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). +newtype SigHash = + SigHash Word32 + deriving ( Eq + , Ord + , Bits + , Enum + , Integral + , Num + , Real + , Show + , Read + , Generic + , Hashable + , 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 :: Network + -> Tx -- ^ transaction to sign + -> Script -- ^ script from output being spent + -> Word64 -- ^ value of output being spent + -> Int -- ^ index of input being signed + -> SigHash -- ^ what to sign + -> Hash256 -- ^ hash to be signed +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 $ + runPut $ do + put 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 + | hasAnyoneCanPayFlag sh = + [ (txins !! i) { scriptInput = encode out } ] + | isSigHashAll sh || isSigHashUnknown sh = single + | otherwise = zipWith noSeq single [0 ..] + where + emptyIn = map (\ti -> ti { scriptInput = BS.empty }) txins + single = + updateIndex i emptyIn $ \ti -> ti { scriptInput = encode out } + noSeq ti j = + if i == j + then ti + else ti { txInSequence = 0 } + +-- | Build transaction outputs for computing sighashes. +buildOutputs :: [TxOut] -> Int -> SigHash -> Maybe [TxOut] +buildOutputs txos i sh + | isSigHashAll sh || isSigHashUnknown sh = return txos + | isSigHashNone sh = return [] + | i >= length txos = Nothing + | otherwise = return $ buffer ++ [txos !! i] + 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 + :: Network + -> Tx -- ^ transaction to sign + -> Script -- ^ script from output being spent + -> Word64 -- ^ value of output being spent + -> Int -- ^ index of input being signed + -> SigHash -- ^ what to sign + -> Hash256 -- ^ hash to be signed +txSigHashForkId net tx out v i sh = + doubleSHA256 . runPut $ do + putWord32le $ txVersion tx + put hashPrevouts + put hashSequence + put $ prevOutput $ txIn tx !! i + putScript out + putWord64le v + putWord32le $ txInSequence $ txIn tx !! i + put hashOutputs + putWord32le $ txLockTime tx + putWord32le $ fromIntegral $ sigHashAddNetworkId net sh + where + hashPrevouts + | not $ hasAnyoneCanPayFlag sh = + doubleSHA256 $ runPut $ mapM_ (put . prevOutput) $ txIn tx + | otherwise = zeros + hashSequence + | not (hasAnyoneCanPayFlag sh) && + not (isSigHashSingle sh) && not (isSigHashNone sh) = + doubleSHA256 $ runPut $ mapM_ (putWord32le . txInSequence) $ txIn tx + | otherwise = zeros + hashOutputs + | not (isSigHashSingle sh) && not (isSigHashNone sh) = + doubleSHA256 $ runPut $ mapM_ put $ txOut tx + | isSigHashSingle sh && i < length (txOut tx) = + doubleSHA256 $ encode $ txOut tx !! i + | otherwise = zeros + putScript s = do + let encodedScript = encode s + putVarInt $ BS.length encodedScript + putByteString encodedScript + zeros :: Hash256 + zeros = "0000000000000000000000000000000000000000000000000000000000000000" + +-- | Data type representing a signature together with a 'SigHash'. The 'SigHash' +-- is serialized as one byte at the end of an ECDSA 'Sig'. All signatures in +-- transaction inputs are of type 'TxSignature'. +data TxSignature + = TxSignature { txSignature :: !Sig + , txSignatureSigHash :: !SigHash + } + | TxSignatureEmpty + deriving (Eq, Show, Generic) + +instance NFData TxSignature + +-- | Serialize a 'TxSignature'. +encodeTxSig :: TxSignature -> ByteString +encodeTxSig TxSignatureEmpty = error "Can not encode an empty signature" +encodeTxSig (TxSignature sig (SigHash n)) = + runPut $ putSig sig >> putWord8 (fromIntegral n) + +-- | Deserialize a 'TxSignature'. +decodeTxSig :: Network -> ByteString -> Either String TxSignature +decodeTxSig _ bs | BS.null bs = Left "Empty signature candidate" +decodeTxSig net bs = + case decodeStrictSig $ BS.init bs of + Just sig -> do + let sh = fromIntegral $ BS.last bs + when (isSigHashUnknown sh) $ + Left "Non-canonical signature: unknown hashtype byte" + when (isNothing (getSigHashForkId net) && hasForkIdFlag sh) $ + Left "Non-canonical signature: invalid network for forkId" + return $ TxSignature sig sh + Nothing -> Left "Non-canonical signature: could not parse signature" diff --git a/src/Haskoin/Script/Standard.hs b/src/Haskoin/Script/Standard.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Script/Standard.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Haskoin.Script.Standard +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Standard scripts like pay-to-public-key, pay-to-public-key-hash, +pay-to-script-hash, pay-to-multisig and corresponding SegWit variants. +-} +module Haskoin.Script.Standard + ( ScriptInput(..) + , SimpleInput(..) + , RedeemScript + , encodeInput + , encodeInputBS + , decodeInput + , decodeInputBS + , sortMulSig + , scriptOpToInt + , isSpendPK + , isSpendPKHash + , isSpendMulSig + , isScriptHashInput + ) where + +import Control.Applicative ((<|>)) +import Control.DeepSeq +import Control.Monad (guard, (<=<)) +import Data.ByteString (ByteString) +import Data.Function (on) +import Data.List (sortBy) +import Data.Serialize (decode, encode) +import GHC.Generics (Generic) +import Haskoin.Constants +import Haskoin.Keys.Common +import Haskoin.Script.Common +import Haskoin.Script.SigHash +import Haskoin.Util + + +-- | 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 + -- | spend pay-to-public-key output + = SpendPK { getInputSig :: !TxSignature + -- ^ transaction signature + } + -- | spend pay-to-public-key-hash output + | SpendPKHash { getInputSig :: !TxSignature + -- ^ embedded signature + , getInputKey :: !PubKeyI + -- ^ public key + } + -- | spend multisig output + | SpendMulSig { 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. +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. +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. +type RedeemScript = ScriptOutput + +-- | Standard input script high-level representation. +data ScriptInput + = RegularInput + { getRegularInput :: !SimpleInput + -- ^ get wrapped simple input + } + | ScriptHashInput + { 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) = + maybeToEither errMsg $ matchPK ops <|> matchPKHash ops <|> matchMulSig ops + where + matchPK [op] = SpendPK <$> f op + matchPK _ = Nothing + matchPKHash [op, OP_PUSHDATA pub _] = + SpendPKHash <$> f op <*> eitherToMaybe (decode pub) + matchPKHash _ = Nothing + matchMulSig (x:xs) = do + guard $ x == OP_0 + SpendMulSig <$> mapM f xs + matchMulSig _ = Nothing + f OP_0 = return TxSignatureEmpty + f (OP_PUSHDATA "" OPCODE) = f OP_0 + f (OP_PUSHDATA bs _) = eitherToMaybe $ decodeTxSig net bs + f _ = Nothing + errMsg = "decodeInput: Could not decode script input" + +-- | Heuristic to decode a 'ScriptInput' from a 'Script'. This function fails if +-- the script can not be parsed as a standard script input. +decodeInput :: Network -> Script -> Either String ScriptInput +decodeInput net s@(Script ops) = + maybeToEither errMsg $ matchSimpleInput <|> matchPayScriptHash + where + matchSimpleInput = + RegularInput <$> eitherToMaybe (decodeSimpleInput net s) + matchPayScriptHash = + case splitAt (length (scriptOps s) - 1) ops of + (is, [OP_PUSHDATA bs _]) -> do + rdm <- eitherToMaybe $ decodeOutputBS bs + inp <- eitherToMaybe $ decodeSimpleInput net $ Script is + return $ ScriptHashInput inp rdm + _ -> Nothing + errMsg = "decodeInput: Could not decode script input" + +-- | Like 'decodeInput' but decodes directly from a serialized script +-- 'ByteString'. +decodeInputBS :: Network -> ByteString -> Either String ScriptInput +decodeInputBS net = decodeInput net <=< decode + +-- | Encode a standard input into a script. +encodeInput :: ScriptInput -> Script +encodeInput s = case s of + RegularInput ri -> encodeSimpleInput ri + ScriptHashInput i o -> Script $ + scriptOps (encodeSimpleInput i) ++ [opPushData $ encodeOutputBS o] + +-- | Similar to 'encodeInput' but encodes directly to a serialized script +-- 'ByteString'. +encodeInputBS :: ScriptInput -> ByteString +encodeInputBS = encode . encodeInput + +-- | Encode a standard 'SimpleInput' into opcodes as an input 'Script'. +encodeSimpleInput :: SimpleInput -> Script +encodeSimpleInput s = + Script $ + case s of + SpendPK ts -> [f ts] + SpendPKHash ts p -> [f ts, opPushData $ encode p] + SpendMulSig xs -> OP_0 : map f xs + where + f TxSignatureEmpty = OP_0 + f ts = opPushData $ encodeTxSig ts + +-- | 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` encode) keys) r + _ -> error "Can only call orderMulSig on PayMulSig scripts" diff --git a/src/Haskoin/Transaction.hs b/src/Haskoin/Transaction.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Transaction.hs @@ -0,0 +1,24 @@ +{-| +Module : Haskoin.Transaction +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Transactions and related code. +-} +module Haskoin.Transaction + ( module Common + -- * Builder + , module Builder + -- * Segwit + , module Segwit + -- * Partial + , module Partial + ) where + +import Haskoin.Transaction.Builder as Builder +import Haskoin.Transaction.Common as Common +import Haskoin.Transaction.Partial as Partial +import Haskoin.Transaction.Segwit as Segwit diff --git a/src/Haskoin/Transaction/Builder.hs b/src/Haskoin/Transaction/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Transaction/Builder.hs @@ -0,0 +1,467 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Haskoin.Transaction.Builder +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Code to simplify transaction creation, signing, fee calculation and coin +selection. +-} +module Haskoin.Transaction.Builder + ( -- * Transaction Creation & Signing + buildAddrTx + , buildTx + , buildInput + , SigInput(..) + , signTx + , signNestedWitnessTx + , makeSignature + , signInput + , signNestedInput + , verifyStdTx + , mergeTxs + , sigKeys + , mergeTxInput + , findSigInput + , verifyStdInput + -- * Coin Selection + , Coin(..) + , chooseCoins + , chooseCoinsSink + , chooseMSCoins + , chooseMSCoinsSink + , countMulSig + , greedyAddSink + , guessTxFee + , guessMSTxFee + , guessTxSize + , guessMSSize + ) where + +import Control.Applicative ((<|>)) +import Control.Arrow (first) +import Control.Monad (foldM, unless) +import Control.Monad.Identity (runIdentity) +import Crypto.Secp256k1 +import qualified Data.ByteString as B +import Data.Conduit (ConduitT, Void, await, + runConduit, (.|)) +import Data.Conduit.List (sourceList) +import Data.Either (fromRight) +import Data.List (nub) +import Data.Maybe (catMaybes, fromJust, isJust) +import Data.Serialize (decode, encode) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Word (Word64) +import Haskoin.Address +import Haskoin.Constants +import Haskoin.Crypto.Hash (Hash256, addressHash) +import Haskoin.Crypto.Signature +import Haskoin.Keys.Common +import Haskoin.Network.Common +import Haskoin.Script +import Haskoin.Transaction.Builder.Sign (SigInput (..), buildInput, + makeSignature, sigKeys) +import qualified Haskoin.Transaction.Builder.Sign as S +import Haskoin.Transaction.Common +import Haskoin.Transaction.Segwit (decodeWitnessInput, isSegwit, + viewWitnessProgram) +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. +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. +chooseCoins :: Coin c + => Word64 -- ^ value to send + -> Word64 -- ^ fee per byte + -> Int -- ^ number of outputs (including change) + -> Bool -- ^ try to find better solutions + -> [c] -- ^ list of ordered coins to choose from + -> Either String ([c], Word64) + -- ^ coin selection and change +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. +chooseCoinsSink :: (Monad m, Coin c) + => Word64 -- ^ value to send + -> Word64 -- ^ fee per byte + -> Int -- ^ number of outputs (including change) + -> Bool -- ^ try to find better solution + -> ConduitT c Void m (Either String ([c], Word64)) + -- ^ coin selection and change +chooseCoinsSink target fee nOut continue + | target > 0 = + maybeToEither err <$> + greedyAddSink target (guessTxFee fee nOut) continue + | otherwise = return $ Left "chooseCoins: Target must be > 0" + where + err = "chooseCoins: No solution found" + +-- | Coin selection algorithm for multisig transactions. This function returns +-- the selected coins together with the amount of change to send back to +-- yourself, taking the fee into account. This function assumes all the coins +-- are script hash outputs that send funds to a multisignature address. +chooseMSCoins :: Coin c + => Word64 -- ^ value to send + -> Word64 -- ^ fee per byte + -> (Int, Int) -- ^ m of n multisig + -> Int -- ^ number of outputs (including change) + -> Bool -- ^ try to find better solution + -> [c] + -> Either String ([c], Word64) + -- ^ coin selection change amount +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. +chooseMSCoinsSink :: (Monad m, Coin c) + => Word64 -- ^ value to send + -> Word64 -- ^ fee per byte + -> (Int, Int) -- ^ m of n multisig + -> Int -- ^ number of outputs (including change) + -> Bool -- ^ try to find better solution + -> ConduitT c Void m (Either String ([c], Word64)) + -- ^ coin selection and change +chooseMSCoinsSink target fee ms nOut continue + | target > 0 = + maybeToEither err <$> + greedyAddSink target (guessMSTxFee fee ms nOut) continue + | otherwise = return $ Left "chooseMSCoins: Target must be > 0" + 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. +greedyAddSink :: (Monad m, Coin c) + => Word64 -- ^ value to send + -> (Int -> Word64) -- ^ coin count to fee function + -> Bool -- ^ try to find better solutions + -> ConduitT c Void m (Maybe ([c], Word64)) + -- ^ coin selection and change +greedyAddSink target guessFee continue = + go [] 0 [] 0 + where + -- The goal is the value we must reach (including the fee) for a certain + -- amount of selected coins. + goal c = target + guessFee c + go acc aTot ps pTot = await >>= \case + -- A coin is available in the stream + Just coin -> do + let val = coinValue coin + -- We have reached the goal using this coin + if val + aTot >= goal (length acc + 1) + -- If we want to continue searching for better solutions + then if continue + -- This solution is the first one or + -- This solution is better than the previous one + then if pTot == 0 || val + aTot < pTot + -- Continue searching for better solutions in the stream + then go [] 0 (coin:acc) (val + aTot) + -- Otherwise, we stop here and return the previous + -- solution + else return $ Just (ps, pTot - goal (length ps)) + -- Otherwise, return this solution + else return $ + Just (coin : acc, val + aTot - goal (length acc + 1)) + -- We have not yet reached the goal. Add the coin to the + -- accumulator + else go (coin:acc) (val + aTot) ps pTot + -- We reached the end of the stream + Nothing -> + return $ if null ps + -- If no solution was found, return Nothing + then Nothing + -- If we have a solution, return it + else 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. +guessTxSize :: Int -- ^ number of regular transaction inputs + -> [(Int,Int)] -- ^ multisig m of n for each input + -> Int -- ^ number of P2PKH outputs + -> Int -- ^ number of P2SH outputs + -> Int -- ^ upper bound on transaction size +guessTxSize pki msi pkout msout = + 8 + inpLen + inp + outLen + out + where + inpLen = B.length $ encode $ VarInt $ fromIntegral $ length msi + pki + outLen = B.length $ encode $ VarInt $ fromIntegral $ pkout + msout + inp = pki * 148 + sum (map guessMSSize msi) + -- (20: hash160) + (5: opcodes) + + -- (1: script len) + (8: Word64) + out = + pkout * 34 + + -- (20: hash160) + (3: opcodes) + + -- (1: script len) + (8: Word64) + msout * 32 + +-- | Size of a multisig P2SH input. +guessMSSize :: (Int,Int) -> Int +guessMSSize (m, n) + -- OutPoint (36) + Sequence (4) + Script + = 40 + fromIntegral (B.length $ encode $ VarInt $ fromIntegral scp) + scp + -- OP_M + n*PubKey + OP_N + OP_CHECKMULTISIG + where + rdm = + fromIntegral $ + B.length $ encode $ opPushData $ B.replicate (n * 34 + 3) 0 + -- Redeem + m*sig + OP_0 + scp = rdm + m * 73 + 1 + +{- Build a new Tx -} + +-- | Build a transaction by providing a list of outpoints as inputs +-- and a list of recipient addresses and amounts as outputs. +buildAddrTx :: Network -> [OutPoint] -> [(Text, Word64)] -> Either String Tx +buildAddrTx net xs ys = buildTx xs =<< mapM f ys + where + f (s, v) = + maybe (Left ("buildAddrTx: Invalid address " ++ cs s)) Right $ do + a <- stringToAddr net s + let o = addressToOutput a + return (o, v) + +-- | Build a transaction by providing a list of outpoints as inputs +-- and a list of 'ScriptOutput' and amounts as outputs. +buildTx :: [OutPoint] -> [(ScriptOutput, Word64)] -> Either String Tx +buildTx xs ys = + mapM fo ys >>= \os -> return $ Tx 1 (map fi xs) os [] 0 + where + fi outPoint = TxIn outPoint B.empty maxBound + fo (o, v) + | v <= 2100000000000000 = return $ TxOut v $ encodeOutputBS o + | otherwise = + Left $ "buildTx: Invalid amount " ++ show v + +-- | 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 + -> Tx -- ^ transaction to sign + -> [SigInput] -- ^ signing parameters + -> [SecKey] -- ^ private keys to sign with + -> Either String Tx -- ^ signed transaction +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'. +signNestedWitnessTx :: Network + -> Tx -- ^ transaction to sign + -> [SigInput] -- ^ signing parameters + -> [SecKey] -- ^ private keys to sign with + -> Either String Tx -- ^ signed transaction +signNestedWitnessTx net tx si = S.signTx net tx $ nested <$> si + where + -- NOTE: the nesting flag is ignored for non-segwit inputs + nested s = (s, True) + + +-- | Sign a single input in a transaction deterministically (RFC-6979). +signInput :: Network -> Tx -> Int -> SigInput -> SecKeyI -> Either String Tx +signInput net tx i si = S.signInput net tx i (si, False) + +-- | 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. +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. +mergeTxs :: Network -> [Tx] -> [(ScriptOutput, Word64, OutPoint)] -> Either String Tx +mergeTxs net txs os + | null txs = Left "Transaction list is empty" + | length (nub emptyTxs) /= 1 = Left "Transactions do not match" + | length txs == 1 = return $ head txs + | otherwise = foldM (mergeTxInput net txs) (head emptyTxs) outs + where + zipOp = zip (matchTemplate os (txIn $ head txs) f) [0..] + outs = map (first $ (\(o,v,_) -> (o,v)) . fromJust) $ filter (isJust . fst) zipOp + f (_, _, o) txin = o == prevOutput txin + emptyTxs = map (\tx -> foldl clearInput tx outs) txs + ins is i = updateIndex i is (\ti -> ti{ scriptInput = B.empty }) + 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. +mergeTxInput :: + Network + -> [Tx] + -> Tx + -> ((ScriptOutput, Word64), Int) + -> Either String Tx +mergeTxInput net txs tx ((so, val), i) + -- Ignore transactions with empty inputs + = do + let ins = map (scriptInput . (!! i) . txIn) txs + sigRes <- mapM extractSigs $ filter (not . B.null) ins + let rdm = snd $ head sigRes + unless (all (== rdm) $ map snd sigRes) $ Left "Redeem scripts do not match" + si <- encodeInputBS <$> go (nub $ concatMap fst sigRes) so rdm + let ins' = updateIndex i (txIn tx) (\ti -> ti {scriptInput = si}) + return $ Tx (txVersion tx) ins' (txOut tx) [] (txLockTime tx) + where + go allSigs out rdmM = + case out of + PayMulSig msPubs r -> + let sigs = + take r $ + catMaybes $ matchTemplate allSigs msPubs $ f out + in return $ RegularInput $ SpendMulSig sigs + PayScriptHash _ -> + case rdmM of + Just rdm -> do + si <- go allSigs rdm Nothing + return $ ScriptHashInput (getRegularInput si) rdm + _ -> Left "Invalid output script type" + _ -> Left "Invalid output script type" + extractSigs si = + case decodeInputBS net si of + Right (RegularInput (SpendMulSig sigs)) -> Right (sigs, Nothing) + Right (ScriptHashInput (SpendMulSig sigs) rdm) -> + Right (sigs, Just rdm) + _ -> Left "Invalid script input type" + f out (TxSignature x sh) p = + verifyHashSig + (txSigHash net tx (encodeOutput out) val i sh) + x + (pubKeyPoint p) + f _ TxSignatureEmpty _ = False + +{- Tx verification -} + +-- | Verify if a transaction is valid and all of its inputs are standard. +verifyStdTx :: Network -> Tx -> [(ScriptOutput, Word64, OutPoint)] -> Bool +verifyStdTx net tx xs = + not (null (txIn tx)) && all go (zip (matchTemplate xs (txIn tx) f) [0 ..]) + where + f (_, _, o) txin = o == prevOutput txin + 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 + | isSegwit so0 = fromRight False $ (inp == mempty &&) . verifySegwitInput so0 <$> wp so0 + | otherwise = fromRight False + $ verifyLegacyInput so0 <$> decodeInputBS net inp + <|> (nestedScriptOutput >>= \so -> verifyNestedInput so0 so <$> wp so) + where + verifyLegacyInput so si = case (so, si) of + (PayPK pub, RegularInput (SpendPK (TxSignature sig sh))) -> + verifyHashSig (theTxSigHash so sh Nothing) sig (pubKeyPoint pub) + (PayPKHash h, RegularInput (SpendPKHash (TxSignature sig sh) pub)) -> + pubKeyAddr pub == p2pkhAddr h && + verifyHashSig (theTxSigHash so sh Nothing) sig (pubKeyPoint pub) + (PayMulSig pubs r, RegularInput (SpendMulSig sigs)) -> + countMulSig net tx out val i (pubKeyPoint <$> pubs) sigs == r + (PayScriptHash h, ScriptHashInput si' rdm) -> + payToScriptAddress rdm == p2shAddr h && verifyLegacyInput rdm (RegularInput si') + _ -> False + where out = encodeOutput so + + verifySegwitInput so (rdm, si) = case (so, rdm, si) of + (PayWitnessPKHash h, Nothing, SpendPKHash (TxSignature sig sh) pub) -> + pubKeyWitnessAddr pub == p2wpkhAddr h && + verifyHashSig (theTxSigHash so sh Nothing) sig (pubKeyPoint pub) + (PayWitnessScriptHash h, Just rdm'@(PayPK pub), SpendPK (TxSignature sig sh)) -> + payToWitnessScriptAddress rdm' == p2wshAddr h && + verifyHashSig (theTxSigHash so sh $ Just rdm') sig (pubKeyPoint pub) + (PayWitnessScriptHash h, Just rdm'@(PayPKHash kh), SpendPKHash (TxSignature sig sh) pub) -> + payToWitnessScriptAddress rdm' == p2wshAddr h && + addressHash (encode pub) == kh && + verifyHashSig (theTxSigHash so sh $ Just rdm') sig (pubKeyPoint pub) + (PayWitnessScriptHash h, Just rdm'@(PayMulSig pubs r), SpendMulSig sigs) -> + payToWitnessScriptAddress rdm' == p2wshAddr h && + countMulSig' (\sh -> theTxSigHash so sh $ Just rdm') (pubKeyPoint <$> pubs) sigs == r + _ -> False + + verifyNestedInput so so' x = case so of + PayScriptHash h -> payToScriptAddress so' == p2shAddr h && verifySegwitInput so' x + _ -> False + + inp = scriptInput $ txIn tx !! i + theTxSigHash so = S.makeSigHash net tx i so val + + ws | length (txWitness tx) > i = txWitness tx !! i + | otherwise = [] + wp so = decodeWitnessInput net =<< viewWitnessProgram net so ws + + nestedScriptOutput = scriptOps <$> decode inp >>= \case + [OP_PUSHDATA bs _] -> decodeOutputBS bs + _ -> Left "nestedScriptOutput: not a nested output" + +-- | Count the number of valid signatures for a multi-signature transaction. +countMulSig :: + Network + -> Tx + -> Script + -> Word64 + -> Int + -> [PubKey] + -> [TxSignature] + -> Int +countMulSig net tx out val i = countMulSig' h + where + h = txSigHash net tx out val i + +countMulSig' :: (SigHash -> Hash256) -> [PubKey] -> [TxSignature] -> Int +countMulSig' _ [] _ = 0 +countMulSig' _ _ [] = 0 +countMulSig' h (_:pubs) (TxSignatureEmpty:sigs) = countMulSig' h pubs sigs +countMulSig' h (pub:pubs) sigs@(TxSignature sig sh : sigs') + | verifyHashSig (h sh) sig pub = 1 + countMulSig' h pubs sigs' + | otherwise = countMulSig' h pubs sigs diff --git a/src/Haskoin/Transaction/Builder/Sign.hs b/src/Haskoin/Transaction/Builder/Sign.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Transaction/Builder/Sign.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Haskoin.Transaction.Builder.Sign +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Types and logic for signing transactions. +-} +module Haskoin.Transaction.Builder.Sign + ( SigInput (..) + , makeSignature + , makeSigHash + , signTx + , findInputIndex + , signInput + , buildInput + , sigKeys + ) where + +import Control.DeepSeq (NFData) +import Control.Monad (foldM, mzero, when) +import Data.Aeson (FromJSON, ToJSON (..), + Value (Object), object, pairs, + parseJSON, (.:), (.:?), (.=)) +import Data.Either (rights) +import Data.Hashable (Hashable) +import Data.List (find, nub) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe, + maybeToList) +import qualified Data.Serialize as S +import Data.Word (Word64) +import GHC.Generics (Generic) + +import Haskoin.Address (getAddrHash160, pubKeyAddr) +import Haskoin.Constants (Network) +import Haskoin.Crypto (Hash256, SecKey) +import Haskoin.Crypto.Signature (signHash, verifyHashSig) +import Haskoin.Keys.Common (PubKeyI (..), SecKeyI (..), + derivePubKeyI, wrapSecKey) +import Haskoin.Script.Common (ScriptOutput (..), encodeOutput, + encodeOutputBS, opPushData) +import Haskoin.Script.SigHash (SigHash, TxSignature (..), + decodeTxSig, txSigHash, + txSigHashForkId) +import Haskoin.Script.Standard (RedeemScript, ScriptInput (..), + SimpleInput (..), decodeInputBS, + encodeInputBS) +import Haskoin.Transaction.Common (OutPoint, Tx (..), TxIn (..), + WitnessData) +import Haskoin.Transaction.Segwit (WitnessProgram (..), + calcWitnessProgram, isSegwit, + toWitnessStack) +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 SigInput = SigInput + { sigInputScript :: !ScriptOutput -- ^ output script to spend + , sigInputValue :: !Word64 -- ^ output script value + , sigInputOP :: !OutPoint -- ^ outpoint to spend + , sigInputSH :: !SigHash -- ^ signature type + , sigInputRedeem :: !(Maybe RedeemScript) -- ^ redeem script + } deriving (Eq, Show, Read, Generic, Hashable, NFData) + +instance ToJSON SigInput where + toJSON (SigInput so val op sh rdm) = object $ + [ "pkscript" .= so + , "value" .= val + , "outpoint" .= op + , "sighash" .= sh + ] ++ [ "redeem" .= r | r <- maybeToList rdm ] + toEncoding (SigInput so val op sh rdm) = pairs $ + "pkscript" .= so + <> "value" .= val + <> "outpoint" .= op + <> "sighash" .= sh + <> (case rdm of Nothing -> mempty + Just r -> "redeem" .= r) + +instance FromJSON SigInput where + parseJSON (Object o) = do + so <- o .: "pkscript" + val <- o .: "value" + op <- o .: "outpoint" + sh <- o .: "sighash" + rdm <- o .:? "redeem" + return $ SigInput so val op sh rdm + parseJSON _ = mzero + +-- | 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 + -> Tx -- ^ transaction to sign + -> [(SigInput, Bool)] -- ^ signing parameters, with nesting flag + -> [SecKey] -- ^ private keys to sign with + -> Either String Tx -- ^ signed transaction +signTx net otx sigis allKeys + | null ti = Left "signTx: Transaction has no inputs" + | otherwise = foldM go otx $ findInputIndex (sigInputOP . fst) sigis ti + where + ti = txIn otx + go tx (sigi@(SigInput so _ _ _ rdmM, _), i) = do + 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. +signInput :: + Network + -> Tx + -> Int + -> (SigInput, Bool) -- ^ boolean flag: nest input + -> SecKeyI + -> Either String Tx +signInput net tx i (sigIn@(SigInput so val _ _ rdmM), nest) key = do + let sig = makeSignature net tx i sigIn key + si <- buildInput net tx i so val rdmM sig $ derivePubKeyI key + w <- updatedWitnessData tx i so si + return tx { txIn = nextTxIn so si + , txWitness = w + } + where + f si x = x {scriptInput = encodeInputBS si} + g so' x = x {scriptInput = S.encode . opPushData $ encodeOutputBS so'} + txis = txIn tx + nextTxIn so' si + | isSegwit so' && nest = updateIndex i txis (g so') + | 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 +updatedWitnessData :: Tx -> Int -> ScriptOutput -> ScriptInput -> Either String WitnessData +updatedWitnessData tx i so si + | isSegwit so = updateWitness . toWitnessStack =<< calcWitnessProgram so si + | otherwise = return $ txWitness tx + where + updateWitness w + | null $ txWitness tx = return $ updateIndex i defaultStack (const w) + | length (txWitness tx) /= n = Left "Invalid number of witness stacks" + | otherwise = return $ updateIndex i (txWitness tx) (const w) + defaultStack = replicate n $ toWitnessStack EmptyWitnessProgram + n = length $ txIn tx + +-- | Associate an input index to each value in a list +findInputIndex :: + (a -> OutPoint) -- ^ extract an outpoint + -> [a] -- ^ input list + -> [TxIn] -- ^ reference list of inputs + -> [(a, Int)] +findInputIndex getOutPoint as ti = + mapMaybe g $ zip (matchTemplate as ti f) [0..] + where + f s txin = getOutPoint s == prevOutput txin + 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'. +sigKeys :: + ScriptOutput + -> Maybe RedeemScript + -> [SecKey] + -> Either String [SecKeyI] +sigKeys so rdmM keys = + case (so, rdmM) of + (PayPK p, Nothing) -> + return . map fst . maybeToList $ find ((== p) . snd) zipKeys + (PayPKHash h, Nothing) -> return $ keyByHash h + (PayMulSig ps r, Nothing) -> + return $ map fst $ take r $ filter ((`elem` ps) . snd) zipKeys + (PayScriptHash _, Just rdm) -> sigKeys rdm Nothing keys + (PayWitnessPKHash h, _) -> return $ keyByHash h + (PayWitnessScriptHash _, Just rdm) -> sigKeys rdm Nothing keys + _ -> Left "sigKeys: Could not decode output script" + where + zipKeys = + [ (prv, pub) + | k <- keys + , t <- [True, False] + , let prv = wrapSecKey t k + , let pub = derivePubKeyI prv + ] + 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. +buildInput :: + Network + -> Tx -- ^ transaction where input will be added + -> Int -- ^ input index where signature will go + -> ScriptOutput -- ^ output script being spent + -> Word64 -- ^ amount of previous output + -> Maybe RedeemScript -- ^ redeem script if pay-to-script-hash + -> TxSignature + -> PubKeyI + -> Either String ScriptInput +buildInput net tx i so val rdmM sig pub = do + when (i >= length (txIn tx)) $ Left "buildInput: Invalid input index" + case (so, rdmM) of + (PayScriptHash _, Just rdm) -> buildScriptHashInput rdm + (PayWitnessScriptHash _, Just rdm) -> buildScriptHashInput rdm + (PayWitnessPKHash _, Nothing) -> return . RegularInput $ SpendPKHash sig pub + (_, Nothing) -> buildRegularInput so + _ -> Left "buildInput: Invalid output/redeem script combination" + where + buildRegularInput = \case + PayPK _ -> return $ RegularInput $ SpendPK sig + PayPKHash _ -> return $ RegularInput $ SpendPKHash sig pub + PayMulSig msPubs r -> do + let mSigs = take r $ catMaybes $ matchTemplate allSigs msPubs f + allSigs = nub $ sig : parseExistingSigs net tx so i + return $ RegularInput $ SpendMulSig mSigs + _ -> Left "buildInput: Invalid output/redeem script combination" + buildScriptHashInput rdm = do + inp <- buildRegularInput rdm + return $ ScriptHashInput (getRegularInput inp) rdm + f (TxSignature x sh) p = + 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 +parseExistingSigs :: Network -> Tx -> ScriptOutput -> Int -> [TxSignature] +parseExistingSigs net tx so i = insSigs <> witSigs + where + insSigs = case decodeInputBS net scp of + Right (ScriptHashInput (SpendMulSig xs) _) -> xs + Right (RegularInput (SpendMulSig xs)) -> xs + _ -> [] + scp = scriptInput $ txIn tx !! i + witSigs + | not $ isSegwit so = [] + | 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 = + TxSignature (signHash (secKeyData key) m) sh + 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 +makeSigHash :: + Network + -> Tx + -> Int + -> ScriptOutput + -> Word64 + -> SigHash + -> Maybe RedeemScript + -> Hash256 +makeSigHash net tx i so val sh rdmM = h net tx (encodeOutput so') val i sh + where + so' = case so of + PayWitnessPKHash h' -> PayPKHash h' + _ -> fromMaybe so rdmM + h | isSegwit so = txSigHashForkId + | otherwise = txSigHash diff --git a/src/Haskoin/Transaction/Common.hs b/src/Haskoin/Transaction/Common.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Transaction/Common.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Haskoin.Transaction.Common +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Code related to transactions parsing and serialization. +-} +module Haskoin.Transaction.Common + ( Tx(..) + , TxIn(..) + , TxOut(..) + , OutPoint(..) + , TxHash(..) + , WitnessData + , WitnessStack + , WitnessStackItem + , txHash + , hexToTxHash + , txHashToHex + , nosigTxHash + , nullOutPoint + , genesisTx + ) where + +import Control.Applicative ((<|>)) +import Control.DeepSeq +import Control.Monad (forM_, guard, liftM2, mzero, + replicateM, (<=<)) +import Data.Aeson as A +import Data.Aeson.Encoding (unsafeToEncoding) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.ByteString.Builder (char7) +import Data.Hashable (Hashable) +import Data.Maybe (fromMaybe) +import Data.Serialize as S +import Data.String (IsString, fromString) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Word (Word32, Word64) +import GHC.Generics (Generic) +import Haskoin.Crypto.Hash +import Haskoin.Network.Common +import Haskoin.Script.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, Serialize, NFData) + +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 (TxHash h) = + unsafeToEncoding $ + char7 '"' <> hexBuilder (B.reverse (S.encode h)) <> char7 '"' + +-- | Transaction hash excluding signatures. +nosigTxHash :: Tx -> TxHash +nosigTxHash tx = + TxHash $ doubleSHA256 $ S.encode tx { txIn = map clearInput $ txIn 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 (S.encode h)) + +-- | Convert transaction hash from hex, reversing bytes. +hexToTxHash :: Text -> Maybe TxHash +hexToTxHash hex = do + bs <- B.reverse <$> decodeHex hex + h <- either (const Nothing) Just (S.decode 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 + } deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + +-- | Compute transaction hash. +txHash :: Tx -> TxHash +txHash tx = TxHash (doubleSHA256 (S.encode tx {txWitness = []})) + +instance IsString Tx where + fromString = + fromMaybe e . (eitherToMaybe . S.decode <=< decodeHex) . cs + where + e = error "Could not read transaction from hex string" + +instance Serialize Tx where + get = parseWitnessTx <|> parseLegacyTx + put tx + | null (txWitness tx) = putLegacyTx tx + | otherwise = putWitnessTx tx + +putInOut :: Tx -> Put +putInOut tx = do + putVarInt $ length (txIn tx) + forM_ (txIn tx) put + putVarInt $ length (txOut tx) + forM_ (txOut tx) put + +-- | Non-SegWit transaction serializer. +putLegacyTx :: Tx -> Put +putLegacyTx tx = do + putWord32le (txVersion tx) + putInOut tx + putWord32le (txLockTime tx) + +-- | Witness transaciton serializer. +putWitnessTx :: Tx -> Put +putWitnessTx tx = do + putWord32le (txVersion tx) + putWord8 0x00 + putWord8 0x01 + putInOut tx + putWitnessData (txWitness tx) + putWord32le (txLockTime tx) + +-- | Non-SegWit transaction deseralizer. +parseLegacyTx :: Get Tx +parseLegacyTx = do + v <- getWord32le + is <- replicateList =<< S.get + os <- replicateList =<< S.get + l <- getWord32le + return + Tx + {txVersion = v, txIn = is, txOut = os, txWitness = [], txLockTime = l} + where + replicateList (VarInt c) = replicateM (fromIntegral c) S.get + +-- | Witness transaction deserializer. +parseWitnessTx :: Get Tx +parseWitnessTx = do + v <- getWord32le + m <- getWord8 + f <- getWord8 + guard $ m == 0x00 + guard $ f == 0x01 + is <- replicateList =<< S.get + os <- replicateList =<< S.get + w <- parseWitnessData $ length is + l <- getWord32le + return + Tx {txVersion = v, txIn = is, txOut = os, txWitness = w, txLockTime = l} + where + replicateList (VarInt c) = replicateM (fromIntegral c) S.get + +-- | Witness data deserializer. Requires count of inputs. +parseWitnessData :: Int -> Get WitnessData +parseWitnessData n = replicateM n parseWitnessStack + where + parseWitnessStack = do + VarInt i <- S.get + replicateM (fromIntegral i) parseWitnessStackItem + parseWitnessStackItem = do + VarInt i <- S.get + getByteString $ fromIntegral i + +-- | Witness data serializer. +putWitnessData :: WitnessData -> Put +putWitnessData = mapM_ putWitnessStack + where + putWitnessStack ws = do + putVarInt $ length ws + mapM_ putWitnessStackItem ws + putWitnessStackItem bs = do + putVarInt $ B.length bs + putByteString bs + +instance FromJSON Tx where + parseJSON = withText "Tx" $ + maybe mzero return . (eitherToMaybe . S.decode <=< decodeHex) + +instance ToJSON Tx where + toJSON = A.String . encodeHex . S.encode + toEncoding tx = + unsafeToEncoding $ char7 '"' <> hexBuilder (S.encode tx) <> char7 '"' + +-- | Data type representing a transaction input. +data TxIn = + TxIn { + -- | output being spent + prevOutput :: !OutPoint + -- | signatures and redeem script + , scriptInput :: !ByteString + -- | lock-time using sequence numbers (BIP-68) + , txInSequence :: !Word32 + } deriving (Eq, Show, Read, Ord, Generic, Hashable, NFData) + +instance Serialize TxIn where + get = + TxIn <$> S.get <*> (readBS =<< S.get) <*> getWord32le + where + readBS (VarInt len) = getByteString $ fromIntegral len + + put (TxIn o s q) = do + put o + putVarInt $ B.length s + putByteString s + putWord32le q + +-- | Data type representing a transaction output. +data TxOut = + TxOut { + -- | value of output is satoshi + outValue :: !Word64 + -- | pubkey script + , scriptOutput :: !ByteString + } deriving (Eq, Show, Read, Ord, Generic, Hashable, NFData) + +instance Serialize TxOut where + get = do + val <- getWord64le + (VarInt len) <- S.get + TxOut val <$> getByteString (fromIntegral len) + + put (TxOut o s) = do + putWord64le o + putVarInt $ B.length s + putByteString s + +-- | The 'OutPoint' refers to a transaction output being spent. +data OutPoint = OutPoint + { -- | hash of previous transaction + outPointHash :: !TxHash + -- | position of output in previous transaction + , outPointIndex :: !Word32 + } deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + +instance FromJSON OutPoint where + parseJSON = withText "OutPoint" $ + maybe mzero return . (eitherToMaybe . S.decode <=< decodeHex) + +instance ToJSON OutPoint where + toJSON = A.String . encodeHex . S.encode + toEncoding op = + unsafeToEncoding $ char7 '"' <> hexBuilder (S.encode op) <> char7 '"' + +instance Serialize OutPoint where + get = do + (h,i) <- liftM2 (,) S.get getWord32le + return $ OutPoint h i + put (OutPoint h i) = put h >> putWord32le i + +-- | Outpoint used in coinbase transactions. +nullOutPoint :: OutPoint +nullOutPoint = + OutPoint + { outPointHash = + "0000000000000000000000000000000000000000000000000000000000000000" + , outPointIndex = maxBound + } + +-- | Transaction from Genesis block. +genesisTx :: Tx +genesisTx = + Tx 1 [txin] [txout] [] locktime + where + txin = TxIn outpoint inputBS maxBound + txout = TxOut 5000000000 (encodeOutputBS output) + locktime = 0 + outpoint = OutPoint z maxBound + Just inputBS = decodeHex $ fromString $ + "04ffff001d0104455468652054696d65732030332f4a616e2f323030392043686" ++ + "16e63656c6c6f72206f6e206272696e6b206f66207365636f6e64206261696c6f" ++ + "757420666f722062616e6b73" + output = PayPK $ fromString $ + "04678afdb0fe5548271967f1a67130b7105cd6a828e03909a67962e0ea1f61deb" ++ + "649f6bc3f4cef38c4f35504e51ec112de5c384df7ba0b8d578a4c702b6bf11d5f" + z = "0000000000000000000000000000000000000000000000000000000000000000" diff --git a/src/Haskoin/Transaction/Partial.hs b/src/Haskoin/Transaction/Partial.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Transaction/Partial.hs @@ -0,0 +1,500 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-| +Module : Haskoin.Transaction.Partial +Copyright : No rights reserved +License : UNLICENSE +Maintainer : matt@bitnomial.com +Stability : experimental +Portability : POSIX + +Code related to PSBT parsing and serialization. +-} +module Haskoin.Transaction.Partial + ( PartiallySignedTransaction (..) + , Input (..) + , Output (..) + , UnknownMap (..) + , Key (..) + , merge + , mergeInput + , mergeOutput + , complete + , finalTransaction + , emptyPSBT + , emptyInput + , emptyOutput + ) where + +import Control.Applicative ((<|>)) +import Control.DeepSeq +import Control.Monad (guard, replicateM, void) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Hashable (Hashable) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.List (foldl') +import Data.Maybe (fromMaybe, isJust) +import Data.Serialize as S +import GHC.Generics (Generic) +import GHC.Word (Word32, Word8) +import Haskoin.Address (Address (..), pubKeyAddr) +import Haskoin.Keys (Fingerprint, KeyIndex, PubKeyI) +import Haskoin.Network (VarInt (..), VarString (..), + putVarInt) +import Haskoin.Script (Script (..), ScriptOp (..), + ScriptOutput (..), SigHash, + decodeOutput, decodeOutputBS, + encodeOutputBS, isPayScriptHash, + opPushData, toP2SH, toP2WSH) +import Haskoin.Transaction.Common (Tx (..), TxOut, WitnessStack, + outPointIndex, prevOutput, + scriptInput, scriptOutput) +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. +data PartiallySignedTransaction = PartiallySignedTransaction + { unsignedTransaction :: Tx + , globalUnknown :: UnknownMap + , inputs :: [Input] + , outputs :: [Output] + } 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. +data Input = Input + { nonWitnessUtxo :: Maybe Tx + , witnessUtxo :: Maybe TxOut + , partialSigs :: HashMap PubKeyI ByteString + , sigHashType :: Maybe SigHash + , inputRedeemScript :: Maybe Script + , inputWitnessScript :: Maybe Script + , inputHDKeypaths :: HashMap PubKeyI (Fingerprint, [KeyIndex]) + , finalScriptSig :: Maybe Script + , finalScriptWitness :: Maybe WitnessStack + , inputUnknown :: UnknownMap + } deriving (Show, Eq, Generic) + +instance NFData Input + +-- | Outputs can contain information needed to spend the output at a later date. +data Output = Output + { outputRedeemScript :: Maybe Script + , outputWitnessScript :: Maybe Script + , outputHDKeypaths :: HashMap PubKeyI (Fingerprint, [KeyIndex]) + , outputUnknown :: UnknownMap + } deriving (Show, Eq, Generic) + +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. +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 + , key :: ByteString + } 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. +merge :: PartiallySignedTransaction -> PartiallySignedTransaction -> Maybe PartiallySignedTransaction +merge psbt1 psbt2 + | unsignedTransaction psbt1 == unsignedTransaction psbt2 + = Just $ psbt1 + { globalUnknown = globalUnknown psbt1 <> globalUnknown psbt2 + , inputs = zipWith mergeInput (inputs psbt1) (inputs psbt2) + , outputs = zipWith mergeOutput (outputs psbt1) (outputs psbt2) + } +merge _ _ = Nothing + +mergeInput :: Input -> Input -> Input +mergeInput a b = Input + { nonWitnessUtxo = if isJust witUtx then Nothing else nonWitnessUtxo a <|> nonWitnessUtxo b + , witnessUtxo = witUtx + , sigHashType = sigHashType a <|> sigHashType b + , partialSigs = partialSigs a <> partialSigs b + , inputHDKeypaths = inputHDKeypaths a <> inputHDKeypaths b + , inputUnknown = inputUnknown a <> inputUnknown b + , inputRedeemScript = inputRedeemScript a <|> inputRedeemScript b + , inputWitnessScript = inputWitnessScript a <|> inputWitnessScript b + , finalScriptSig = finalScriptSig a <|> finalScriptSig b + , finalScriptWitness = finalScriptWitness a <|> finalScriptWitness b + } + where + witUtx = witnessUtxo a <|> witnessUtxo b + +mergeOutput :: Output -> Output -> Output +mergeOutput a b = Output + { outputRedeemScript = outputRedeemScript a <|> outputRedeemScript b + , outputWitnessScript = outputWitnessScript a <|> outputWitnessScript b + , outputHDKeypaths = outputHDKeypaths a <> outputHDKeypaths b + , outputUnknown = outputUnknown a <> outputUnknown b + } + +-- | Take partial signatures from all of the 'Input's and finalize the signature. +complete :: PartiallySignedTransaction -> PartiallySignedTransaction +complete psbt = psbt { inputs = map (completeInput . analyzeInputs) (indexed $ inputs psbt) } + where + analyzeInputs (i, input) = (outputScript =<< witnessUtxo input <|> nonWitScript, input) + where + nonWitScript = getPrevOut i =<< nonWitnessUtxo input + + getPrevOut i tx = + (txOut tx !!?) . fromIntegral . outPointIndex . prevOutput =<< txIn (unsignedTransaction psbt) !!? i + xs !!? i = lookup i $ indexed xs + + outputScript = eitherToMaybe . decodeOutputBS . scriptOutput + + completeInput (Nothing, input) = input + completeInput (Just script, input) = completeSig input script + + indexed :: [a] -> [(Word32, a)] + indexed = zip [0..] + +completeSig :: Input -> ScriptOutput -> Input +completeSig input (PayPK k) = + input { finalScriptSig = eitherToMaybe . S.decode =<< HashMap.lookup k (partialSigs input) } +completeSig input (PayPKHash h) + | [(k, sig)] <- HashMap.toList $ partialSigs input + , PubKeyAddress h == pubKeyAddr k + = input { finalScriptSig = Just $ Script [opPushData sig, opPushData (S.encode k)] } +completeSig input (PayMulSig pubKeys m) | length sigs >= m = input { finalScriptSig = finalSig } + where + sigs = collectSigs m pubKeys input + finalSig = Script . (OP_0 :) . (map opPushData sigs <>) . pure . opPushData . S.encode <$> inputRedeemScript input +completeSig input (PayScriptHash h) + | Just rdmScript <- inputRedeemScript input + , PayScriptHash h == toP2SH rdmScript + , Right decodedScript <- decodeOutput rdmScript + , not (isPayScriptHash decodedScript) + = completeSig input decodedScript +completeSig input (PayWitnessPKHash h) + | [(k, sig)] <- HashMap.toList $ partialSigs input + , PubKeyAddress h == pubKeyAddr k + = input { finalScriptWitness = Just [sig, S.encode k] + , finalScriptSig = Script . pure . opPushData . S.encode <$> inputRedeemScript input + } +completeSig input (PayWitnessScriptHash h) + | Just witScript <- inputWitnessScript input + , PayWitnessScriptHash h == toP2WSH witScript + , Right decodedScript <- decodeOutput witScript + = completeWitnessSig input decodedScript +completeSig input _ = input + +completeWitnessSig :: Input -> ScriptOutput -> Input +completeWitnessSig input script@(PayMulSig pubKeys m) | length sigs >= m = input + { finalScriptWitness = Just finalWit + , finalScriptSig = finalSig + } + where + sigs = collectSigs m pubKeys input + finalSig = Script . pure . opPushData . S.encode <$> inputRedeemScript input + finalWit = mempty : sigs <> [encodeOutputBS script] +completeWitnessSig input _ = input + +collectSigs :: Int -> [PubKeyI] -> Input -> [ByteString] +collectSigs m pubKeys input = take m . reverse $ foldl' lookupKey [] pubKeys + where + lookupKey sigs key = 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. +finalTransaction :: PartiallySignedTransaction -> Tx +finalTransaction psbt = setInputs . foldl' finalizeInput ([], []) $ zip (txIn tx) (inputs psbt) + where + tx = unsignedTransaction psbt + hasWitness = any (isJust . finalScriptWitness) (inputs psbt) + setInputs (ins, witData) = tx { txIn = reverse ins, txWitness = if hasWitness then reverse witData else [] } + finalizeInput (ins, witData) (txInput, psbtInput) = maybe finalWitness finalScript $ finalScriptSig psbtInput + where + finalScript script = (txInput { scriptInput = encode script }:ins, []:witData) + finalWitness = (ins, fromMaybe [] (finalScriptWitness psbtInput):witData) + +-- | Take an unsigned transaction and produce an empty 'PartiallySignedTransaction' +emptyPSBT :: Tx -> PartiallySignedTransaction +emptyPSBT tx = PartiallySignedTransaction + { unsignedTransaction = tx + , globalUnknown = mempty + , inputs = replicate (length (txIn tx)) emptyInput + , outputs = replicate (length (txOut tx)) emptyOutput + } + +emptyInput :: Input +emptyInput = Input + Nothing Nothing HashMap.empty Nothing + Nothing Nothing HashMap.empty + Nothing Nothing (UnknownMap HashMap.empty) + +emptyOutput :: Output +emptyOutput = Output Nothing Nothing HashMap.empty (UnknownMap HashMap.empty) + +instance Serialize PartiallySignedTransaction where + get = do + magic <- getBytes 4 + guard $ magic == "psbt" + headerSep <- getWord8 + guard $ headerSep == 0xff + + keySize <- getWord8 + guard $ keySize == 1 + globalUnsignedTxType <- getWord8 + guard $ globalUnsignedTxType == 0x00 + unsignedTransaction <- getSizedBytes + guard $ all (B.null . scriptInput) (txIn unsignedTransaction) + guard $ null (txWitness unsignedTransaction) + + globalUnknown <- get + globalEnd <- getWord8 + guard $ globalEnd == 0x00 + + inputs <- replicateM (length $ txIn unsignedTransaction) get + outputs <- replicateM (length $ txOut unsignedTransaction) get + + return PartiallySignedTransaction { unsignedTransaction, globalUnknown, inputs, outputs } + + put PartiallySignedTransaction{ unsignedTransaction, globalUnknown, inputs, outputs } = do + putByteString "psbt" + putWord8 0xff -- Header separator + + putWord8 0x01 -- Key size + putWord8 0x00 -- Unsigned Transaction type + putSizedBytes unsignedTransaction + put globalUnknown + putWord8 0x00 -- Global end + + mapM_ put inputs + mapM_ put outputs + +instance Serialize Key where + get = do + VarInt keySize <- get + guard $ keySize > 0 + t <- getWord8 + k <- getBytes (fromIntegral keySize - 1) + return (Key t k) + + put (Key t k) = do + putVarInt $ 1 + B.length k + putWord8 t + putByteString k + +instance Serialize UnknownMap where + get = go HashMap.empty + where + getItem m = do + k <- get + VarString v <- get + go $ HashMap.insert k v m + go m = do + isEnd <- lookAhead getWord8 + if isEnd == 0x00 + then return (UnknownMap m) + else getItem m + + put (UnknownMap m) = void $ HashMap.traverseWithKey (\k v -> put k >> put (VarString v)) m + +instance Serialize Input where + get = getMap getInputItem setInputUnknown emptyInput + where + setInputUnknown f input = input { inputUnknown = UnknownMap $ f (unknownMap $ inputUnknown input) } + + put Input { nonWitnessUtxo, witnessUtxo, partialSigs, sigHashType + , inputRedeemScript, inputWitnessScript, inputHDKeypaths + , finalScriptSig, finalScriptWitness, inputUnknown + } = do + whenJust (putKeyValue InNonWitnessUtxo) nonWitnessUtxo + whenJust (putKeyValue InWitnessUtxo) witnessUtxo + putPartialSig partialSigs + whenJust putSigHash sigHashType + whenJust (putKeyValue InRedeemScript) inputRedeemScript + whenJust (putKeyValue InWitnessScript) inputWitnessScript + putHDPath InBIP32Derivation inputHDKeypaths + whenJust (putKeyValue InFinalScriptSig) finalScriptSig + whenJust (putKeyValue InFinalScriptWitness) finalScriptWitness + put inputUnknown + putWord8 0x00 + where + putPartialSig = putPubKeyMap InPartialSig . fmap VarString + putSigHash sigHash = do + putKey InSigHashType + putWord8 0x04 + putWord32le (fromIntegral sigHash) + +instance Serialize Output where + get = getMap getOutputItem setOutputUnknown emptyOutput + where + setOutputUnknown f output = output { outputUnknown = UnknownMap $ f (unknownMap $ outputUnknown output) } + + put Output{ outputRedeemScript, outputWitnessScript, outputHDKeypaths, outputUnknown } = do + whenJust (putKeyValue OutRedeemScript) outputRedeemScript + whenJust (putKeyValue OutWitnessScript) outputWitnessScript + putHDPath OutBIP32Derivation outputHDKeypaths + put outputUnknown + putWord8 0x00 + +putSizedBytes :: Serialize a => a -> Put +putSizedBytes a = putVarInt (B.length bs) >> putByteString bs + where bs = encode a + +getSizedBytes :: Serialize a => Get a +getSizedBytes = getNested (fromIntegral . getVarInt <$> get) get + +putKeyValue :: (Enum t, Serialize v) => t -> v -> Put +putKeyValue t v = putKey t >> putSizedBytes v + +putKey :: Enum t => t -> Put +putKey t = putVarInt (1 :: Word8) >> putWord8 (enumWord8 t) + +getMap :: (Bounded t, Enum t) + => (Int -> a -> t -> Get a) + -> ((HashMap Key ByteString -> HashMap Key ByteString) -> a -> a) + -> a -> Get a +getMap getMapItem setUnknown = go + where + getItem keySize m (Right t) = getMapItem (fromIntegral keySize - 1) m t >>= go + getItem keySize m (Left t) = do + k <- getBytes (fromIntegral keySize - 1) + VarString v <- get + go $ setUnknown (HashMap.insert (Key t k) v) m + go m = do + keySize <- getVarInt <$> get + if keySize == 0 + then return m + else getItem keySize m =<< (word8Enum <$> getWord8) + +data InputType + = InNonWitnessUtxo + | InWitnessUtxo + | InPartialSig + | InSigHashType + | InRedeemScript + | InWitnessScript + | InBIP32Derivation + | InFinalScriptSig + | InFinalScriptWitness + deriving (Show, Eq, Enum, Bounded, Generic) + +instance NFData InputType + +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 + return $ input { nonWitnessUtxo = Just utxo } +getInputItem 0 input@Input{witnessUtxo = Nothing} InWitnessUtxo = do + utxo <- getSizedBytes + return $ input { witnessUtxo = Just utxo } +getInputItem keySize input InPartialSig = do + (k, v) <- getPartialSig + return $ input { partialSigs = HashMap.insert k v (partialSigs input) } + where + getPartialSig = (,) <$> isolate keySize get <*> (getVarString <$> get) +getInputItem 0 input@Input{sigHashType = Nothing} InSigHashType = do + VarInt size <- get + guard $ size == 0x04 + sigHash <- fromIntegral <$> getWord32le + return $ input { sigHashType = Just sigHash } +getInputItem 0 input@Input{inputRedeemScript = Nothing} InRedeemScript = do + script <- getSizedBytes + return $ input { inputRedeemScript = Just script } +getInputItem 0 input@Input{inputWitnessScript = Nothing} InWitnessScript = do + script <- getSizedBytes + return $ input { inputWitnessScript = Just script } +getInputItem keySize input InBIP32Derivation = do + (k, v) <- getHDPath keySize + return $ input { inputHDKeypaths = HashMap.insert k v (inputHDKeypaths input) } +getInputItem 0 input@Input{finalScriptSig = Nothing} InFinalScriptSig = do + script <- getSizedBytes + return $ input { finalScriptSig = Just script } +getInputItem 0 input@Input{finalScriptWitness = Nothing} InFinalScriptWitness = do + scripts <- map getVarString <$> getVarIntList + return $ input { finalScriptWitness = Just scripts } + where + getVarIntList = do + VarInt n <- get + replicateM (fromIntegral n) get +getInputItem keySize input inputType = fail $ + "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 + return $ output { outputRedeemScript = Just script } +getOutputItem 0 output@Output{outputWitnessScript = Nothing} OutWitnessScript = do + script <- getSizedBytes + return $ output { outputWitnessScript = Just script } +getOutputItem keySize output OutBIP32Derivation = do + (k, v) <- getHDPath keySize + return $ output { outputHDKeypaths = HashMap.insert k v (outputHDKeypaths output) } +getOutputItem keySize output outputType = fail $ + "Incorrect key size for output item or item already existed: " <> + show (keySize, output, outputType) + +getHDPath :: Int -> Get (PubKeyI, (Fingerprint, [KeyIndex])) +getHDPath keySize = (,) <$> isolate keySize get <*> (unPSBTHDPath <$> get) + +putHDPath :: Enum t => t -> HashMap PubKeyI (Fingerprint, [KeyIndex]) -> Put +putHDPath t = putPubKeyMap t . fmap PSBTHDPath + +newtype PSBTHDPath = PSBTHDPath { unPSBTHDPath :: (Fingerprint, [KeyIndex]) } + deriving (Show, Eq, Generic) + +instance NFData PSBTHDPath + +instance Serialize PSBTHDPath where + get = do + VarInt valueSize <- get + guard $ valueSize `mod` 4 == 0 + let numIndices = (fromIntegral valueSize - 4) `div` 4 + PSBTHDPath <$> + isolate + (fromIntegral valueSize) + ((,) <$> getWord32le <*> getKeyIndexList numIndices) + where + getKeyIndexList n = replicateM n getWord32le + put (PSBTHDPath (fp, kis)) = putVarInt (B.length bs) >> putByteString bs + where + bs = runPut $ putWord32le fp >> mapM_ putWord32le kis + +putPubKeyMap :: (Serialize a, Enum t) => t -> HashMap PubKeyI a -> Put +putPubKeyMap t = void . HashMap.traverseWithKey putItem + where + putItem k v = put (Key (enumWord8 t) (encode k)) >> put 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 ()) diff --git a/src/Haskoin/Transaction/Segwit.hs b/src/Haskoin/Transaction/Segwit.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Transaction/Segwit.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-| +Module : Haskoin.Transaction.Segwit +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Types to represent segregated witness data and auxilliary functions to +manipulate it. See [BIP 141](https://github.com/bitcoin/bips/blob/master/bip-0141.mediawiki) +and [BIP 143](https://github.com/bitcoin/bips/blob/master/bip-0143.mediawiki) for +details. +-} +module Haskoin.Transaction.Segwit + ( WitnessProgram (..) + , WitnessProgramPKH (..) + , WitnessProgramSH (..) + , isSegwit + + , viewWitnessProgram + , decodeWitnessInput + + , calcWitnessProgram + , simpleInputStack + , toWitnessStack + ) where + +import Data.ByteString (ByteString) +import qualified Data.Serialize as S +import Haskoin.Constants (Network) +import Haskoin.Keys.Common (PubKeyI) +import Haskoin.Script.Common (Script (..), ScriptOutput (..), + decodeOutput, encodeOutput) +import Haskoin.Script.SigHash (TxSignature (..), decodeTxSig, + encodeTxSig) +import Haskoin.Script.Standard (ScriptInput (..), SimpleInput (..)) +import Haskoin.Transaction.Common (WitnessStack) + +-- | 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 +data WitnessProgram = P2WPKH WitnessProgramPKH | P2WSH WitnessProgramSH | EmptyWitnessProgram + deriving (Eq, Show) + +-- | Encode a witness program +-- +-- @since 0.11.0.0 +toWitnessStack :: WitnessProgram -> WitnessStack +toWitnessStack = \case + P2WPKH (WitnessProgramPKH sig key) -> [encodeTxSig sig, S.encode key] + P2WSH (WitnessProgramSH stack scr) -> stack <> [S.encode scr] + EmptyWitnessProgram -> mempty + +-- | 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 +data WitnessProgramSH = WitnessProgramSH + { witnessScriptHashStack :: ![ByteString] + , witnessScriptHashScript :: !Script + } deriving (Eq, Show) + +-- | Calculate the witness program from the transaction data +-- +-- @since 0.11.0.0 +viewWitnessProgram :: Network -> ScriptOutput -> WitnessStack -> Either String WitnessProgram +viewWitnessProgram net so witness = case so of + PayWitnessPKHash _ | length witness == 2 -> do + sig <- decodeTxSig net $ head witness + pubkey <- S.decode $ witness !! 1 + return . P2WPKH $ WitnessProgramPKH sig pubkey + PayWitnessScriptHash _ | not (null witness) -> do + redeemScript <- S.decode $ last witness + return . P2WSH $ WitnessProgramSH (init witness) redeemScript + _ | null witness -> return EmptyWitnessProgram + | otherwise -> Left "viewWitnessProgram: Invalid witness program" + +-- | Analyze the witness, trying to match it with standard input structures +-- +-- @since 0.11.0.0 +decodeWitnessInput :: Network -> WitnessProgram -> Either String (Maybe ScriptOutput, SimpleInput) +decodeWitnessInput net = \case + P2WPKH (WitnessProgramPKH sig key) -> return (Nothing, SpendPKHash sig key) + P2WSH (WitnessProgramSH st scr) -> do + so <- decodeOutput scr + fmap (Just so, ) $ case (so, st) of + (PayPK _, [sigBS]) -> + SpendPK <$> decodeTxSig net sigBS + (PayPKHash _, [sigBS, keyBS]) -> + SpendPKHash <$> decodeTxSig net sigBS <*> S.decode keyBS + (PayMulSig _ _, "" : sigsBS) -> + SpendMulSig <$> traverse (decodeTxSig net) sigsBS + _ -> Left "decodeWitnessInput: Non-standard script output" + EmptyWitnessProgram -> Left "decodeWitnessInput: Empty witness program" + +-- | Create the witness program for a standard input +-- +-- @since 0.11.0.0 +calcWitnessProgram :: ScriptOutput -> ScriptInput -> Either String WitnessProgram +calcWitnessProgram so si = case (so, si) of + (PayWitnessPKHash{}, RegularInput (SpendPKHash sig pk)) -> p2wpkh sig pk + (PayScriptHash{}, RegularInput (SpendPKHash sig pk)) -> p2wpkh sig pk + (PayWitnessScriptHash{}, ScriptHashInput i o) -> p2wsh i o + (PayScriptHash{}, ScriptHashInput i o) -> p2wsh i o + _ -> Left "calcWitnessProgram: Invalid segwit SigInput" + where + 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 +simpleInputStack :: SimpleInput -> [ByteString] +simpleInputStack = \case + SpendPK sig -> [f sig] + SpendPKHash sig k -> [f sig, S.encode k] + SpendMulSig sigs -> "" : fmap f sigs + where + f TxSignatureEmpty = "" + f sig = encodeTxSig sig diff --git a/src/Haskoin/Util.hs b/src/Haskoin/Util.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Util.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-| +Module : Haskoin.Util +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +This module defines various utility functions used across the library. +-} +module Haskoin.Util + ( + -- * ByteString Helpers + bsToInteger + , integerToBS + , hexBuilder + , encodeHex + , decodeHex + , getBits + + -- * Maybe & Either Helpers + , eitherToMaybe + , maybeToEither + , liftEither + , liftMaybe + + -- * Other Helpers + , updateIndex + , matchTemplate + , convertBits + + -- * Triples + , fst3 + , snd3 + , lst3 + + -- * JSON Utilities + , dropFieldLabel + , dropSumLabels + + ) where + +import Control.Monad (guard) +import Control.Monad.Except (ExceptT (..), liftEither) +import Data.Aeson.Types (Options (..), SumEncoding (..), + defaultOptions, defaultTaggedObject) +import Data.Bits +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as B16 +import Data.ByteString.Builder +import qualified Data.ByteString.Lazy as BL +import Data.Char (toLower) +import Data.List +import Data.Text (Text) +import qualified Data.Text.Encoding as E +import Data.Word (Word8) + +-- ByteString helpers + +-- | Decode a big endian 'Integer' from a 'ByteString'. +bsToInteger :: ByteString -> Integer +bsToInteger = BS.foldr f 0 . BS.reverse + where + f w n = toInteger w .|. shiftL n 8 + +-- | Encode an 'Integer' to a 'ByteString' as big endian. +integerToBS :: Integer -> ByteString +integerToBS 0 = BS.pack [0] +integerToBS i + | i > 0 = BS.reverse $ BS.unfoldr f i + | otherwise = error "integerToBS not defined for negative values" + where + f 0 = Nothing + f x = Just (fromInteger x :: Word8, x `shiftR` 8) + +hexBuilder :: ByteString -> Builder +hexBuilder = byteStringHex + +-- | Encode as string of human-readable hex characters. +encodeHex :: ByteString -> Text +encodeHex = E.decodeUtf8 . BL.toStrict . toLazyByteString . byteStringHex + +-- | Decode string of human-readable hex characters. +decodeHex :: Text -> Maybe ByteString +decodeHex text = + let (x, b) = B16.decode (E.encodeUtf8 text) + in guard (b == BS.empty) >> return x + +-- | Obtain 'Int' bits from beginning of 'ByteString'. Resulting 'ByteString' +-- will be smallest required to hold that many bits, padded with zeroes to the +-- right. +getBits :: Int -> ByteString -> ByteString +getBits b bs + | r == 0 = BS.take q bs + | otherwise = i `BS.snoc` l + where + (q, r) = b `quotRem` 8 + s = BS.take (q + 1) bs + i = BS.init s + l = BS.last s .&. (0xff `shiftL` (8 - r)) -- zero unneeded bits + +-- Maybe and Either monad helpers + +-- | Transform an 'Either' value into a 'Maybe' value. 'Right' is mapped to +-- 'Just' and 'Left' is mapped to 'Nothing'. The value inside 'Left' is lost. +eitherToMaybe :: Either a b -> Maybe b +eitherToMaybe (Right b) = Just b +eitherToMaybe _ = Nothing + +-- | Transform a 'Maybe' value into an 'Either' value. 'Just' is mapped to +-- 'Right' and 'Nothing' is mapped to 'Left'. Default 'Left' required. +maybeToEither :: b -> Maybe a -> Either b a +maybeToEither err = maybe (Left err) Right + +-- | Lift a 'Maybe' computation into the 'ExceptT' monad. +liftMaybe :: Monad m => b -> Maybe a -> ExceptT b m a +liftMaybe err = liftEither . maybeToEither err + +-- Various helpers + +-- | Applies a function to only one element of a list defined by its index. If +-- the index is out of the bounds of the list, the original list is returned. +updateIndex :: Int -- ^ index of the element to change + -> [a] -- ^ list of elements + -> (a -> a) -- ^ function to apply + -> [a] -- ^ result with one element changed +updateIndex i xs f + | i < 0 || i >= length xs = xs + | otherwise = l ++ (f h : r) + where + (l,h:r) = splitAt i xs + +-- | Use the list @[b]@ as a template and try to match the elements of @[a]@ +-- against it. For each element of @[b]@ return the (first) matching element of +-- @[a]@, or 'Nothing'. Output list has same size as @[b]@ and contains results +-- in same order. Elements of @[a]@ can only appear once. +matchTemplate :: [a] -- ^ input list + -> [b] -- ^ list to serve as a template + -> (a -> b -> Bool) -- ^ comparison function + -> [Maybe a] +matchTemplate [] bs _ = replicate (length bs) Nothing +matchTemplate _ [] _ = [] +matchTemplate as (b:bs) f = case break (`f` b) as of + (l,r:rs) -> Just r : matchTemplate (l ++ rs) bs f + _ -> Nothing : matchTemplate as bs f + +-- | Returns the first value of a triple. +fst3 :: (a,b,c) -> a +fst3 (a,_,_) = a + +-- | Returns the second value of a triple. +snd3 :: (a,b,c) -> b +snd3 (_,b,_) = b + +-- | Returns the last value of a triple. +lst3 :: (a,b,c) -> c +lst3 (_,_,c) = c + +-- | Field label goes lowercase and first @n@ characters get removed. +dropFieldLabel :: Int -> Options +dropFieldLabel n = defaultOptions + { fieldLabelModifier = map toLower . drop n + } + +-- | Transformation from 'dropFieldLabel' is applied with argument @f@, plus +-- constructor tags are lowercased and first @c@ characters removed. @tag@ is +-- used as the name of the object field name that will hold the transformed +-- constructor tag as its value. +dropSumLabels :: Int -> Int -> String -> Options +dropSumLabels c f tag = (dropFieldLabel f) + { constructorTagModifier = map toLower . drop c + , sumEncoding = defaultTaggedObject { tagFieldName = tag } + } + +-- | Convert from one power-of-two base to another, as long as it fits in a +-- 'Word'. +convertBits :: Bool -> Int -> Int -> [Word] -> ([Word], Bool) +convertBits pad frombits tobits i = (reverse yout, rem') + where + (xacc, xbits, xout) = foldl' outer (0, 0, []) i + (yout, rem') + | pad && xbits /= 0 = + let xout' = (xacc `shiftL` (tobits - xbits)) .&. maxv : xout + in (xout', False) + | pad = (xout, False) + | xbits /= 0 = (xout, True) + | otherwise = (xout, False) + maxv = 1 `shiftL` tobits - 1 + max_acc = 1 `shiftL` (frombits + tobits - 1) - 1 + outer (acc, bits, out) it = + let acc' = ((acc `shiftL` frombits) .|. it) .&. max_acc + bits' = bits + frombits + (out', bits'') = inner acc' out bits' + in (acc', bits'', out') + inner acc out bits + | bits >= tobits = + let bits' = bits - tobits + out' = ((acc `shiftR` bits') .&. maxv) : out + in inner acc out' bits' + | otherwise = (out, bits) diff --git a/src/Network/Haskoin/Address.hs b/src/Network/Haskoin/Address.hs deleted file mode 100644 --- a/src/Network/Haskoin/Address.hs +++ /dev/null @@ -1,314 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-| -Module : Network.Haskoin.Address -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Base58, CashAddr, Bech32 address and WIF private key serialization support. --} -module Network.Haskoin.Address - ( Address(..) - , isPubKeyAddress - , isScriptAddress - , isWitnessPubKeyAddress - , isWitnessScriptAddress - , addrToString - , stringToAddr - , addrToJSON - , addrToEncoding - , addrFromJSON - , pubKeyAddr - , pubKeyWitnessAddr - , pubKeyCompatWitnessAddr - , p2pkhAddr - , p2wpkhAddr - , p2shAddr - , p2wshAddr - , inputAddress - , outputAddress - , addressToScript - , addressToScriptBS - , addressToOutput - , payToScriptAddress - , payToWitnessScriptAddress - , payToNestedScriptAddress - , scriptToAddress - , scriptToAddressBS - -- * Private Key Wallet Import Format (WIF) - , fromWif - , toWif - -- * Base58 - , module Network.Haskoin.Address.Base58 - -- * Bech32 - , module Network.Haskoin.Address.Bech32 - -- * CashAddr - , module Network.Haskoin.Address.CashAddr - ) where - -import Control.Applicative -import Control.DeepSeq -import Control.Monad -import Data.Aeson as A -import Data.Aeson.Encoding as A -import Data.Aeson.Types -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Hashable -import Data.Maybe -import Data.Serialize as S -import Data.Text (Text) -import GHC.Generics (Generic) -import Network.Haskoin.Address.Base58 -import Network.Haskoin.Address.Bech32 -import Network.Haskoin.Address.CashAddr -import Network.Haskoin.Constants -import Network.Haskoin.Crypto -import Network.Haskoin.Keys.Common -import Network.Haskoin.Script -import Network.Haskoin.Util - --- | Address format for Bitcoin and Bitcoin Cash. -data Address - -- | pay to public key hash (regular) - = PubKeyAddress { getAddrHash160 :: !Hash160 - -- ^ RIPEMD160 hash of public key's SHA256 hash - } - -- | pay to script hash - | ScriptAddress { getAddrHash160 :: !Hash160 - -- ^ RIPEMD160 hash of script's SHA256 hash - } - -- | pay to witness public key hash - | WitnessPubKeyAddress { getAddrHash160 :: !Hash160 - -- ^ RIPEMD160 hash of public key's SHA256 hash - } - -- | pay to witness script hash - | WitnessScriptAddress { getAddrHash256 :: !Hash256 - -- ^ HASH256 hash of script - } - deriving (Eq, Ord, Generic, Show, Read, Serialize, Hashable, NFData) - --- | '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. -isWitnessPubKeyAddress :: Address -> Bool -isWitnessPubKeyAddress WitnessPubKeyAddress {} = True -isWitnessPubKeyAddress _ = False - --- | 'Address' pays to a witness script hash. Only valid for SegWit networks. -isWitnessScriptAddress :: Address -> Bool -isWitnessScriptAddress WitnessScriptAddress {} = True -isWitnessScriptAddress _ = False - --- | Deserializer for binary 'Base58' addresses. -base58get :: Network -> Get Address -base58get net = do - pfx <- getWord8 - addr <- S.get - f pfx addr - where - f x a - | x == getAddrPrefix net = return $ PubKeyAddress a - | x == getScriptPrefix net = return $ ScriptAddress a - | otherwise = fail "Does not recognize address prefix" - --- | Binary serializer for 'Base58' addresses. -base58put :: Network -> Putter Address -base58put net (PubKeyAddress h) = do - putWord8 (getAddrPrefix net) - put h -base58put net (ScriptAddress h) = do - putWord8 (getScriptPrefix net) - put h -base58put _ _ = error "Cannot serialize this address as Base58" - -addrToJSON :: Network -> Address -> Value -addrToJSON net a = toJSON (addrToString net a) - -addrToEncoding :: Network -> Address -> Encoding -addrToEncoding net a = - case addrToString net a of - Nothing -> null_ - Just txt -> text txt - --- | JSON parsing for Bitcoin addresses. Works with 'Base58', 'CashAddr' and --- 'Bech32'. -addrFromJSON :: Network -> Value -> Parser Address -addrFromJSON net = - withText "address" $ \t -> - case stringToAddr net t of - Nothing -> fail "could not decode address" - Just x -> return x - --- | Convert address to human-readable string. Uses 'Base58', 'Bech32', or --- 'CashAddr' depending on network. -addrToString :: Network -> Address -> Maybe Text -addrToString net a@PubKeyAddress {getAddrHash160 = h} - | isNothing (getCashAddrPrefix net) = - Just . encodeBase58Check . runPut $ base58put net a - | otherwise = - cashAddrEncode net 0 (S.encode h) -addrToString net a@ScriptAddress {getAddrHash160 = h} - | isNothing (getCashAddrPrefix net) = - Just . encodeBase58Check . runPut $ base58put net a - | otherwise = - cashAddrEncode net 1 (S.encode h) -addrToString net WitnessPubKeyAddress {getAddrHash160 = h} = do - hrp <- getBech32Prefix net - segwitEncode hrp 0 (B.unpack (S.encode h)) -addrToString net WitnessScriptAddress {getAddrHash256 = h} = do - hrp <- getBech32Prefix net - segwitEncode hrp 0 (B.unpack (S.encode h)) - --- | Parse 'Base58', 'Bech32' or 'CashAddr' address, depending on network. -stringToAddr :: Network -> Text -> Maybe Address -stringToAddr net bs = cash <|> segwit <|> b58 - where - b58 = eitherToMaybe . runGet (base58get net) =<< decodeBase58Check bs - cash = cashAddrDecode net bs >>= \(ver, bs') -> case ver of - 0 -> do - h <- eitherToMaybe (S.decode bs') - return $ PubKeyAddress h - 1 -> do - h <- eitherToMaybe (S.decode bs') - return $ ScriptAddress h - _ -> Nothing - segwit = do - hrp <- getBech32Prefix net - (ver, bs') <- segwitDecode hrp bs - guard (ver == 0) - let bs'' = B.pack bs' - case B.length bs'' of - 20 -> do - h <- eitherToMaybe (S.decode bs'') - return $ WitnessPubKeyAddress h - 32 -> do - h <- eitherToMaybe (S.decode bs'') - return $ WitnessScriptAddress h - _ -> Nothing - --- | Obtain a standard pay-to-public-key-hash address from a public key. -pubKeyAddr :: PubKeyI -> Address -pubKeyAddr = PubKeyAddress . addressHash . S.encode - --- | Obtain a standard pay-to-public-key-hash (P2PKH) address from a 'Hash160'. -p2pkhAddr :: Hash160 -> Address -p2pkhAddr = PubKeyAddress - --- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a --- public key. -pubKeyWitnessAddr :: PubKeyI -> Address -pubKeyWitnessAddr = WitnessPubKeyAddress . addressHash . S.encode - --- | Obtain a backwards-compatible SegWit P2SH-P2WPKH address from a public key. -pubKeyCompatWitnessAddr :: PubKeyI -> Address -pubKeyCompatWitnessAddr = - p2shAddr . - addressHash . encodeOutputBS . PayWitnessPKHash . addressHash . S.encode - --- | 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. -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. -addressToOutput :: Address -> ScriptOutput -addressToOutput (PubKeyAddress h) = PayPKHash h -addressToOutput (ScriptAddress h) = PayScriptHash h -addressToOutput (WitnessPubKeyAddress h) = PayWitnessPKHash h -addressToOutput (WitnessScriptAddress h) = PayWitnessScriptHash h - --- | 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 = S.encode . 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 (PayPKHash h) = Just $ PubKeyAddress h -outputAddress (PayScriptHash h) = Just $ ScriptAddress h -outputAddress (PayPK k) = Just $ pubKeyAddr k -outputAddress (PayWitnessPKHash h) = Just $ WitnessPubKeyAddress h -outputAddress (PayWitnessScriptHash h) = Just $ WitnessScriptAddress h -outputAddress _ = Nothing - --- | Infer the 'Address' of a 'ScriptInput'. -inputAddress :: ScriptInput -> Maybe Address -inputAddress (RegularInput (SpendPKHash _ key)) = Just $ pubKeyAddr key -inputAddress (ScriptHashInput _ rdm) = Just $ payToScriptAddress rdm -inputAddress _ = Nothing - --- | Decode private key from WIF (wallet import format) string. -fromWif :: Network -> Base58 -> Maybe SecKeyI -fromWif net wif = do - bs <- decodeBase58Check wif - -- Check that this is a private key - guard (B.head bs == getSecretPrefix net) - case B.length bs of - -- Uncompressed format - 33 -> wrapSecKey False <$> secKey (B.tail bs) - -- Compressed format - 34 -> do - guard $ B.last bs == 0x01 - wrapSecKey True <$> secKey (B.tail $ B.init bs) - -- Bad length - _ -> Nothing - --- | Encode private key into a WIF string. -toWif :: Network -> SecKeyI -> Base58 -toWif net (SecKeyI k c) = - encodeBase58Check . B.cons (getSecretPrefix net) $ - if c - then getSecKey k `B.snoc` 0x01 - else getSecKey k diff --git a/src/Network/Haskoin/Address/Base58.hs b/src/Network/Haskoin/Address/Base58.hs deleted file mode 100644 --- a/src/Network/Haskoin/Address/Base58.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-| -Module : Network.Haskoin.Address.Base58 -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Support for legacy 'Base58' addresses. Superseded by Bech32 for Bitcoin SegWit -(BTC) and CashAddr for Bitcoin Cash (BCH). --} -module Network.Haskoin.Address.Base58 - ( Base58 - , encodeBase58 - , decodeBase58 - , encodeBase58Check - , decodeBase58Check - ) where - -import Control.Monad -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as C -import Data.Maybe (fromMaybe, isJust, listToMaybe) -import Data.Serialize as S -import Data.String.Conversions (cs) -import Data.Text (Text) -import qualified Data.Text as T -import Network.Haskoin.Crypto.Hash -import Network.Haskoin.Util -import Numeric (readInt, showIntAtBase) - --- | 'Base58' classic Bitcoin address format. -type Base58 = Text - --- | Symbols for Base58 encoding. -b58Data :: ByteString -b58Data = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz" - --- | Convert a number less than or equal to provided integer into a 'Base58' --- character. -b58 :: Int -> Char -b58 = C.index b58Data - --- | Convert a 'Base58' character into the number it represents. -b58' :: Char -> Maybe Int -b58' = flip C.elemIndex b58Data - --- | 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 b58 i "" - --- | Decode a 'Base58' string into an arbitrary-length 'Integer'. -decodeBase58I :: Base58 -> Maybe Integer -decodeBase58I s = - case go of - Just (r,[]) -> Just r - _ -> Nothing - where - p = isJust . b58' - f = fromMaybe e . b58' - 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. -encodeBase58 :: ByteString -> Base58 -encodeBase58 bs = - l `mappend` r - where - (z, b) = BS.span (== 0) bs - l = cs $ BS.replicate (BS.length z) (BS.index b58Data 0) -- preserve leading 0's - r | BS.null b = T.empty - | otherwise = encodeBase58I $ bsToInteger b - --- | Decode a 'Base58'-encoded 'Text' to a 'ByteString'. -decodeBase58 :: Base58 -> Maybe ByteString -decodeBase58 t = - BS.append prefix <$> r - where - (z, b) = BS.span (== BS.index b58Data 0) (cs t) - prefix = BS.replicate (BS.length z) 0 -- preserve leading 1's - r | 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'. -encodeBase58Check :: ByteString -> Base58 -encodeBase58Check bs = - encodeBase58 $ BS.append bs $ encode $ 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. -decodeBase58Check :: Base58 -> Maybe ByteString -decodeBase58Check bs = do - rs <- decodeBase58 bs - let (res, chk) = BS.splitAt (BS.length rs - 4) rs - guard $ chk == encode (checkSum32 res) - return res diff --git a/src/Network/Haskoin/Address/Bech32.hs b/src/Network/Haskoin/Address/Bech32.hs deleted file mode 100644 --- a/src/Network/Haskoin/Address/Bech32.hs +++ /dev/null @@ -1,228 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-| -Module : Network.Haskoin.Address.Base58 -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Support for Bitcoin SegWit (BTC) Bech32 addresses. This module is a modified -version of Marko Bencun's reference implementation. --} -module Network.Haskoin.Address.Bech32 - ( HRP - , Bech32 - , Data - , bech32Encode - , bech32Decode - , toBase32 - , toBase256 - , segwitEncode - , segwitDecode - , Word5(..) - , word5 - , fromWord5 - ) where - -import Control.Monad (guard) -import Data.Array (Array, assocs, bounds, listArray, (!), - (//)) -import Data.Bits (Bits, testBit, unsafeShiftL, - unsafeShiftR, xor, (.&.), (.|.)) -import qualified Data.ByteString as B -import Data.Char (toUpper) -import Data.Foldable (foldl') -import Data.Functor.Identity (Identity, runIdentity) -import Data.Ix (Ix (..)) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as E -import Data.Word (Word8) - --- | 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 - | inRange (bounds inv) upperC = inv ! upperC - | otherwise = Nothing - where - upperC = toUpper 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 - where - go chk value = - foldl' xor chk' [g | (g, i) <- zip generator [25 ..], testBit chk i] - where - generator = [0x3b6a57b2, 0x26508e6d, 0x1ea119fa, 0x3d4233dd, 0x2a1462b3] - chk' = chk .<<. 5 `xor` fromWord5 value - --- | Convert human-readable part of 'Bech32' string into a list of five-bit --- words. -bech32HRPExpand :: HRP -> [Word5] -bech32HRPExpand hrp = - map (UnsafeWord5 . (.>>. 5)) hrpBytes ++ - [UnsafeWord5 0] ++ map word5 hrpBytes - where - hrpBytes = B.unpack $ E.encodeUtf8 hrp - --- | Calculate checksum for a string of five-bit words. -bech32CreateChecksum :: HRP -> [Word5] -> [Word5] -bech32CreateChecksum hrp dat = [word5 (polymod .>>. i) | i <- [25,20 .. 0]] - where - values = bech32HRPExpand hrp ++ dat - polymod = - bech32Polymod (values ++ map UnsafeWord5 [0, 0, 0, 0, 0, 0]) `xor` 1 - --- | Verify checksum for a human-readable part and string of five-bit words. -bech32VerifyChecksum :: HRP -> [Word5] -> Bool -bech32VerifyChecksum hrp dat = bech32Polymod (bech32HRPExpand hrp ++ dat) == 1 - --- | 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. -bech32Encode :: HRP -> [Word5] -> Maybe Bech32 -bech32Encode hrp dat = do - guard $ checkHRP hrp - let dat' = dat ++ bech32CreateChecksum (T.toLower hrp) dat - rest = map (charset !) dat' - result = T.concat [T.toLower hrp, T.pack "1", T.pack rest] - guard $ T.length result <= maxBech32Length - return result - --- | Check that human-readable part is valid for a 'Bech32' string. -checkHRP :: HRP -> Bool -checkHRP hrp = not (T.null hrp) && T.all (\char -> char >= '\x21' && char <= '\x7e') hrp - --- | Decode human-readable 'Bech32' string into a human-readable part and a --- string of five-bit words. -bech32Decode :: Bech32 -> Maybe (HRP, [Word5]) -bech32Decode bech32 = do - guard $ T.length bech32 <= maxBech32Length - guard $ T.toUpper bech32 == bech32 || lowerBech32 == bech32 - let (hrp, dat) = T.breakOnEnd "1" lowerBech32 - guard $ T.length dat >= 6 - hrp' <- T.stripSuffix "1" hrp - guard $ checkHRP hrp' - dat' <- mapM charsetMap $ T.unpack dat - guard $ bech32VerifyChecksum hrp' dat' - return (hrp', take (T.length dat - 6) dat') - 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}\). -convertBits :: Functor f => [Word] -> Int -> Int -> Pad f -> f [Word] -convertBits dat frombits tobits pad = concat . reverse <$> go dat 0 0 [] - where - go [] acc bits result = - let padValue = (acc .<<. (tobits - bits)) .&. maxv - in pad frombits bits padValue result - go (value:dat') acc bits result = - go dat' acc' (bits' `rem` tobits) (result' : result) - where - acc' = (acc .<<. frombits) .|. fromIntegral value - bits' = bits + frombits - result' = - [ (acc' .>>. b) .&. maxv - | b <- [bits' - tobits,bits' - 2 * tobits .. 0] - ] - maxv = (1 .<<. tobits) - 1 -{-# INLINE convertBits #-} - --- | Convert from eight-bit to five-bit word string, adding padding as required. -toBase32 :: [Word8] -> [Word5] -toBase32 dat = - map word5 $ runIdentity $ convertBits (map fromIntegral dat) 8 5 yesPadding - --- | 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 :: Word8 -> Data -> Bool -segwitCheck witver witprog = - witver <= 16 && - if witver == 0 - then length witprog == 20 || length witprog == 32 - else 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 - (hrp', dat) <- bech32Decode addr - guard $ (hrp == hrp') && not (null dat) - let (UnsafeWord5 witver:datBase32) = dat - decoded <- toBase256 datBase32 - guard $ segwitCheck witver decoded - return (witver, decoded) - --- | 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 witver witprog - bech32Encode hrp $ UnsafeWord5 witver : toBase32 witprog diff --git a/src/Network/Haskoin/Address/CashAddr.hs b/src/Network/Haskoin/Address/CashAddr.hs deleted file mode 100644 --- a/src/Network/Haskoin/Address/CashAddr.hs +++ /dev/null @@ -1,198 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-| -Module : Network.Haskoin.Address.CashAddr -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Support for Bitcoin Cash (BCH) CashAddr format. --} -module Network.Haskoin.Address.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 Network.Haskoin.Constants -import Network.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/Network/Haskoin/Block.hs b/src/Network/Haskoin/Block.hs deleted file mode 100644 --- a/src/Network/Haskoin/Block.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-| -Module : Network.Haskoin.Block -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Most functions relating to blocks are exported by this module. --} -module Network.Haskoin.Block - ( module Network.Haskoin.Block.Common - -- * Block Header Chain - , module Network.Haskoin.Block.Headers - -- * Merkle Blocks - , module Network.Haskoin.Block.Merkle - ) where - -import Network.Haskoin.Block.Headers -import Network.Haskoin.Block.Merkle -import Network.Haskoin.Block.Common diff --git a/src/Network/Haskoin/Block/Common.hs b/src/Network/Haskoin/Block/Common.hs deleted file mode 100644 --- a/src/Network/Haskoin/Block/Common.hs +++ /dev/null @@ -1,348 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-| -Module : Network.Haskoin.Block.Common -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Common data types and functions to handle blocks from the block chain. --} -module Network.Haskoin.Block.Common - ( Block(..) - , BlockHeight - , Timestamp - , BlockHeader(..) - , headerHash - , BlockLocator - , GetBlocks(..) - , GetHeaders(..) - , BlockHeaderCount - , BlockHash(..) - , blockHashToHex - , hexToBlockHash - , Headers(..) - , decodeCompact - , encodeCompact - ) where - -import Control.DeepSeq -import Control.Monad (forM_, liftM2, mzero, - replicateM) -import Data.Aeson (FromJSON (..), ToJSON (..), - Value (String), toJSON, - withText) -import Data.Aeson.Encoding (unsafeToEncoding) -import Data.Bits (shiftL, shiftR, (.&.), - (.|.)) -import qualified Data.ByteString as B -import Data.ByteString.Builder (char7) -import Data.Hashable (Hashable) -import Data.Maybe (fromMaybe) -import Data.Serialize (Serialize, decode, encode, - get, put) -import Data.Serialize.Get (getWord32le) -import Data.Serialize.Put (Put, putWord32le) -import Data.String (IsString, fromString) -import Data.String.Conversions (cs) -import Data.Text (Text) -import Data.Word (Word32) -import GHC.Generics (Generic) -import Network.Haskoin.Crypto.Hash -import Network.Haskoin.Network.Common -import Network.Haskoin.Transaction.Common -import Network.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 - , blockTxns :: ![Tx] - } deriving (Eq, Show, Read, Generic, Hashable, NFData) - -instance Serialize Block where - get = do - header <- get - (VarInt c) <- get - txs <- replicateM (fromIntegral c) get - return $ Block header txs - put (Block h txs) = do - put h - putVarInt $ length txs - forM_ txs put - -instance ToJSON Block where - toJSON = String . encodeHex . encode - toEncoding s = - unsafeToEncoding $ char7 '"' <> hexBuilder (encode s) <> char7 '"' - -instance FromJSON Block where - parseJSON = - withText "Block" $ \t -> do - bin <- - case decodeHex t of - Nothing -> mzero - Just bin -> return bin - case decode bin of - Left e -> fail e - Right h -> return h - -instance ToJSON BlockHeader where - toJSON = String . encodeHex . encode - toEncoding s = - unsafeToEncoding $ char7 '"' <> hexBuilder (encode s) <> char7 '"' - -instance FromJSON BlockHeader where - parseJSON = - withText "BlockHeader" $ \t -> do - bin <- - case decodeHex t of - Nothing -> mzero - Just bin -> return bin - case decode bin of - Left e -> fail e - Right h -> return h - --- | Block header hash. To be serialized reversed for display purposes. -newtype BlockHash = BlockHash - { getBlockHash :: Hash256 } - deriving (Eq, Ord, Generic, Hashable, Serialize, NFData) - -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 "block hash" $ - maybe mzero return . hexToBlockHash - -instance ToJSON BlockHash where - toJSON = String . blockHashToHex - toEncoding s = - unsafeToEncoding $ - char7 '"' <> hexBuilder (B.reverse (encode s)) <> char7 '"' - --- | 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 (encode h)) - --- | 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 (decode 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 BlockHeader = - BlockHeader { blockVersion :: !Word32 -- 4 bytes - -- | hash of the previous block (parent) - , prevBlock :: !BlockHash -- 32 bytes - -- | root of the merkle tree of transactions - , merkleRoot :: !Hash256 -- 32 bytes - -- | unix timestamp - , blockTimestamp :: !Timestamp -- 4 bytes - -- | difficulty target - , blockBits :: !Word32 -- 4 bytes - -- | random nonce - , bhNonce :: !Word32 -- 4 bytes - } deriving (Eq, Ord, Show, Read, Generic, Hashable, NFData) - -- 80 bytes - --- | Compute hash of 'BlockHeader'. -headerHash :: BlockHeader -> BlockHash -headerHash = BlockHash . doubleSHA256 . encode - -instance Serialize BlockHeader where - get = do - v <- getWord32le - p <- get - m <- get - t <- getWord32le - b <- getWord32le - n <- getWord32le - return BlockHeader - { blockVersion = v - , prevBlock = p - , merkleRoot = m - , blockTimestamp = t - , blockBits = b - , bhNonce = n - } - - put (BlockHeader v p m bt bb n) = do - putWord32le v - put p - put m - putWord32le bt - putWord32le bb - putWord32le n - --- | 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 GetBlocks = - GetBlocks { -- | protocol version. - getBlocksVersion :: !Word32 - -- | block locator object - , getBlocksLocator :: !BlockLocator - -- | hash of the last desired block - , getBlocksHashStop :: !BlockHash - } deriving (Eq, Show, Generic, NFData) - -instance Serialize GetBlocks where - - get = GetBlocks <$> getWord32le - <*> (repList =<< get) - <*> get - where - repList (VarInt c) = replicateM (fromIntegral c) get - - put (GetBlocks v xs h) = putGetBlockMsg v xs h - -putGetBlockMsg :: Word32 -> BlockLocator -> BlockHash -> Put -putGetBlockMsg v xs h = do - putWord32le v - putVarInt $ length xs - forM_ xs put - put 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. -data GetHeaders = - GetHeaders { - -- | protocol version - getHeadersVersion :: !Word32 - -- | block locator object - , getHeadersBL :: !BlockLocator - -- | hash of the last desired block header - , getHeadersHashStop :: !BlockHash - } deriving (Eq, Show, Generic, NFData) - -instance Serialize GetHeaders where - - get = GetHeaders <$> getWord32le - <*> (repList =<< get) - <*> get - where - repList (VarInt c) = replicateM (fromIntegral c) get - - put (GetHeaders v xs h) = putGetBlockMsg v xs h - --- | '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. -newtype Headers = - Headers { -- | list of block headers with transaction count - headersList :: [BlockHeaderCount] - } - deriving (Eq, Show, Generic, NFData) - -instance Serialize Headers where - - get = Headers <$> (repList =<< get) - where - repList (VarInt c) = replicateM (fromIntegral c) action - action = liftM2 (,) get get - - put (Headers xs) = do - putVarInt $ length xs - forM_ xs $ \(a,b) -> put a >> put b - --- | 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 -> (Integer, Bool) -- ^ true means overflow -decodeCompact nCompact = (if neg then res * (-1) else res, over) - where - nSize :: Int - nSize = fromIntegral nCompact `shiftR` 24 - nWord' :: Word32 - nWord' = nCompact .&. 0x007fffff - nWord :: Word32 - nWord | nSize <= 3 = nWord' `shiftR` (8 * (3 - nSize)) - | otherwise = nWord' - res :: Integer - res | nSize <= 3 = fromIntegral nWord - | otherwise = fromIntegral nWord `shiftL` (8 * (nSize - 3)) - neg = nWord /= 0 && (nCompact .&. 0x00800000) /= 0 - over = nWord /= 0 && (nSize > 34 || - nWord > 0xff && nSize > 33 || - nWord > 0xffff && nSize > 32) - --- | Encode an 'Integer' to the compact number format used in the difficulty --- target of a block. -encodeCompact :: Integer - -> Word32 -encodeCompact i = nCompact - where - i' = abs i - neg = i < 0 - nSize' :: Int - nSize' = let f 0 = 0 - f n = 1 + f (n `shiftR` 8) - in f i' - nCompact''' :: Word32 - nCompact''' - | nSize' <= 3 = fromIntegral $ (low64 .&. i') `shiftL` (8 * (3 - nSize')) - | otherwise = fromIntegral $ low64 .&. (i' `shiftR` (8 * (nSize' - 3))) - nCompact'' :: Word32 - nSize :: Int - (nCompact'', nSize) - | nCompact''' .&. 0x00800000 /= 0 = (nCompact''' `shiftR` 8, nSize' + 1) - | otherwise = (nCompact''', nSize') - nCompact' :: Word32 - nCompact' = nCompact'' .|. (fromIntegral nSize `shiftL` 24) - nCompact :: Word32 - nCompact | neg && (nCompact' .&. 0x007fffff /= 0) = nCompact' .|. 0x00800000 - | otherwise = nCompact' - low64 :: Integer - low64 = 0xffffffffffffffff diff --git a/src/Network/Haskoin/Block/Headers.hs b/src/Network/Haskoin/Block/Headers.hs deleted file mode 100644 --- a/src/Network/Haskoin/Block/Headers.hs +++ /dev/null @@ -1,741 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-| -Module : Network.Haskoin.Block.Headers -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Block chain header synchronization and proof-of-work consensus functions. --} -module Network.Haskoin.Block.Headers - ( BlockNode(..) - , BlockHeaders(..) - , BlockWork - , genesisNode - , genesisBlock - , isGenesis - , chooseBest - -- * Header Chain Storage Functions - , parentBlock - , getParents - , getAncestor - , splitPoint - , connectBlocks - , connectBlock - , blockLocator - -- * In-Memory Header Chain Store - , HeaderMemory(..) - , ShortBlockHash - , BlockMap - , shortBlockHash - , initialChain - , genesisMap - -- * Helper Functions - , appendBlocks - , validBlock - , validCP - , afterLastCP - , bip34 - , validVersion - , lastNoMinDiff - , nextWorkRequired - , nextEdaWorkRequired - , nextDaaWorkRequired - , computeTarget - , getSuitableBlock - , nextPowWorkRequired - , calcNextWork - , isValidPOW - , blockPOW - , headerWork - , diffInterval - , blockLocatorNodes - , mineBlock - , computeSubsidy - , ) where - -import Control.Applicative ((<|>)) -import Control.DeepSeq -import Control.Monad (guard, unless, when) -import Control.Monad.Except (ExceptT (..), runExceptT, - throwError) -import Control.Monad.State.Strict as State (StateT, get, gets, - lift, modify) -import Control.Monad.Trans.Maybe -import Data.Bits (shiftL, shiftR, (.&.)) -import qualified Data.ByteString as B -import Data.ByteString.Short (ShortByteString, fromShort, - toShort) -import Data.Function (on) -import Data.Hashable -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.List (sort, sortBy) -import Data.Maybe (fromMaybe, listToMaybe) -import Data.Serialize as S (Serialize (..), - decode, encode, get, - put) -import Data.Serialize.Get as S -import Data.Serialize.Put as S -import Data.Typeable (Typeable) -import Data.Word (Word32, Word64) -import GHC.Generics (Generic) -import Network.Haskoin.Block.Common -import Network.Haskoin.Constants -import Network.Haskoin.Crypto -import Network.Haskoin.Transaction.Common -import Network.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). -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. -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 BlockNode - -- | non-Genesis block header - = BlockNode { nodeHeader :: !BlockHeader - , nodeHeight :: !BlockHeight - -- | accumulated work so far - , nodeWork :: !BlockWork - -- | akip magic block hash - , nodeSkip :: !BlockHash } - -- | Genesis block header - | GenesisNode { nodeHeader :: !BlockHeader - , nodeHeight :: !BlockHeight - , nodeWork :: !BlockWork } - deriving (Show, Read, Generic, Hashable, NFData) - -instance Serialize BlockNode where - get = do - nodeHeader <- S.get - nodeHeight <- getWord32le - nodeWork <- S.get - if nodeHeight == 0 - then return GenesisNode {..} - else do - nodeSkip <- S.get - return BlockNode {..} - put bn = do - put $ nodeHeader bn - putWord32le $ nodeHeight bn - put $ nodeWork bn - case bn of - GenesisNode {} -> return () - BlockNode {} -> put $ nodeSkip bn - -instance Eq BlockNode where - (==) = (==) `on` nodeHeader - -instance Ord BlockNode where - compare = compare `on` nodeHeight - --- | Memory-based header tree. -data HeaderMemory = HeaderMemory - { memoryHeaderMap :: !BlockMap - , memoryBestHeader :: !BlockNode - } deriving (Eq, Typeable, Show, Read, Generic, Hashable, NFData) - --- | Typeclass for block header chain storage monad. -class Monad m => BlockHeaders m where - -- | Add a new 'BlockNode' to the chain. Does not validate. - addBlockHeader :: BlockNode -> m () - -- | 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 = HeaderMemory - { memoryHeaderMap = genesisMap net - , memoryBestHeader = genesisNode net - } - --- | Initialize map for memory-based chain. -genesisMap :: Network -> BlockMap -genesisMap net = - HashMap.singleton - (shortBlockHash (headerHash (getGenesisHeader net))) - (toShort (encode (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 . decode $ 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. -shortBlockHash :: BlockHash -> ShortBlockHash -shortBlockHash = either error id . decode . B.take 8 . encode - --- | Add a block to memory-based block map. -addBlockToMap :: BlockNode -> BlockMap -> BlockMap -addBlockToMap node = - HashMap.insert - (shortBlockHash $ headerHash $ nodeHeader node) - (toShort $ encode node) - --- | Get the ancestor of the provided 'BlockNode' at the specified --- 'BlockHeight'. -getAncestor :: BlockHeaders m - => BlockHeight - -> BlockNode - -> m (Maybe BlockNode) -getAncestor height node - | height > nodeHeight node = return Nothing - | otherwise = go node - where - e1 = error "Could not get skip header" - e2 = error "Could not get previous block header" - go walk - | nodeHeight walk > height = - let heightSkip = skipHeight (nodeHeight walk) - heightSkipPrev = skipHeight (nodeHeight walk - 1) - in if not (isGenesis walk) && - (heightSkip == height || - (heightSkip > height && - not - (heightSkipPrev < heightSkip - 2 && - heightSkipPrev >= height))) - then do - walk' <- fromMaybe e1 <$> getBlockHeader (nodeSkip walk) - go walk' - else do - walk' <- - fromMaybe e2 <$> - getBlockHeader (prevBlock (nodeHeader walk)) - go walk' - | otherwise = return $ Just walk - --- | Is the provided 'BlockNode' the Genesis block? -isGenesis :: BlockNode -> Bool -isGenesis GenesisNode{} = True -isGenesis BlockNode{} = False - --- | Build the genesis 'BlockNode' for the supplied 'Network'. -genesisNode :: Network -> BlockNode -genesisNode net = - GenesisNode - { nodeHeader = getGenesisHeader net - , nodeHeight = 0 - , nodeWork = headerWork (getGenesisHeader net) - } - --- | 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 - -> Timestamp -- ^ current time - -> [BlockHeader] - -> m (Either String [BlockNode]) -connectBlocks _ _ [] = return $ Right [] -connectBlocks net t bhs@(bh:_) = - runExceptT $ do - unless (chained bhs) $ - throwError "Blocks to connect do not form a chain" - par <- - maybeToExceptT - "Could not get parent block" - (MaybeT (parentBlock bh)) - pars <- lift $ getParents 10 par - bb <- lift getBestBlockHeader - go par [] bb par pars bhs >>= \case - bns@(bn:_) -> do - lift $ addBlockHeaders bns - let bb' = chooseBest bn bb - when (bb' /= bb) $ lift $ setBestBlockHeader bb' - return bns - _ -> undefined - where - chained (h1:h2:hs) = headerHash h1 == prevBlock h2 && chained (h2 : hs) - chained _ = True - skipit lbh ls par - | sh == nodeHeight lbh = return lbh - | sh < nodeHeight lbh = do - skM <- lift $ getAncestor sh lbh - case skM of - Just sk -> return sk - Nothing -> - throwError $ - "BUG: Could not get skip for block " ++ - show (headerHash $ nodeHeader par) - | otherwise = do - let sn = ls !! fromIntegral (nodeHeight par - sh) - when (nodeHeight sn /= sh) $ - throwError "BUG: Node height not right in skip" - return sn - where - sh = skipHeight (nodeHeight par + 1) - go _ acc _ _ _ [] = return acc - go lbh acc bb par pars (h:hs) = do - sk <- skipit lbh acc par - bn <- ExceptT . return $ validBlock net t bb par pars h sk - go lbh (bn : acc) (chooseBest bn bb) bn (take 10 $ par : pars) hs - --- | 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. -connectBlock :: - BlockHeaders m - => Network - -> Timestamp -- ^ current time - -> BlockHeader - -> m (Either String BlockNode) -connectBlock net t bh = - runExceptT $ do - par <- - maybeToExceptT - "Could not get parent block" - (MaybeT (parentBlock bh)) - pars <- lift $ getParents 10 par - skM <- lift $ getAncestor (skipHeight (nodeHeight par + 1)) par - sk <- - case skM of - Just sk -> return sk - Nothing -> - throwError $ - "BUG: Could not get skip for block " ++ - show (headerHash $ nodeHeader par) - bb <- lift getBestBlockHeader - bn <- ExceptT . return $ validBlock net t bb par pars bh sk - let bb' = chooseBest bb bn - lift $ addBlockHeader bn - when (bb /= bb') . lift $ setBestBlockHeader bb' - return bn - --- | Validate this block header. Build a 'BlockNode' if successful. -validBlock :: Network - -> Timestamp -- ^ current time - -> BlockNode -- ^ best block - -> BlockNode -- ^ immediate parent - -> [BlockNode] -- ^ 10 parents above - -> BlockHeader -- ^ header to validate - -> BlockNode -- ^ skip node (black magic) - -> Either String BlockNode -validBlock net t bb par pars bh sk = do - let mt = medianTime . map (blockTimestamp . nodeHeader) $ par : pars - nt = blockTimestamp bh - hh = headerHash bh - nv = blockVersion bh - ng = nodeHeight par + 1 - aw = nodeWork par + headerWork bh - unless (isValidPOW net bh) $ - Left $ "Proof of work failed: " ++ show (headerHash bh) - unless (nt <= t + 2 * 60 * 60) $ - Left $ "Invalid header timestamp: " ++ show nt - unless (nt >= mt) $ - Left $ "Block timestamp too early: " ++ show nt - unless (afterLastCP net (nodeHeight bb) ng) $ - Left $ "Rewriting pre-checkpoint chain: " ++ show ng - unless (validCP net ng hh) $ - Left $ "Rejected checkpoint: " ++ show ng - unless (bip34 net ng hh) $ - Left $ "Rejected BIP-34 block: " ++ show hh - unless (validVersion net ng nv) $ - Left $ "Invalid block version: " ++ show nv - return BlockNode { nodeHeader = bh - , nodeHeight = ng - , nodeWork = aw - , nodeSkip = headerHash $ nodeHeader sk - } - --- | 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. -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 - => Int - -> BlockNode - -> m [BlockNode] -- ^ starts from immediate parent -getParents = getpars [] - where - getpars acc 0 _ = return $ reverse acc - getpars acc _ GenesisNode{} = return $ reverse acc - getpars acc n BlockNode{..} = do - parM <- getBlockHeader $ prevBlock nodeHeader - case parM of - Just bn -> getpars (bn : acc) (n - 1) bn - Nothing -> error "BUG: All non-genesis blocks should have a parent" - --- | Verify that checkpoint location is valid. -validCP :: Network - -> BlockHeight -- ^ new child height - -> BlockHash -- ^ new child hash - -> Bool -validCP net height newChildHash = - case lookup height (getCheckpoints net) of - Just cpHash -> cpHash == newChildHash - Nothing -> True - --- | New block height above the last checkpoint imported. Used to prevent a --- reorg below the highest checkpoint that was already imported. -afterLastCP :: Network - -> BlockHeight -- ^ best height - -> BlockHeight -- ^ new imported block height - -> Bool -afterLastCP net bestHeight newChildHeight = - case lM of - Just l -> l < newChildHeight - Nothing -> True - where - lM = - 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. -bip34 :: Network - -> BlockHeight -- ^ new child height - -> BlockHash -- ^ new child hash - -> Bool -bip34 net height hsh - | fst (getBip34Block net) == 0 = True - | fst (getBip34Block net) == height = snd (getBip34Block net) == hsh - | otherwise = True - --- | Check if the provided block height and version are valid. -validVersion :: Network - -> BlockHeight -- ^ new child height - -> Word32 -- ^ new child version - -> Bool -validVersion net height version - | version < 2 = height < fst (getBip34Block net) - | version < 3 = height < getBip66Height net - | version < 4 = height < getBip65Height net - | otherwise = True - --- | Find last block with normal, as opposed to minimum difficulty (for test --- networks). -lastNoMinDiff :: BlockHeaders m => Network -> BlockNode -> m BlockNode -lastNoMinDiff net bn@BlockNode {..} = do - let i = nodeHeight `mod` diffInterval net /= 0 - c = encodeCompact (getPowLimit net) - l = blockBits nodeHeader == c - e1 = - error $ - "Could not get block header for parent of " ++ - show (headerHash nodeHeader) - if i && l - then do - bn' <- fromMaybe e1 <$> getBlockHeader (prevBlock nodeHeader) - lastNoMinDiff net bn' - else return bn - -lastNoMinDiff _ bn@GenesisNode{} = 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 - let mf = daa <|> eda <|> pow - case mf of - Just f -> f net par bh - Nothing -> - error - "Could not get an appropriate difficulty calculation algorithm" - where - daa = getDaaBlockHeight net >>= \daaHeight -> do - guard (nodeHeight par + 1 >= daaHeight) - return nextDaaWorkRequired - eda = getEdaBlockHeight net >>= \edaHeight -> do - guard (nodeHeight par + 1 >= edaHeight) - return nextEdaWorkRequired - pow = return nextPowWorkRequired - --- | 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 - let height = nodeHeight par - 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 - e1 = error "Cannot get ancestor at parent - 144 height" - minDifficulty = - blockTimestamp bh > - blockTimestamp (nodeHeader par) + getTargetSpacing net * 2 - --- | 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. -nextPowWorkRequired :: - BlockHeaders m => Network -> BlockNode -> BlockHeader -> m Word32 -nextPowWorkRequired net par bh - | nodeHeight par + 1 `mod` diffInterval net /= 0 = - if getAllowMinDifficultyBlocks net - then if ht > pt + delta - then return $ encodeCompact (getPowLimit net) - else do - d <- lastNoMinDiff net par - return $ blockBits $ nodeHeader d - else return $ blockBits $ nodeHeader par - | otherwise = do - let rh = nodeHeight par - (diffInterval net - 1) - a <- fromMaybe e1 <$> getAncestor rh par - let t = blockTimestamp $ nodeHeader a - return $ calcNextWork net (nodeHeader par) t - where - e1 = error "Could not get ancestor for block header" - pt = blockTimestamp $ nodeHeader par - ht = blockTimestamp bh - delta = getTargetSpacing net * 2 - --- | Computes the work required for the first block in a new retarget period. -calcNextWork :: Network - -> BlockHeader -- ^ last block in previous retarget (parent) - -> Timestamp -- ^ timestamp of first block in previous retarget - -> Word32 -calcNextWork net header time - | getPowNoRetargetting net = blockBits header - | new > getPowLimit net = encodeCompact (getPowLimit net) - | otherwise = encodeCompact new - where - s = blockTimestamp header - time - n | s < getTargetTimespan net `div` 4 = getTargetTimespan net `div` 4 - | s > getTargetTimespan net * 4 = getTargetTimespan net * 4 - | otherwise = s - l = fst $ decodeCompact $ blockBits header - new = l * fromIntegral n `div` fromIntegral (getTargetTimespan net) - --- | Returns True if the difficulty target (bits) of the header is valid and the --- proof of work of the header matches the advertised difficulty target. This --- function corresponds to the function @CheckProofOfWork@ from @bitcoind@ in --- @main.cpp@. -isValidPOW :: Network -> BlockHeader -> Bool -isValidPOW net h - | target <= 0 || over || target > getPowLimit net = False - | otherwise = blockPOW (headerHash h) <= fromIntegral target - 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 . encode - --- | 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 | nodeWork b1 == nodeWork b2 = - if nodeHeight b1 >= nodeHeight b2 - then b1 - else b2 - | nodeWork b1 > nodeWork b2 = b1 - | otherwise = b2 - --- | Get list of blocks for a block locator. -blockLocatorNodes :: BlockHeaders m => BlockNode -> m [BlockNode] -blockLocatorNodes best = - reverse <$> go [] best 1 - where - e1 = error "Could not get ancestor" - go loc bn n = - let loc' = bn : loc - n' = if length loc' > 10 - then n * 2 - else 1 - in if nodeHeight bn < n' - then do a <- fromMaybe e1 <$> getAncestor 0 bn - return $ a : loc' - else do let h = nodeHeight bn - n' - bn' <- fromMaybe e1 <$> getAncestor h bn - go loc' bn' n' - --- | 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 = - head - [ j - | i <- (+ seed) <$> [0 .. maxBound] - , let j = h {bhNonce = i} - , isValidPOW net j - ] - --- | Generate and append new blocks (mining). Only practical in regtest network. -appendBlocks :: - Network - -> Word32 -- ^ random seed - -> BlockHeader - -> Int - -> [BlockHeader] -appendBlocks _ _ _ 0 = [] -appendBlocks net seed bh i = - bh' : appendBlocks net seed bh' (i - 1) - where - bh' = mineBlock net seed bh - { prevBlock = headerHash bh - -- Just to make it different in every header - , merkleRoot = sha256 $ encode seed - } - --- | Find the last common block ancestor between provided block headers. -splitPoint :: BlockHeaders m => BlockNode -> BlockNode -> m BlockNode -splitPoint l r = do - let h = min (nodeHeight l) (nodeHeight r) - ll <- fromMaybe e <$> getAncestor h l - lr <- fromMaybe e <$> getAncestor h r - f ll lr - where - e = error "BUG: Could not get ancestor at lowest height" - f ll lr = - if ll == lr - then return lr - else do - let h = nodeHeight ll - 1 - pl <- fromMaybe e <$> getAncestor h ll - pr <- fromMaybe e <$> getAncestor h lr - f pl pr - --- | 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 = - let halvings = height `div` getHalvingInterval net - ini = 50 * 100 * 1000 * 1000 - in if halvings >= 64 - then 0 - else ini `shiftR` fromIntegral halvings diff --git a/src/Network/Haskoin/Block/Merkle.hs b/src/Network/Haskoin/Block/Merkle.hs deleted file mode 100644 --- a/src/Network/Haskoin/Block/Merkle.hs +++ /dev/null @@ -1,256 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-| -Module : Network.Haskoin.Block.Merkle -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Function to deal with Merkle trees inside blocks. --} -module Network.Haskoin.Block.Merkle - ( MerkleBlock(..) - , MerkleRoot - , FlagBits - , PartialMerkleTree - , buildMerkleRoot - , merkleBlockTxs - , testMerkleRoot - -- * Helper functions - , buildPartialMerkle - , decodeMerkleFlags - , encodeMerkleFlags - , calcTreeHeight - , calcTreeWidth - , hash2 - , calcHash - , traverseAndBuild - , traverseAndExtract - , extractMatches - , splitIn - , boolsToWord8 - ) where - -import Control.DeepSeq -import Control.Monad (forM_, replicateM, when) -import Data.Bits -import qualified Data.ByteString as BS -import Data.Either (isRight) -import Data.Hashable -import Data.Maybe -import Data.Serialize (Serialize, encode, get, - put) -import Data.Serialize.Get (getWord32le, getWord8) -import Data.Serialize.Put (putWord32le, putWord8) -import Data.Word (Word32, Word8) -import GHC.Generics -import Network.Haskoin.Block.Common -import Network.Haskoin.Constants -import Network.Haskoin.Crypto.Hash -import Network.Haskoin.Network.Common -import Network.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. -data MerkleBlock = - MerkleBlock { - -- | block header - merkleHeader :: !BlockHeader - -- | total number of transactions in block - , merkleTotalTxns :: !Word32 - -- | hashes in depth-first order - , mHashes :: !PartialMerkleTree - -- | bits to rebuild partial merkle tree - , mFlags :: !FlagBits - } deriving (Eq, Show, Read, Generic, Hashable, NFData) - -instance Serialize MerkleBlock where - - get = do - header <- get - ntx <- getWord32le - (VarInt matchLen) <- get - hashes <- replicateM (fromIntegral matchLen) get - (VarInt flagLen) <- get - ws <- replicateM (fromIntegral flagLen) getWord8 - return $ MerkleBlock header ntx hashes (decodeMerkleFlags ws) - - put (MerkleBlock h ntx hashes flags) = do - put h - putWord32le ntx - putVarInt $ length hashes - forM_ hashes put - let ws = encodeMerkleFlags flags - putVarInt $ length ws - forM_ ws putWord8 - --- | 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 :: Int -- ^ number of transactions (leaf nodes) - -> Int -- ^ height of the merkle tree -calcTreeHeight ntx | ntx < 2 = 0 - | even ntx = 1 + calcTreeHeight (ntx `div` 2) - | otherwise = calcTreeHeight $ ntx + 1 - --- | Computes the width of a Merkle tree at a specific height. The transactions --- are at height 0. -calcTreeWidth :: Int -- ^ number of transactions (leaf nodes) - -> Int -- ^ height at which we want to compute the width - -> Int -- ^ width of the Merkle tree -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 :: [TxHash] -- ^ transaction hashes (leaf nodes) - -> MerkleRoot -- ^ root of the Merkle tree -buildMerkleRoot txs = calcHash (calcTreeHeight $ length txs) 0 txs - --- | Concatenate and compute double SHA256. -hash2 :: Hash256 -> Hash256 -> Hash256 -hash2 a b = doubleSHA256 $ encode a `BS.append` encode b - --- | Computes the hash of a specific node in a Merkle tree. -calcHash :: Int -- ^ height of the node - -> Int -- ^ position of the node (0 for the leftmost node) - -> [TxHash] -- ^ transaction hashes (leaf nodes) - -> Hash256 -- ^ hash of the node at the specified position -calcHash height pos txs - | height < 0 || pos < 0 = error "calcHash: Invalid parameters" - | height == 0 = getTxHash $ txs !! pos - | otherwise = hash2 left right - where - left = calcHash (height-1) (pos*2) txs - right | pos*2+1 < calcTreeWidth (length txs) (height-1) = - calcHash (height-1) (pos*2+1) txs - | otherwise = left - --- | 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 :: - [(TxHash, Bool)] -- ^ transaction hash and whether to include - -> (FlagBits, PartialMerkleTree) -- ^ flag bits and partial Merkle tree -buildPartialMerkle hs = traverseAndBuild (calcTreeHeight $ length hs) 0 hs - --- | Helper function to build partial Merkle tree. Used by 'buildPartialMerkle' --- above. -traverseAndBuild :: - Int -> Int -> [(TxHash, Bool)] -> (FlagBits, PartialMerkleTree) -traverseAndBuild height pos txs - | height < 0 || pos < 0 = error "traverseAndBuild: Invalid parameters" - | height == 0 || not match = ([match], [calcHash height pos t]) - | otherwise = (match : lb ++ rb, lh ++ rh) - where - t = map fst txs - s = pos `shiftL` height - e = min (length txs) $ (pos + 1) `shiftL` height - match = any snd $ take (e - s) $ drop s txs - (lb, lh) = traverseAndBuild (height - 1) (pos * 2) txs - (rb, rh) - | (pos * 2 + 1) < calcTreeWidth (length txs) (height - 1) = - traverseAndBuild (height - 1) (pos * 2 + 1) txs - | otherwise = ([], []) - --- | Helper function to extract transaction hashes from partial Merkle tree. -traverseAndExtract :: Int -> Int -> Int -> FlagBits -> PartialMerkleTree - -> Maybe (MerkleRoot, [TxHash], Int, Int) -traverseAndExtract height pos ntx flags hashes - | null flags = Nothing - | height == 0 || not match = leafResult - | isNothing leftM = Nothing - | (pos*2+1) >= calcTreeWidth ntx (height-1) = - Just (hash2 lh lh, lm, lcf+1, lch) - | isNothing rightM = Nothing - | otherwise = - Just (hash2 lh rh, lm ++ rm, lcf+rcf+1, lch+rch) - where - leafResult - | null hashes = Nothing - | otherwise = Just (h, [ TxHash h | height == 0 && match ], 1, 1) - (match:fs) = flags - (h:_) = hashes - leftM = traverseAndExtract (height-1) (pos*2) ntx fs hashes - (lh,lm,lcf,lch) = fromMaybe e leftM - rightM = traverseAndExtract (height-1) (pos*2+1) ntx - (drop lcf fs) (drop lch hashes) - (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'. -extractMatches :: Network - -> FlagBits - -> PartialMerkleTree - -> Int -- ^ number of transaction at height 0 (leaf nodes) - -> Either String (MerkleRoot, [TxHash]) - -- ^ Merkle root and list of matching transaction hashes -extractMatches net flags hashes ntx - | ntx == 0 = Left - "extractMatches: number of transactions can not be 0" - | ntx > getMaxBlockSize net `div` 60 = Left - "extractMatches: number of transactions excessively high" - | length hashes > ntx = Left - "extractMatches: More hashes provided than the number of transactions" - | length flags < length hashes = Left - "extractMatches: At least one bit per node and one bit per hash" - | isNothing resM = Left - "extractMatches: traverseAndExtract failed" - | (nBitsUsed+7) `div` 8 /= (length flags+7) `div` 8 = Left - "extractMatches: All bits were not consumed" - | nHashUsed /= length hashes = Left $ - "extractMatches: All hashes were not consumed: " ++ show nHashUsed - | otherwise = return (merkRoot, matches) - where - resM = traverseAndExtract (calcTreeHeight ntx) 0 ntx flags hashes - (merkRoot, matches, nBitsUsed, nHashUsed) = fromMaybe e resM - e = error "extractMatches: unexpected error extracting a Maybe value" - --- | Helper function to split a list in chunks 'Int' length. Last chunk may be --- smaller. -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 = - let flags = mFlags b - hs = mHashes b - n = fromIntegral $ merkleTotalTxns b - merkle = merkleRoot $ merkleHeader b - in do (root, ths) <- extractMatches net flags hs n - when (root /= merkle) $ Left "merkleBlockTxs: Merkle root incorrect" - return ths - --- | Check if Merkle block root is valid against the block header. -testMerkleRoot :: Network -> MerkleBlock -> Bool -testMerkleRoot net = isRight . merkleBlockTxs net diff --git a/src/Network/Haskoin/Constants.hs b/src/Network/Haskoin/Constants.hs deleted file mode 100644 --- a/src/Network/Haskoin/Constants.hs +++ /dev/null @@ -1,540 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-| -Module : Network.Haskoin.Constants -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Network constants for various networks, including Bitcoin SegWit (BTC), Bitcoin -Cash (BCH), and corresponding public test and private regression test networks. --} -module Network.Haskoin.Constants - ( Network(..) - , btc - , btcTest - , btcRegTest - , bch - , bchTest - , bchRegTest - , allNets - , netByName - , netByIdent - ) where - -import Control.DeepSeq -import Data.ByteString (ByteString) -import Data.List -import Data.Maybe -import Data.Serialize -import Data.String -import Data.Text (Text) -import Data.Version -import Data.Word (Word32, Word64, Word8) -import GHC.Generics (Generic) -import Network.Haskoin.Block.Common -import Paths_haskoin_core -import Text.Read - --- | Version of Haskoin Core package. -versionString :: IsString a => a -versionString = fromString (showVersion version) - --- | Constants for network. -data Network = Network - { -- | lowercase alphanumeric and dashes - getNetworkName :: !String - -- | network Haskell identifier - , getNetworkIdent :: !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) - -- | segregated witness active - , getSegWit :: !Bool - -- | 'CashAddr' prefix (for Bitcoin Cash) - , getCashAddrPrefix :: !(Maybe Text) - -- | 'Bech32' prefix (for SegWit network) - , getBech32Prefix :: !(Maybe Text) - -- | Replace-By-Fee (BIP-125) - , getReplaceByFee :: !Bool - -- | Subsidy halving interval - , getHalvingInterval :: !Word32 - } deriving (Eq, Generic, NFData) - -instance Serialize Network where - put net = - putWord32be $ getNetworkMagic net - get = do - magic <- getWord32be - case find ((== magic) . getNetworkMagic) allNets of - Nothing -> fail $ "Network magic unknown: " <> show magic - Just net -> return net - -instance Show Network where - show = getNetworkIdent - -instance Read Network where - readPrec = do - Ident str <- lexP - maybe pfail return (netByIdent str) - -instance IsString Network where - fromString = fromMaybe (error "Network name invalid") . netByName - --- | Query known networks by name. -netByName :: String -> Maybe Network -netByName str = find ((== str) . getNetworkName) allNets - --- | Query known networks by Haskell identifier. -netByIdent :: String -> Maybe Network -netByIdent str = find ((== str) . getNetworkIdent) allNets - --- | Bitcoin SegWit network. Symbol: BTC. -btc :: Network -btc = - Network - { getNetworkName = "btc" - , getNetworkIdent = "btc" - , getAddrPrefix = 0 - , getScriptPrefix = 5 - , getSecretPrefix = 128 - , getExtPubKeyPrefix = 0x0488b21e - , getExtSecretPrefix = 0x0488ade4 - , getNetworkMagic = 0xf9beb4d9 - , getGenesisHeader = - BlockHeader - 0x01 - "0000000000000000000000000000000000000000000000000000000000000000" - "3ba3edfd7a7b12b27ac72c3e67768f617fc81bc3888a51323a9fb8aa4b1e5e4a" - 1231006505 - 0x1d00ffff - 2083236893 - -- Hash 000000000019d6689c085ae165831e934ff763ae46a2a6c172b3f1b60a8ce26f - , getMaxBlockSize = 1000000 - , getMaxSatoshi = 2100000000000000 - , getHaskoinUserAgent = - "/haskoin-btc:" <> versionString <> "/" - , getDefaultPort = 8333 - , getAllowMinDifficultyBlocks = False - , getPowNoRetargetting = False - , getPowLimit = - 0x00000000ffffffffffffffffffffffffffffffffffffffffffffffffffffffff - , getBip34Block = - ( 227931 - , "000000000000024b89b42a942fe0d9fea3bb44ab7bd1b19115dd6a759c0808b8") - , getBip65Height = 388381 - , getBip66Height = 363725 - , getTargetTimespan = 14 * 24 * 60 * 60 - , getTargetSpacing = 10 * 60 - , getCheckpoints = - [ ( 11111 - , "0000000069e244f73d78e8fd29ba2fd2ed618bd6fa2ee92559f542fdb26e7c1d") - , ( 33333 - , "000000002dd5588a74784eaa7ab0507a18ad16a236e7b1ce69f00d7ddfb5d0a6") - , ( 74000 - , "0000000000573993a3c9e41ce34471c079dcf5f52a0e824a81e7f953b8661a20") - , ( 105000 - , "00000000000291ce28027faea320c8d2b054b2e0fe44a773f3eefb151d6bdc97") - , ( 134444 - , "00000000000005b12ffd4cd315cd34ffd4a594f430ac814c91184a0d42d2b0fe") - , ( 168000 - , "000000000000099e61ea72015e79632f216fe6cb33d7899acb35b75c8303b763") - , ( 193000 - , "000000000000059f452a5f7340de6682a977387c17010ff6e6c3bd83ca8b1317") - , ( 210000 - , "000000000000048b95347e83192f69cf0366076336c639f9b7228e9ba171342e") - , ( 216116 - , "00000000000001b4f4b433e81ee46494af945cf96014816a4e2370f11b23df4e") - , ( 225430 - , "00000000000001c108384350f74090433e7fcf79a606b8e797f065b130575932") - , ( 250000 - , "000000000000003887df1f29024b06fc2200b55f8af8f35453d7be294df2d214") - , ( 279000 - , "0000000000000001ae8c72a0b0c301f67e3afca10e819efa9041e458e9bd7e40") - , ( 295000 - , "00000000000000004d9b4ef50f0f9d686fd69db2e03af35a100370c64632a983") - ] - , getSeeds = - [ "seed.bitcoin.sipa.be" -- Pieter Wuille - , "dnsseed.bluematt.me" -- Matt Corallo - , "dnsseed.bitcoin.dashjr.org" -- Luke Dashjr - , "seed.bitcoinstats.com" -- Chris Decker - , "seed.bitcoin.jonasschnelli.ch" -- Jonas Schnelli - , "seed.btc.petertodd.org" -- Peter Todd - , "seed.bitcoin.sprovoost.nl" -- Sjors Provoost - ] - , getBip44Coin = 0 - , getSigHashForkId = Nothing - , getEdaBlockHeight = Nothing - , getDaaBlockHeight = Nothing - , getSegWit = True - , getCashAddrPrefix = Nothing - , getBech32Prefix = Just "bc" - , getReplaceByFee = True - , getHalvingInterval = 210000 - } - --- | Testnet for Bitcoin SegWit network. -btcTest :: Network -btcTest = - Network - { getNetworkName = "btctest" - , getNetworkIdent = "btcTest" - , getAddrPrefix = 111 - , getScriptPrefix = 196 - , getSecretPrefix = 239 - , getExtPubKeyPrefix = 0x043587cf - , getExtSecretPrefix = 0x04358394 - , getNetworkMagic = 0x0b110907 - , getGenesisHeader = - BlockHeader - 0x01 - "0000000000000000000000000000000000000000000000000000000000000000" - "3ba3edfd7a7b12b27ac72c3e67768f617fc81bc3888a51323a9fb8aa4b1e5e4a" - 1296688602 - 486604799 - 414098458 - -- Hash 000000000933ea01ad0ee984209779baaec3ced90fa3f408719526f8d77f4943 - , getMaxBlockSize = 1000000 - , getMaxSatoshi = 2100000000000000 - , getHaskoinUserAgent = "/haskoin-btc-test:" <> versionString <> "/" - , getDefaultPort = 18333 - , getAllowMinDifficultyBlocks = True - , getPowNoRetargetting = False - , getPowLimit = - 0x00000000ffffffffffffffffffffffffffffffffffffffffffffffffffffffff - , getBip34Block = - ( 21111 - , "0000000023b3a96d3484e5abb3755c413e7d41500f8e2a5c3f0dd01299cd8ef8") - , getBip65Height = 581885 - , getBip66Height = 330776 - , getTargetTimespan = 14 * 24 * 60 * 60 - , getTargetSpacing = 10 * 60 - , getCheckpoints = - [ ( 546 - , "000000002a936ca763904c3c35fce2f3556c559c0214345d31b1bcebf76acb70") - ] - , getSeeds = - [ "testnet-seed.bitcoin.jonasschnelli.ch" - , "seed.tbtc.petertodd.org" - , "seed.testnet.bitcoin.sprovoost.nl" - , "testnet-seed.bluematt.me" - ] - , getBip44Coin = 1 - , getSigHashForkId = Nothing - , getEdaBlockHeight = Nothing - , getDaaBlockHeight = Nothing - , getSegWit = True - , getCashAddrPrefix = Nothing - , getBech32Prefix = Just "tb" - , getReplaceByFee = True - , getHalvingInterval = 210000 - } - --- | RegTest for Bitcoin SegWit network. -btcRegTest :: Network -btcRegTest = - Network - { getNetworkName = "btcreg" - , getNetworkIdent = "btcRegTest" - , getAddrPrefix = 111 - , getScriptPrefix = 196 - , getSecretPrefix = 239 - , getExtPubKeyPrefix = 0x043587cf - , getExtSecretPrefix = 0x04358394 - , getNetworkMagic = 0xfabfb5da - , getGenesisHeader = - BlockHeader - -- 0f9188f13cb7b2c71f2a335e3a4fc328bf5beb436012afca590b1a11466e2206 - 0x01 - "0000000000000000000000000000000000000000000000000000000000000000" - "3ba3edfd7a7b12b27ac72c3e67768f617fc81bc3888a51323a9fb8aa4b1e5e4a" - 1296688602 - 0x207fffff - 2 - , getMaxBlockSize = 1000000 - , getMaxSatoshi = 2100000000000000 - , getHaskoinUserAgent = "/haskoin-btc-regtest:" <> versionString <> "/" - , getDefaultPort = 18444 - , getAllowMinDifficultyBlocks = True - , getPowNoRetargetting = True - , getPowLimit = - 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - , getBip34Block = - ( 100000000 - , "0000000000000000000000000000000000000000000000000000000000000000") - , getBip65Height = 1351 - , getBip66Height = 1251 - , getTargetTimespan = 14 * 24 * 60 * 60 - , getTargetSpacing = 10 * 60 - , getCheckpoints = [] - , getSeeds = ["localhost"] - , getBip44Coin = 1 - , getSigHashForkId = Nothing - , getEdaBlockHeight = Nothing - , getDaaBlockHeight = Nothing - , getSegWit = True - , getCashAddrPrefix = Nothing - , getBech32Prefix = Just "bcrt" - , getReplaceByFee = True - , getHalvingInterval = 150 - } - --- | Bitcoin Cash network. Symbol: BCH. -bch :: Network -bch = - Network - { getNetworkName = "bch" - , getNetworkIdent = "bch" - , getAddrPrefix = 0 - , getScriptPrefix = 5 - , getSecretPrefix = 128 - , getExtPubKeyPrefix = 0x0488b21e - , getExtSecretPrefix = 0x0488ade4 - , getNetworkMagic = 0xe3e1f3e8 - , getGenesisHeader = - BlockHeader - 0x01 - "0000000000000000000000000000000000000000000000000000000000000000" - "3ba3edfd7a7b12b27ac72c3e67768f617fc81bc3888a51323a9fb8aa4b1e5e4a" - 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-abc.bitcoinforks.org" - , "btccash-seeder.bitcoinunlimited.info" - , "seed.bitprim.org" - , "seed.deadalnix.me" - , "seeder.criptolayer.net" - ] - , getBip44Coin = 145 - , getSigHashForkId = Just 0 - , getEdaBlockHeight = Just 478559 - , getDaaBlockHeight = Just 404031 - , getSegWit = False - , getCashAddrPrefix = Just "bitcoincash" - , getBech32Prefix = Nothing - , getReplaceByFee = False - , getHalvingInterval = 210000 - } - --- | Testnet for Bitcoin Cash network. -bchTest :: Network -bchTest = - Network - { getNetworkName = "bchtest" - , getNetworkIdent = "bchTest" - , getAddrPrefix = 111 - , getScriptPrefix = 196 - , getSecretPrefix = 239 - , getExtPubKeyPrefix = 0x043587cf - , getExtSecretPrefix = 0x04358394 - , getNetworkMagic = 0xf4e5f3f4 - , getGenesisHeader = - BlockHeader - 0x01 - "0000000000000000000000000000000000000000000000000000000000000000" - "3ba3edfd7a7b12b27ac72c3e67768f617fc81bc3888a51323a9fb8aa4b1e5e4a" - 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-abc.bitcoinforks.org" - , "testnet-seed.bitprim.org" - , "testnet-seed.deadalnix.me" - , "testnet-seeder.criptolayer.net" - ] - , getBip44Coin = 1 - , getSigHashForkId = Just 0 - , getEdaBlockHeight = Just 1155876 - , getDaaBlockHeight = Just 1188697 - , getSegWit = False - , getCashAddrPrefix = Just "bchtest" - , getBech32Prefix = Nothing - , getReplaceByFee = False - , getHalvingInterval = 210000 - } - --- | RegTest for Bitcoin Cash network. -bchRegTest :: Network -bchRegTest = - Network - { getNetworkName = "bchreg" - , getNetworkIdent = "bchRegTest" - , getAddrPrefix = 111 - , getScriptPrefix = 196 - , getSecretPrefix = 239 - , getExtPubKeyPrefix = 0x043587cf - , getExtSecretPrefix = 0x04358394 - , getNetworkMagic = 0xdab5bffa - , getGenesisHeader = - BlockHeader - -- 0f9188f13cb7b2c71f2a335e3a4fc328bf5beb436012afca590b1a11466e2206 - 0x01 - "0000000000000000000000000000000000000000000000000000000000000000" - "3ba3edfd7a7b12b27ac72c3e67768f617fc81bc3888a51323a9fb8aa4b1e5e4a" - 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 - , 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, bchTest, btcRegTest, bchRegTest] diff --git a/src/Network/Haskoin/Crypto.hs b/src/Network/Haskoin/Crypto.hs deleted file mode 100644 --- a/src/Network/Haskoin/Crypto.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-| -Module : Network.Haskoin.Crypto -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Hashing functions and ECDSA signatures. --} -module Network.Haskoin.Crypto - ( -- * Hashes - module Hash - -- * Signatures - , module Signature - -- * Secp256k1 (re-exported) - , module Secp256k1 - ) where - -import Crypto.Secp256k1 as Secp256k1 -import Network.Haskoin.Crypto.Hash as Hash -import Network.Haskoin.Crypto.Signature as Signature diff --git a/src/Network/Haskoin/Crypto/Hash.hs b/src/Network/Haskoin/Crypto/Hash.hs deleted file mode 100644 --- a/src/Network/Haskoin/Crypto/Hash.hs +++ /dev/null @@ -1,202 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-| -Module : Network.Haskoin.Crypto.Hash -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Hashing functions and corresponding data types. Uses functions from the -cryptonite library. --} -module Network.Haskoin.Crypto.Hash - ( -- * Hashes - Hash512(getHash512) - , Hash256(getHash256) - , Hash160(getHash160) - , CheckSum32(getCheckSum32) - , sha512 - , sha256 - , ripemd160 - , sha1 - , doubleSHA256 - , addressHash - , checkSum32 - , hmac512 - , hmac256 - , split512 - , join512 - ) where - -import Control.DeepSeq -import Crypto.Hash (RIPEMD160 (..), SHA1 (..), - SHA256 (..), SHA512 (..), hashWith) -import Crypto.MAC.HMAC (HMAC, hmac) -import Data.ByteArray (ByteArrayAccess) -import qualified Data.ByteArray as BA -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.ByteString.Short (ShortByteString) -import qualified Data.ByteString.Short as BSS -import Data.Either (fromRight) -import Data.Hashable (Hashable) -import Data.Serialize (Serialize (..), decode) -import qualified Data.Serialize.Get as Get -import qualified Data.Serialize.Put as Put -import Data.String (IsString, fromString) -import Data.String.Conversions (cs) -import Data.Word (Word32) -import GHC.Generics (Generic) -import Network.Haskoin.Util -import Text.Read as R - --- | 'Word32' wrapped for type-safe 32-bit checksums. -newtype CheckSum32 = CheckSum32 - { getCheckSum32 :: Word32 - } deriving (Eq, Ord, Serialize, Show, Read, Hashable, Generic, NFData) - --- | 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 - Nothing -> e - Just bs -> - case BS.length bs of - 64 -> Hash512 (BSS.toShort bs) - _ -> e - where - e = error "Could not decode hash from hex string" - -instance Serialize Hash512 where - get = Hash512 <$> Get.getShortByteString 64 - put = Put.putShortByteString . getHash512 - -instance IsString Hash256 where - fromString str = - case decodeHex $ cs str of - Nothing -> e - Just bs -> - case BS.length bs of - 32 -> Hash256 (BSS.toShort bs) - _ -> e - where - e = error "Could not decode hash from hex string" - -instance Serialize Hash256 where - get = Hash256 <$> Get.getShortByteString 32 - put = Put.putShortByteString . getHash256 - -instance IsString Hash160 where - fromString str = - case decodeHex $ cs str of - Nothing -> e - Just bs -> - case BS.length bs of - 20 -> Hash160 (BSS.toShort bs) - _ -> e - where - e = error "Could not decode hash from hex string" - -instance Serialize Hash160 where - get = Hash160 <$> Get.getShortByteString 20 - put = Put.putShortByteString . getHash160 - --- | 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. -checkSum32 :: ByteArrayAccess b => b -> CheckSum32 -checkSum32 = fromRight (error "Could not decode bytes as CheckSum32") - . decode - . BS.take 4 - . BA.convert - . hashWith SHA256 - . hashWith SHA256 - -{- HMAC -} - --- | Computes HMAC over SHA-512. -hmac512 :: ByteString -> ByteString -> Hash512 -hmac512 key msg = - Hash512 $ BSS.toShort $ BA.convert (hmac key msg :: HMAC SHA512) - --- | 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 = - (Hash256 (BSS.toShort a), Hash256 (BSS.toShort b)) - 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) = - Hash512 . - BSS.toShort $ - BSS.fromShort (getHash256 a) `BS.append` BSS.fromShort (getHash256 b) diff --git a/src/Network/Haskoin/Crypto/Signature.hs b/src/Network/Haskoin/Crypto/Signature.hs deleted file mode 100644 --- a/src/Network/Haskoin/Crypto/Signature.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-| -Module : Network.Haskoin.Crypto.Signature -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -ECDSA signatures using secp256k1 curve. Uses functions from upstream secp256k1 -library. --} -module Network.Haskoin.Crypto.Signature - ( putSig - , getSig - , signHash - , verifyHashSig - , isCanonicalHalfOrder - , decodeStrictSig - , exportSig - ) where - -import Control.Monad (guard, unless, when) -import Crypto.Secp256k1 -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.ByteString.Short (toShort) -import Data.Maybe (fromMaybe) -import Data.Serialize as S -import Data.Serialize.Put (Putter, putByteString) -import Network.Haskoin.Crypto.Hash -import Numeric (showHex) - --- | Convert 256-bit hash into a 'Msg' for signing or verification. -hashToMsg :: Hash256 -> Msg -hashToMsg = - fromMaybe e . msg . encode - 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 g m - where - (g, _) = normalizeSig s - m = hashToMsg h - --- | Deserialize an ECDSA signature as commonly encoded in Bitcoin. -getSig :: Get Sig -getSig = do - l <- lookAhead $ do - t <- getWord8 - -- 0x30 is DER sequence type - unless (t == 0x30) $ fail $ - "Bad DER identifier byte 0x" ++ showHex t ". Expecting 0x30" - l <- getWord8 - when (l == 0x00) $ fail "Indeterminate form unsupported" - when (l >= 0x80) $ fail "Multi-octect length not supported" - return $ fromIntegral l - bs <- getByteString $ l + 2 - case decodeStrictSig bs of - Just s -> return s - Nothing -> fail "Invalid signature" - --- | Serialize an ECDSA signature for Bitcoin use. -putSig :: Putter Sig -putSig s = putByteString $ exportSig s - --- | Is canonical half order. -isCanonicalHalfOrder :: Sig -> Bool -isCanonicalHalfOrder = not . snd . normalizeSig - --- | Decode signature strictly. -decodeStrictSig :: ByteString -> Maybe Sig -decodeStrictSig bs = do - g <- importSig bs - let compact = exportCompactSig g - -- - -- 4.1.4.1 (r and s can not be zero) - guard $ getCompactSigR compact /= zero - guard $ getCompactSigS compact /= zero - guard $ isCanonicalHalfOrder g - return g - where - zero = toShort $ BS.replicate 32 0 diff --git a/src/Network/Haskoin/Keys.hs b/src/Network/Haskoin/Keys.hs deleted file mode 100644 --- a/src/Network/Haskoin/Keys.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-| -Module : Network.Haskoin.Keys -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -ECDSA private and public keys, extended keys (BIP-32) and mnemonic sentences -(BIP-39). --} -module Network.Haskoin.Keys - ( module Network.Haskoin.Keys.Common - -- * Extended Keys - , module Network.Haskoin.Keys.Extended - -- * Mnemonic - , module Network.Haskoin.Keys.Mnemonic - ) where - -import Network.Haskoin.Keys.Common -import Network.Haskoin.Keys.Extended -import Network.Haskoin.Keys.Mnemonic diff --git a/src/Network/Haskoin/Keys/Common.hs b/src/Network/Haskoin/Keys/Common.hs deleted file mode 100644 --- a/src/Network/Haskoin/Keys/Common.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-| -Module : Network.Haskoin.Keys.Common -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -ECDSA private and public key functions. --} -module Network.Haskoin.Keys.Common - ( -- * Public & Private Keys - PubKeyI(..) - , SecKeyI(..) - , exportPubKey - , importPubKey - , wrapPubKey - , derivePubKeyI - , wrapSecKey - , fromMiniKey - , tweakPubKey - , tweakSecKey - , secKeyPut - , secKeyGet - , getSecKey - , secKey - ) where - -import Control.Applicative ((<|>)) -import Control.DeepSeq -import Control.Monad (guard, mzero, (<=<)) -import Crypto.Secp256k1 -import Data.Aeson (FromJSON, ToJSON (..), - Value (String), parseJSON, - withText) -import Data.Aeson.Encoding (unsafeToEncoding) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.ByteString.Builder (char7) -import Data.Hashable -import Data.Maybe (fromMaybe) -import Data.Serialize (Serialize, decode, encode, get, - put) -import Data.Serialize.Get (Get, getByteString) -import Data.Serialize.Put (Putter, putByteString) -import Data.String (IsString, fromString) -import Data.String.Conversions (cs) -import GHC.Generics (Generic) -import Network.Haskoin.Crypto.Hash -import Network.Haskoin.Util - --- | Elliptic curve public key type with expected serialized compression flag. -data PubKeyI = PubKeyI - { pubKeyPoint :: !PubKey - , pubKeyCompressed :: !Bool - } deriving (Generic, Eq, Show, Read, Hashable, NFData) - -instance IsString PubKeyI where - fromString str = - fromMaybe e $ eitherToMaybe . decode <=< decodeHex $ cs str - where - e = error "Could not decode public key" - -instance ToJSON PubKeyI where - toJSON = String . encodeHex . encode - toEncoding s = unsafeToEncoding $ char7 '"' <> hexBuilder (encode s) <> char7 '"' - -instance FromJSON PubKeyI where - parseJSON = withText "PubKeyI" $ - maybe mzero return . (eitherToMaybe . decode =<<) . decodeHex - -instance Serialize PubKeyI where - get = c <|> u - where - c = do - bs <- getByteString 33 - guard $ BS.head bs `BS.elem` BS.pack [0x02, 0x03] - maybe mzero return $ PubKeyI <$> importPubKey bs <*> pure True - u = do - bs <- getByteString 65 - guard $ BS.head bs == 0x04 - maybe mzero return $ PubKeyI <$> importPubKey bs <*> pure False - - put pk = putByteString $ exportPubKey (pubKeyCompressed pk) (pubKeyPoint pk) - --- | Wrap a public key from secp256k1 library adding information about compression. -wrapPubKey :: Bool -> PubKey -> PubKeyI -wrapPubKey c p = PubKeyI p c - --- | Derives a public key from a private key. This function will preserve --- compression flag. -derivePubKeyI :: SecKeyI -> PubKeyI -derivePubKeyI (SecKeyI d c) = PubKeyI (derivePubKey d) c - --- | Tweak a public key. -tweakPubKey :: PubKey -> Hash256 -> Maybe PubKey -tweakPubKey p h = tweakAddPubKey p =<< tweak (encode h) - --- | Elliptic curve private key type with expected public key compression --- information. Compression information is stored in private key WIF formats and --- needs to be preserved to generate the correct address from the corresponding --- public key. -data SecKeyI = SecKeyI - { secKeyData :: !SecKey - , secKeyCompressed :: !Bool - } deriving (Eq, Show, Read, Generic, NFData) - --- | Wrap private key with corresponding public key compression flag. -wrapSecKey :: Bool -> SecKey -> SecKeyI -wrapSecKey c d = SecKeyI d c - --- | Deserialize 'SecKey'. -secKeyGet :: Get SecKey -secKeyGet = do - bs <- getByteString 32 - maybe (fail "invalid private key") return (secKey bs) - --- | Serialize 'SecKey'. -secKeyPut :: Putter SecKey -secKeyPut = putByteString . getSecKey - --- | Decode Casascius mini private keys (22 or 30 characters). -fromMiniKey :: ByteString -> Maybe SecKeyI -fromMiniKey bs = do - guard checkShortKey - wrapSecKey False <$> secKey (encode (sha256 bs)) - where - checkHash = encode $ sha256 $ bs `BS.append` "?" - checkShortKey = BS.length bs `elem` [22, 30] && BS.head checkHash == 0x00 - --- | Tweak a private key. -tweakSecKey :: SecKey -> Hash256 -> Maybe SecKey -tweakSecKey key h = tweakAddSecKey key =<< tweak (encode h) diff --git a/src/Network/Haskoin/Keys/Extended.hs b/src/Network/Haskoin/Keys/Extended.hs deleted file mode 100644 --- a/src/Network/Haskoin/Keys/Extended.hs +++ /dev/null @@ -1,920 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-| -Module : Network.Haskoin.Keys.Extended -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -BIP-32 extended keys. --} -module Network.Haskoin.Keys.Extended - ( - -- * Extended Keys - XPubKey(..) - , XPrvKey(..) - , ChainCode - , KeyIndex - , Fingerprint - , DerivationException(..) - , makeXPrvKey - , deriveXPubKey - , prvSubKey - , pubSubKey - , hardSubKey - , xPrvIsHard - , xPubIsHard - , xPrvChild - , xPubChild - , xPubID - , xPrvID - , xPubFP - , xPrvFP - , xPubAddr - , xPubWitnessAddr - , xPubCompatWitnessAddr - , xPubExport - , xPubToJSON - , xPubToEncoding - , xPubFromJSON - , xPrvExport - , xPrvToJSON - , xPrvToEncoding - , xPrvFromJSON - , xPubImport - , xPrvImport - , xPrvWif - , putXPrvKey - , putXPubKey - , getXPrvKey - , getXPubKey - - -- ** Helper Functions - , prvSubKeys - , pubSubKeys - , hardSubKeys - , deriveAddr - , deriveWitnessAddr - , deriveCompatWitnessAddr - , deriveAddrs - , deriveWitnessAddrs - , deriveCompatWitnessAddrs - , deriveMSAddr - , deriveMSAddrs - , cycleIndex - - -- ** Derivation Paths - , DerivPathI(..) - , AnyDeriv, HardDeriv, SoftDeriv - , HardOrAny - , AnyOrSoft - , DerivPath - , HardPath - , SoftPath - , Bip32PathIndex (..) - , derivePath - , derivePubPath - , toHard - , toSoft - , toGeneric - , (++/) - , pathToStr - , listToPath - , pathToList - - -- *** Derivation Path Parser - , XKey(..) - , ParsedPath(..) - , parsePath - , parseHard - , parseSoft - , applyPath - , derivePathAddr - , derivePathAddrs - , derivePathMSAddr - , derivePathMSAddrs - , concatBip32Segments - ) where - -import Control.Applicative -import Control.DeepSeq -import Control.Exception (Exception, throw) -import Control.Monad (guard, mzero, unless, (<=<)) -import Crypto.Secp256k1 -import Data.Aeson as A (FromJSON, ToJSON (..), - Value (String), parseJSON, - toJSON, withText) -import Data.Aeson.Encoding (Encoding, text) -import Data.Aeson.Types (Parser) -import Data.Bits (clearBit, setBit, testBit) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Either (fromRight) -import Data.List (foldl') -import Data.List.Split (splitOn) -import Data.Maybe (fromMaybe) -import Data.Serialize as S (Serialize, decode, encode, - get, put) -import Data.Serialize.Get (Get, getWord32be, getWord8, - runGet) -import Data.Serialize.Put (Putter, putWord32be, putWord8, - runPut) -import Data.String (IsString, fromString) -import Data.String.Conversions (cs) -import Data.Typeable (Typeable) -import Data.Word (Word32, Word8) -import GHC.Generics (Generic) -import Network.Haskoin.Address -import Network.Haskoin.Constants -import Network.Haskoin.Crypto.Hash -import Network.Haskoin.Keys.Common -import Network.Haskoin.Script -import Network.Haskoin.Util -import Text.Read as R -import Text.Read.Lex - - --- | A derivation exception is thrown in the very unlikely event that a --- derivation is invalid. -newtype DerivationException = DerivationException String - deriving (Eq, Read, Show, Typeable, Generic, NFData) - -instance Exception DerivationException - --- | Chain code as specified in BIP-32. -type ChainCode = Hash256 - --- | Index of key as specified in BIP-32. -type KeyIndex = Word32 - --- | Fingerprint of parent -type Fingerprint = Word32 - --- | Data type representing an extended BIP32 private key. An extended key --- is a node in a tree of key derivations. It has a depth in the tree, a --- parent node and an index to differentiate it from other siblings. -data XPrvKey = XPrvKey - { xPrvDepth :: !Word8 -- ^ depth in the tree - , xPrvParent :: !Fingerprint -- ^ fingerprint of parent - , xPrvIndex :: !KeyIndex -- ^ derivation index - , xPrvChain :: !ChainCode -- ^ chain code - , xPrvKey :: !SecKey -- ^ private key of this node - } deriving (Generic, Eq, Show, Read, NFData) - -xPrvToJSON :: Network -> XPrvKey -> Value -xPrvToJSON net = A.String . xPrvExport net - -xPrvToEncoding :: Network -> XPrvKey -> Encoding -xPrvToEncoding net = text . xPrvExport net - --- | Data type representing an extended BIP32 public key. -data XPubKey = XPubKey - { xPubDepth :: !Word8 -- ^ depth in the tree - , xPubParent :: !Fingerprint -- ^ fingerprint of parent - , xPubIndex :: !KeyIndex -- ^ derivation index - , xPubChain :: !ChainCode -- ^ chain code - , xPubKey :: !PubKey -- ^ public key of this node - } deriving (Generic, Eq, Show, Read, NFData) - - --- | Decode an extended public key from a JSON string -xPubFromJSON :: Network -> Value -> Parser XPubKey -xPubFromJSON net = - withText "xpub" $ \t -> - case xPubImport net t of - Nothing -> fail "could not read xpub" - Just x -> return x - --- | Get JSON 'Value' from 'XPubKey'. -xPubToJSON :: Network -> XPubKey -> Value -xPubToJSON net = A.String . xPubExport net - -xPubToEncoding :: Network -> XPubKey -> Encoding -xPubToEncoding net = text . xPubExport net - --- | Decode an extended private key from a JSON string -xPrvFromJSON :: Network -> Value -> Parser XPrvKey -xPrvFromJSON net = - withText "xprv" $ \t -> - case xPrvImport net t of - Nothing -> fail "could not read xprv" - Just x -> return x - --- | 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 0 0 c k - where - (p, c) = split512 $ hmac512 "Bitcoin seed" bs - k = fromMaybe err (secKey (encode p)) - err = throw $ DerivationException "Invalid seed" - --- | Derive an extended public key from an extended private key. This function --- will preserve the depth, parent, index and chaincode fields of the extended --- private keys. -deriveXPubKey :: XPrvKey -> XPubKey -deriveXPubKey (XPrvKey d p i c k) = XPubKey d p i c (derivePubKey k) - --- | Compute a private, soft child key derivation. A private soft derivation --- will allow the equivalent extended public key to derive the public key for --- this child. Given a parent key /m/ and a derivation index /i/, this function --- will compute /m\/i/. --- --- Soft derivations allow for more flexibility such as read-only wallets. --- However, care must be taken not the leak both the parent extended public key --- and one of the extended child private keys as this would compromise the --- extended parent private key. -prvSubKey :: XPrvKey -- ^ extended parent private key - -> KeyIndex -- ^ child derivation index - -> XPrvKey -- ^ extended child private key -prvSubKey xkey child - | child >= 0 && child < 0x80000000 = - XPrvKey (xPrvDepth xkey + 1) (xPrvFP xkey) child c k - | otherwise = error "Invalid child derivation index" - where - pK = xPubKey $ deriveXPubKey xkey - m = B.append (exportPubKey True pK) (encode child) - (a, c) = split512 $ hmac512 (encode $ xPrvChain xkey) m - k = fromMaybe err $ tweakSecKey (xPrvKey xkey) a - err = throw $ DerivationException "Invalid prvSubKey derivation" - --- | Compute a public, soft child key derivation. Given a parent key /M/ --- and a derivation index /i/, this function will compute /M\/i/. -pubSubKey :: XPubKey -- ^ extended parent public key - -> KeyIndex -- ^ child derivation index - -> XPubKey -- ^ extended child public key -pubSubKey xKey child - | child >= 0 && child < 0x80000000 = - XPubKey (xPubDepth xKey + 1) (xPubFP xKey) child c pK - | otherwise = error "Invalid child derivation index" - where - m = B.append (exportPubKey True (xPubKey xKey)) (encode child) - (a, c) = split512 $ hmac512 (encode $ xPubChain xKey) m - pK = fromMaybe err $ tweakPubKey (xPubKey xKey) a - err = throw $ DerivationException "Invalid pubSubKey derivation" - --- | Compute a hard child key derivation. Hard derivations can only be computed --- for private keys. Hard derivations do not allow the parent public key to --- derive the child public keys. However, they are safer as a breach of the --- parent public key and child private keys does not lead to a breach of the --- parent private key. Given a parent key /m/ and a derivation index /i/, this --- function will compute /m\/i'/. -hardSubKey :: XPrvKey -- ^ extended parent private key - -> KeyIndex -- ^ child derivation index - -> XPrvKey -- ^ extended child private key -hardSubKey xkey child - | child >= 0 && child < 0x80000000 = - XPrvKey (xPrvDepth xkey + 1) (xPrvFP xkey) i c k - | otherwise = error "Invalid child derivation index" - where - i = setBit child 31 - m = B.append (bsPadPrvKey $ xPrvKey xkey) (encode i) - (a, c) = split512 $ hmac512 (encode $ xPrvChain xkey) m - k = fromMaybe err $ tweakSecKey (xPrvKey xkey) a - err = throw $ DerivationException "Invalid hardSubKey derivation" - --- | Returns true if the extended private key was derived through a hard --- derivation. -xPrvIsHard :: XPrvKey -> Bool -xPrvIsHard k = testBit (xPrvIndex k) 31 - --- | Returns true if the extended public key was derived through a hard --- derivation. -xPubIsHard :: XPubKey -> Bool -xPubIsHard k = testBit (xPubIndex k) 31 - --- | Returns the derivation index of this extended private key without the hard --- bit set. -xPrvChild :: XPrvKey -> KeyIndex -xPrvChild k = clearBit (xPrvIndex k) 31 - --- | Returns the derivation index of this extended public key without the hard --- bit set. -xPubChild :: XPubKey -> KeyIndex -xPubChild k = clearBit (xPubIndex k) 31 - --- | Computes the key identifier of an extended private key. -xPrvID :: XPrvKey -> Hash160 -xPrvID = xPubID . deriveXPubKey - --- | Computes the key identifier of an extended public key. -xPubID :: XPubKey -> Hash160 -xPubID = ripemd160 . encode . sha256 . exportPubKey True . xPubKey - --- | Computes the key fingerprint of an extended private key. -xPrvFP :: XPrvKey -> Fingerprint -xPrvFP = - fromRight err . decode . B.take 4 . encode . xPrvID - where - err = error "Could not decode xPrvFP" - --- | Computes the key fingerprint of an extended public key. -xPubFP :: XPubKey -> Fingerprint -xPubFP = - fromRight err . decode . B.take 4 . encode . xPubID - where - err = error "Could not decode xPubFP" - --- | Compute a standard P2PKH address for an extended public key. -xPubAddr :: XPubKey -> Address -xPubAddr xkey = pubKeyAddr (wrapPubKey True (xPubKey xkey)) - --- | Compute a SegWit P2WPKH address for an extended public key. -xPubWitnessAddr :: XPubKey -> Address -xPubWitnessAddr xkey = pubKeyWitnessAddr (wrapPubKey True (xPubKey xkey)) - --- | Compute a backwards-compatible SegWit P2SH-P2WPKH address for an extended --- public key. -xPubCompatWitnessAddr :: XPubKey -> Address -xPubCompatWitnessAddr xkey = - pubKeyCompatWitnessAddr (wrapPubKey True (xPubKey xkey)) - --- | Exports an extended private key to the BIP32 key export format ('Base58'). -xPrvExport :: Network -> XPrvKey -> Base58 -xPrvExport net = encodeBase58Check . runPut . putXPrvKey net - --- | Exports an extended public key to the BIP32 key export format ('Base58'). -xPubExport :: Network -> XPubKey -> Base58 -xPubExport net = encodeBase58Check . runPut . putXPubKey net - --- | Decodes a BIP32 encoded extended private key. This function will fail if --- invalid base 58 characters are detected or if the checksum fails. -xPrvImport :: Network -> Base58 -> Maybe XPrvKey -xPrvImport net = eitherToMaybe . runGet (getXPrvKey net) <=< decodeBase58Check - --- | Decodes a BIP32 encoded extended public key. This function will fail if --- invalid base 58 characters are detected or if the checksum fails. -xPubImport :: Network -> Base58 -> Maybe XPubKey -xPubImport net = eitherToMaybe . runGet (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 :: Network -> Get XPrvKey -getXPrvKey net = do - ver <- getWord32be - unless (ver == getExtSecretPrefix net) $ fail - "Get: Invalid version for extended private key" - XPrvKey <$> getWord8 - <*> getWord32be - <*> getWord32be - <*> S.get - <*> getPadPrvKey - --- | Serialize an extended private key. -putXPrvKey :: Network -> Putter XPrvKey -putXPrvKey net k = do - putWord32be $ getExtSecretPrefix net - putWord8 $ xPrvDepth k - putWord32be $ xPrvParent k - putWord32be $ xPrvIndex k - put $ xPrvChain k - putPadPrvKey $ xPrvKey k - --- | Parse a binary extended public key. -getXPubKey :: Network -> Get XPubKey -getXPubKey net = do - ver <- getWord32be - unless (ver == getExtPubKeyPrefix net) $ fail - "Get: Invalid version for extended public key" - XPubKey <$> getWord8 - <*> getWord32be - <*> getWord32be - <*> S.get - <*> (pubKeyPoint <$> S.get) - --- | Serialize an extended public key. -putXPubKey :: Network -> Putter XPubKey -putXPubKey net k = do - putWord32be $ getExtPubKeyPrefix net - putWord8 $ xPubDepth k - putWord32be $ xPubParent k - putWord32be $ xPubIndex k - put $ xPubChain k - put $ wrapPubKey True (xPubKey k) - -{- Derivation helpers -} - --- | Cyclic list of all private soft child key derivations of a parent key --- starting from an offset index. -prvSubKeys :: XPrvKey -> KeyIndex -> [(XPrvKey, KeyIndex)] -prvSubKeys k = map (\i -> (prvSubKey k i, i)) . cycleIndex - --- | Cyclic list of all public soft child key derivations of a parent key --- starting from an offset index. -pubSubKeys :: XPubKey -> KeyIndex -> [(XPubKey, KeyIndex)] -pubSubKeys k = map (\i -> (pubSubKey k i, i)) . cycleIndex - --- | Cyclic list of all hard child key derivations of a parent key starting --- from an offset index. -hardSubKeys :: XPrvKey -> KeyIndex -> [(XPrvKey, KeyIndex)] -hardSubKeys k = map (\i -> (hardSubKey k i, i)) . cycleIndex - --- | Derive a standard address from an extended public key and an index. -deriveAddr :: XPubKey -> KeyIndex -> (Address, PubKey) -deriveAddr k i = - (xPubAddr key, xPubKey key) - where - key = pubSubKey k i - --- | Derive a SegWit P2WPKH address from an extended public key and an index. -deriveWitnessAddr :: XPubKey -> KeyIndex -> (Address, PubKey) -deriveWitnessAddr k i = - (xPubWitnessAddr key, xPubKey key) - where - key = pubSubKey k i - --- | Derive a backwards-compatible SegWit P2SH-P2WPKH address from an extended --- public key and an index. -deriveCompatWitnessAddr :: XPubKey -> KeyIndex -> (Address, PubKey) -deriveCompatWitnessAddr k i = - (xPubCompatWitnessAddr key, xPubKey key) - where - key = pubSubKey k i - --- | Cyclic list of all addresses derived from a public key starting from an --- offset index. -deriveAddrs :: XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)] -deriveAddrs k = - map f . cycleIndex - where - f i = let (a, key) = deriveAddr k i in (a, key, i) - --- | Cyclic list of all SegWit P2WPKH addresses derived from a public key --- starting from an offset index. -deriveWitnessAddrs :: XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)] -deriveWitnessAddrs k = - map f . cycleIndex - where - f i = let (a, key) = deriveWitnessAddr k i in (a, key, i) - --- | Cyclic list of all backwards-compatible SegWit P2SH-P2WPKH addresses --- derived from a public key starting from an offset index. -deriveCompatWitnessAddrs :: XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)] -deriveCompatWitnessAddrs k = - map f . cycleIndex - where - f i = let (a, key) = deriveCompatWitnessAddr k i in (a, key, i) - --- | Derive a multisig address from a list of public keys, the number of --- required signatures /m/ and a derivation index. The derivation type is a --- public, soft derivation. -deriveMSAddr :: [XPubKey] -> Int -> KeyIndex -> (Address, RedeemScript) -deriveMSAddr keys m i = (payToScriptAddress rdm, rdm) - where - rdm = sortMulSig $ PayMulSig k m - k = map (wrapPubKey True . xPubKey . flip pubSubKey i) keys - --- | Cyclic list of all multisig addresses derived from a list of public keys, --- a number of required signatures /m/ and starting from an offset index. The --- derivation type is a public, soft derivation. -deriveMSAddrs :: [XPubKey] -> Int -> KeyIndex - -> [(Address, RedeemScript, KeyIndex)] -deriveMSAddrs keys m = map f . cycleIndex - where - f i = - let (a, rdm) = deriveMSAddr keys m i - in (a, rdm, i) - --- | Helper function to go through derivation indices. -cycleIndex :: KeyIndex -> [KeyIndex] -cycleIndex i - | i == 0 = cycle [0..0x7fffffff] - | i < 0x80000000 = cycle $ [i..0x7fffffff] ++ [0..(i-1)] - | otherwise = error $ "cycleIndex: invalid index " ++ show i - -{- Derivation Paths -} - --- | Phantom type signaling a hardened derivation path that can only be computed --- from private extended key. -data HardDeriv deriving (Generic, NFData) - --- | Phantom type signaling no knowledge about derivation path: can be hardened or not. -data AnyDeriv deriving (Generic, NFData) - --- | Phantom type signaling derivation path including only non-hardened paths --- that can be computed from an extended public key. -data SoftDeriv deriving (Generic, NFData) - --- | Hardened derivation path. Can be computed from extended private key only. -type HardPath = DerivPathI HardDeriv - --- | Any derivation path. -type DerivPath = DerivPathI AnyDeriv - --- | Non-hardened derivation path can be computed from extended public key. -type SoftPath = DerivPathI SoftDeriv - --- | Helper class to perform validations on a hardened derivation path. -class HardOrAny a -instance HardOrAny HardDeriv -instance HardOrAny AnyDeriv - --- | Helper class to perform validations on a non-hardened derivation path. -class AnyOrSoft a -instance AnyOrSoft AnyDeriv -instance AnyOrSoft SoftDeriv - --- | Data type representing a derivation path. Two constructors are provided --- for specifying soft or hard derivations. The path /\/0\/1'\/2/ for example can be --- expressed as @'Deriv' :\/ 0 :| 1 :\/ 2@. The 'HardOrAny' and 'AnyOrSoft' type --- classes are used to constrain the valid values for the phantom type /t/. If --- you mix hard '(:|)' and soft '(:\/)' paths, the only valid type for /t/ is 'AnyDeriv'. --- Otherwise, /t/ can be 'HardDeriv' if you only have hard derivation or 'SoftDeriv' --- if you only have soft derivations. --- --- Using this type is as easy as writing the required derivation like in these --- example: --- --- > Deriv :/ 0 :/ 1 :/ 2 :: SoftPath --- > Deriv :| 0 :| 1 :| 2 :: HardPath --- > Deriv :| 0 :/ 1 :/ 2 :: DerivPath -data DerivPathI t where - (:|) :: HardOrAny t => !(DerivPathI t) -> !KeyIndex -> DerivPathI t - (:/) :: AnyOrSoft t => !(DerivPathI t) -> !KeyIndex -> DerivPathI t - Deriv :: DerivPathI t - -instance NFData (DerivPathI t) where - rnf (a :| b) = rnf a `seq` rnf b `seq` () - rnf (a :/ b) = rnf a `seq` rnf b `seq` () - rnf Deriv = () - -instance Eq (DerivPathI t) where - (nextA :| iA) == (nextB :| iB) = iA == iB && nextA == nextB - (nextA :/ iA) == (nextB :/ iB) = iA == iB && nextA == nextB - Deriv == Deriv = True - _ == _ = False - -instance Ord (DerivPathI t) where - -- Same hardness on each side - (nextA :| iA) `compare` (nextB :| iB) = - if nextA == nextB then iA `compare` iB else nextA `compare` nextB - (nextA :/ iA) `compare` (nextB :/ iB) = - if nextA == nextB then iA `compare` iB else nextA `compare` nextB - - -- Different hardness: hard paths are LT soft paths - (nextA :/ _iA) `compare` (nextB :| _iB) = - if nextA == nextB then LT else nextA `compare` nextB - (nextA :| _iA) `compare` (nextB :/ _iB) = - if nextA == nextB then GT else nextA `compare` nextB - - Deriv `compare` Deriv = EQ - Deriv `compare` _ = LT - _ `compare` Deriv = GT - - -instance Serialize DerivPath where - get = listToPath <$> S.get - put = put . pathToList - --- | Get a list of derivation indices from a derivation path. -pathToList :: DerivPathI t -> [KeyIndex] -pathToList = - reverse . go - where - go (next :| i) = setBit i 31 : go next - go (next :/ i) = i : go next - go _ = [] - --- | Convert a list of derivation indices to a derivation path. -listToPath :: [KeyIndex] -> DerivPath -listToPath = - go . reverse - where - go (i:is) - | testBit i 31 = go is :| clearBit i 31 - | otherwise = go is :/ i - go [] = Deriv - --- | Convert a derivation path to a human-readable string. -pathToStr :: DerivPathI t -> String -pathToStr p = - case p of - next :| i -> concat [ pathToStr next, "/", show i, "'" ] - next :/ i -> concat [ pathToStr next, "/", show i ] - Deriv -> "" - --- | Turn a derivation path into a hard derivation path. Will fail if the path --- contains soft derivations. -toHard :: DerivPathI t -> Maybe HardPath -toHard p = case p of - next :| i -> (:| i) <$> toHard next - Deriv -> Just Deriv - _ -> Nothing - --- | Turn a derivation path into a soft derivation path. Will fail if the path --- has hard derivations. -toSoft :: DerivPathI t -> Maybe SoftPath -toSoft p = case p of - next :/ i -> (:/ i) <$> toSoft next - Deriv -> Just Deriv - _ -> Nothing - --- | Make a derivation path generic. -toGeneric :: DerivPathI t -> DerivPath -toGeneric p = case p of - next :/ i -> toGeneric next :/ i - next :| i -> toGeneric next :| i - Deriv -> Deriv - --- | Append two derivation paths together. The result will be a mixed --- derivation path. -(++/) :: DerivPathI t1 -> DerivPathI t2 -> DerivPath -(++/) p1 p2 = - go id (toGeneric p2) $ toGeneric p1 - where - go f p = case p of - next :/ i -> go (f . (:/ i)) $ toGeneric next - next :| i -> go (f . (:| i)) $ toGeneric next - _ -> f - --- | Derive a private key from a derivation path -derivePath :: DerivPathI t -> XPrvKey -> XPrvKey -derivePath = go id - where - -- Build the full derivation function starting from the end - go f p = case p of - next :| i -> go (f . flip hardSubKey i) next - next :/ i -> go (f . flip prvSubKey i) next - _ -> f - --- | Derive a public key from a soft derivation path -derivePubPath :: SoftPath -> XPubKey -> XPubKey -derivePubPath = go id - where - -- Build the full derivation function starting from the end - go f p = case p of - next :/ i -> go (f . flip pubSubKey i) next - _ -> f - -instance Show DerivPath where - showsPrec d p = showParen (d > 10) $ - showString "DerivPath " . shows (pathToStr p) - -instance Read DerivPath where - readPrec = parens $ do - R.Ident "DerivPath" <- lexP - R.String str <- lexP - maybe pfail return $ getParsedPath <$> parsePath str - -instance Show HardPath where - showsPrec d p = showParen (d > 10) $ - showString "HardPath " . shows (pathToStr p) - -instance Read HardPath where - readPrec = parens $ do - R.Ident "HardPath" <- lexP - R.String str <- lexP - maybe pfail return $ parseHard str - -instance Show SoftPath where - showsPrec d p = showParen (d > 10) $ - showString "SoftPath " . shows (pathToStr p) - -instance Read SoftPath where - readPrec = parens $ do - R.Ident "SoftPath" <- lexP - R.String str <- lexP - maybe pfail return $ parseSoft str - -instance IsString ParsedPath where - fromString = - fromMaybe e . parsePath - where - e = error "Could not parse derivation path" - -instance IsString DerivPath where - fromString = - getParsedPath . fromMaybe e . parsePath - where - e = error "Could not parse derivation path" - -instance IsString HardPath where - fromString = - fromMaybe e . parseHard - where - e = error "Could not parse hard derivation path" - -instance IsString SoftPath where - fromString = - fromMaybe e . parseSoft - where - e = error "Could not parse soft derivation path" - -instance FromJSON ParsedPath where - parseJSON = withText "ParsedPath" $ \str -> case parsePath $ cs str of - Just p -> return p - _ -> mzero - -instance FromJSON DerivPath where - parseJSON = withText "DerivPath" $ \str -> case parsePath $ cs str of - Just p -> return $ getParsedPath p - _ -> mzero - -instance FromJSON HardPath where - parseJSON = withText "HardPath" $ \str -> case parseHard $ cs str of - Just p -> return p - _ -> mzero - -instance FromJSON SoftPath where - parseJSON = withText "SoftPath" $ \str -> case parseSoft $ cs str of - Just p -> return p - _ -> mzero - -instance ToJSON (DerivPathI t) where - toJSON = A.String . cs . pathToStr - -instance ToJSON ParsedPath where - toJSON (ParsedPrv p) = A.String . cs . ("m" ++) . pathToStr $ p - toJSON (ParsedPub p) = A.String . cs . ("M" ++) . pathToStr $ p - toJSON (ParsedEmpty p) = A.String . cs . ("" ++) . pathToStr $ p - -{- Parsing derivation paths of the form m/1/2'/3 or M/1/2'/3 -} - --- | Type for parsing derivation paths of the form /m\/1\/2'\/3/ or --- /M\/1\/2'\/3/. -data ParsedPath = ParsedPrv { getParsedPath :: !DerivPath } - | ParsedPub { getParsedPath :: !DerivPath } - | ParsedEmpty { getParsedPath :: !DerivPath } - deriving (Eq, Generic, NFData) - -instance Show ParsedPath where - showsPrec d p = showParen (d > 10) $ showString "ParsedPath " . shows f - where - f = - case p of - ParsedPrv d' -> "m" <> pathToStr d' - ParsedPub d' -> "M" <> pathToStr d' - ParsedEmpty d' -> pathToStr d' - -instance Read ParsedPath where - readPrec = parens $ do - R.Ident "ParsedPath" <- lexP - R.String str <- lexP - maybe pfail return $ parsePath str - --- | Parse derivation path string for extended key. --- Forms: /m\/0'\/2/, /M\/2\/3\/4/. -parsePath :: String -> Maybe ParsedPath -parsePath str = do - res <- concatBip32Segments <$> mapM parseBip32PathIndex xs - case x of - "m" -> Just $ ParsedPrv res - "M" -> Just $ ParsedPub res - "" -> Just $ ParsedEmpty res - _ -> Nothing - where - (x : xs) = splitOn "/" str - --- | Concatenate derivation path indices into a derivation path. -concatBip32Segments :: [Bip32PathIndex] -> DerivPath -concatBip32Segments = foldl' appendBip32Segment Deriv - --- | Append an extra derivation path index element into an existing path. -appendBip32Segment :: DerivPath -> Bip32PathIndex -> DerivPath -appendBip32Segment d (Bip32SoftIndex i) = d :/ i -appendBip32Segment d (Bip32HardIndex i) = d :| i - --- | Parse a BIP32 derivation path index element from a string. -parseBip32PathIndex :: String -> Maybe Bip32PathIndex -parseBip32PathIndex segment = case reads segment of - [(i, "" )] -> guard (is31Bit i) >> return (Bip32SoftIndex i) - [(i, "'")] -> guard (is31Bit i) >> return (Bip32HardIndex i) - _ -> Nothing - --- | Type for BIP32 path index element. -data Bip32PathIndex = Bip32HardIndex KeyIndex - | Bip32SoftIndex KeyIndex - deriving (Eq, Generic, NFData) - -instance Show Bip32PathIndex where - showsPrec d (Bip32HardIndex i) = showParen (d > 10) $ - showString "Bip32HardIndex " . shows i - showsPrec d (Bip32SoftIndex i) = showParen (d > 10) $ - showString "Bip32SoftIndex " . shows i - -instance Read Bip32PathIndex where - readPrec = h <|> s - where - h = - parens $ do - R.Ident "Bip32HardIndex" <- lexP - R.Number n <- lexP - maybe pfail return $ - Bip32HardIndex . fromIntegral <$> numberToInteger n - s = - parens $ do - R.Ident "Bip32SoftIndex" <- lexP - R.Number n <- lexP - maybe pfail return $ - Bip32SoftIndex . fromIntegral <$> numberToInteger n - --- | Test whether the number could be a valid BIP32 derivation index. -is31Bit :: (Integral a) => a -> Bool -is31Bit i = i >= 0 && i < 0x80000000 - --- | Helper function to parse a hard path. -parseHard :: String -> Maybe HardPath -parseHard = toHard . getParsedPath <=< parsePath - --- | Helper function to parse a soft path. -parseSoft :: String -> Maybe SoftPath -parseSoft = toSoft . getParsedPath <=< parsePath - --- | Data type representing a private or public key with its respective network. -data XKey - = XPrv { getXKeyPrv :: !XPrvKey - , getXKeyNet :: !Network } - | XPub { getXKeyPub :: !XPubKey - , getXKeyNet :: !Network } - deriving (Eq, Show, Generic, NFData) - --- | Apply a parsed path to an extended key to derive the new key defined in the --- path. If the path starts with /m/, a private key will be returned and if the --- path starts with /M/, a public key will be returned. Private derivations on a --- public key, and public derivations with a hard segment, return an error --- value. -applyPath :: ParsedPath -> XKey -> Either String XKey -applyPath path key = - case (path, key) of - (ParsedPrv _, XPrv k n) -> return $ XPrv (derivPrvF k) n - (ParsedPrv _, XPub {}) -> Left "applyPath: Invalid public key" - (ParsedPub _, XPrv k n) -> return $ XPub (deriveXPubKey (derivPrvF k)) n - (ParsedPub _, XPub k n) -> derivPubFE >>= \f -> return $ XPub (f k) n - -- For empty parsed paths, we take a hint from the provided key - (ParsedEmpty _, XPrv k n) -> return $ XPrv (derivPrvF k) n - (ParsedEmpty _, XPub k n) -> derivPubFE >>= \f -> return $ XPub (f k) n - where - derivPrvF = goPrv id $ getParsedPath path - derivPubFE = goPubE id $ getParsedPath path - -- Build the full private derivation function starting from the end - goPrv f p = - case p of - next :| i -> goPrv (f . flip hardSubKey i) next - next :/ i -> goPrv (f . flip prvSubKey i) next - Deriv -> f - -- Build the full public derivation function starting from the end - goPubE f p = - case p of - next :/ i -> goPubE (f . flip pubSubKey i) next - Deriv -> Right f - _ -> Left "applyPath: Invalid hard derivation" - -{- Helpers for derivation paths and addresses -} - --- | Derive an address from a given parent path. -derivePathAddr :: XPubKey -> SoftPath -> KeyIndex -> (Address, PubKey) -derivePathAddr key path = deriveAddr (derivePubPath path key) - --- | Cyclic list of all addresses derived from a given parent path and starting --- from the given offset index. -derivePathAddrs :: - XPubKey -> SoftPath -> KeyIndex -> [(Address, PubKey, KeyIndex)] -derivePathAddrs key path = deriveAddrs (derivePubPath path key) - --- | Derive a multisig address from a given parent path. The number of required --- signatures (m in m of n) is also needed. -derivePathMSAddr :: - [XPubKey] - -> SoftPath - -> Int - -> KeyIndex - -> (Address, RedeemScript) -derivePathMSAddr keys path = - deriveMSAddr $ map (derivePubPath path) keys - --- | Cyclic list of all multisig addresses derived from a given parent path and --- starting from the given offset index. The number of required signatures --- (m in m of n) is also needed. -derivePathMSAddrs :: - [XPubKey] - -> SoftPath - -> Int - -> KeyIndex - -> [(Address, RedeemScript, KeyIndex)] -derivePathMSAddrs keys path = - deriveMSAddrs $ map (derivePubPath path) keys - -{- Utilities for extended keys -} - --- | De-serialize HDW-specific private key. -getPadPrvKey :: Get SecKey -getPadPrvKey = do - pad <- getWord8 - unless (pad == 0x00) $ fail "Private key must be padded with 0x00" - secKeyGet - --- | Serialize HDW-specific private key. -putPadPrvKey :: Putter SecKey -putPadPrvKey p = putWord8 0x00 >> secKeyPut p - -bsPadPrvKey :: SecKey -> ByteString -bsPadPrvKey = runPut . putPadPrvKey diff --git a/src/Network/Haskoin/Keys/Mnemonic.hs b/src/Network/Haskoin/Keys/Mnemonic.hs deleted file mode 100644 --- a/src/Network/Haskoin/Keys/Mnemonic.hs +++ /dev/null @@ -1,516 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-| -Module : Network.Haskoin.Keys.Mnemonic -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Mnemonic keys (BIP-39). Only English dictionary. --} -module Network.Haskoin.Keys.Mnemonic - ( -- * Mnemonic Sentences - Entropy - , Mnemonic - , Passphrase - , Seed - , toMnemonic - , fromMnemonic - , mnemonicToSeed - ) where - -import Control.Monad (when) -import Crypto.Hash (SHA256 (..), hashWith) -import Crypto.KDF.PBKDF2 (Parameters (..), fastPBKDF2_SHA512) -import Data.Bits (shiftL, shiftR) -import qualified Data.ByteArray as BA -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.List -import qualified Data.Map.Strict as M -import Data.Maybe -import Data.String.Conversions (cs) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as E -import Data.Vector (Vector, (!)) -import qualified Data.Vector as V -import Network.Haskoin.Util - --- | Random data used to create a mnemonic sentence. Use a good entropy source. --- You will get your coins stolen if you don't. You have been warned. -type Entropy = ByteString - --- | Human-readable mnemonic sentence. -type Mnemonic = Text - --- | Optional passphrase for mnemnoic sentence. -type Passphrase = ByteString - --- | Seed for a private key from a mnemonic sentence. -type Seed = ByteString - --- | Mnemonic key checksum. -type Checksum = ByteString - --- | Paremeters for PBKDF2 function. -pbkdfParams :: Parameters -pbkdfParams = Parameters {iterCounts = 2048, outputLength = 64} - --- | Provide intial 'Entropy' as a 'ByteString' of length multiple of 4 bytes. --- Output a 'Mnemonic' sentence. -toMnemonic :: Entropy -> Either String Mnemonic -toMnemonic ent = do - when (BS.null ent) $ - Left "toMnemonic: entropy can not be empty" - when (remainder /= 0) $ - Left "toMnemonic: entropy must be multiples of 4 bytes" - when (cs_len > 16) $ - Left "toMnemonic: maximum entropy is 64 bytes (512 bits)" - return ms - where - (cs_len, remainder) = BS.length ent `quotRem` 4 - c = calcCS cs_len ent - indices = bsToIndices $ ent `BS.append` c - ms = T.unwords $ map (wl!) indices - --- | Revert 'toMnemonic'. Do not use this to generate a 'Seed'. Instead use --- 'mnemonicToSeed'. This outputs the original 'Entropy' used to generate a --- 'Mnemonic' sentence. -fromMnemonic :: Mnemonic -> Either String Entropy -fromMnemonic ms = do - when (T.null ms) $ - Left "fromMnemonic: empty mnemonic" - when (word_count > 48) $ - Left $ "fromMnemonic: too many words: " ++ show word_count - when (word_count `mod` 3 /= 0) $ - Left $ "fromMnemonic: wrong number of words:" ++ show word_count - ms_bs <- indicesToBS =<< getIndices ms_words - let (ms_ent, ms_cs) = BS.splitAt (ent_len * 4) ms_bs - ms_cs_num = numCS cs_len ms_cs - ent_cs_num = numCS cs_len $ calcCS cs_len ms_ent - when (ent_cs_num /= ms_cs_num) $ - Left $ "fromMnemonic: checksum failed: " ++ sh ent_cs_num ms_cs_num - return ms_ent - where - ms_words = T.words ms - word_count = length ms_words - (ent_len, cs_len) = (word_count * 11) `quotRem` 32 - sh cs_a cs_b = show cs_a ++ " /= " ++ show cs_b - --- | Compute 'Checksum'. -calcCS :: Int -> Entropy -> Checksum -calcCS len = getBits len . BA.convert . hashWith SHA256 - -numCS :: Int -> Entropy -> Integer -numCS len = - shiftCS . bsToInteger - where - shiftCS = case 8 - len `mod` 8 of - 8 -> id - x -> flip shiftR x - --- | Turn an arbitrary sequence of characters into a 512-bit 'Seed'. Use --- 'mnemonicToSeed' to get a seed from a 'Mnemonic' sentence. Warning: Does not --- perform NFKD normalization. -anyToSeed :: Passphrase -> Mnemonic -> Seed -anyToSeed pf ms = - fastPBKDF2_SHA512 pbkdfParams (E.encodeUtf8 ms) ("mnemonic" `mappend` pf) - --- | Get a 512-bit 'Seed' from a 'Mnemonic' sentence. Will validate checksum. --- 'Passphrase' can be used to protect the 'Mnemonic'. Use an empty string as --- 'Passphrase' if none is required. -mnemonicToSeed :: Passphrase -> Mnemonic -> Either String Seed -mnemonicToSeed pf ms = do - ent <- fromMnemonic ms - mnm <- toMnemonic ent - return $ anyToSeed pf mnm - --- | Get indices of words in word list. -getIndices :: [Text] -> Either String [Int] -getIndices ws - | null n = return $ catMaybes i - | otherwise = Left $ "getIndices: words not found: " ++ cs w - where - i = map (`M.lookup` wl') ws - n = elemIndices Nothing i - w = T.unwords $ map (ws !!) n - --- | Turn a list of 11-bit numbers into a 'ByteString' -indicesToBS :: [Int] -> Either String ByteString -indicesToBS is = do - when lrg $ Left "indicesToBS: index larger or equal than 2048" - return . pad . integerToBS $ foldl' f 0 is `shiftL` shift_width - where - lrg = isJust $ find (>= 2048) is - (q, r) = (length is * 11) `quotRem` 8 - shift_width = - if r == 0 - then 0 - else 8 - r - bl = - if r == 0 - then q - else q + 1 -- length of resulting ByteString - pad bs = BS.append (BS.replicate (bl - BS.length bs) 0x00) bs - f acc x = (acc `shiftL` 11) + fromIntegral x - --- | Turn a 'ByteString' into a list of 11-bit numbers. -bsToIndices :: ByteString -> [Int] -bsToIndices bs = - reverse . go q $ bsToInteger bs `shiftR` r - where - (q, r) = (BS.length bs * 8) `quotRem` 11 - go 0 _ = [] - go n i = fromIntegral (i `mod` 2048) : go (n - 1) (i `shiftR` 11) - -wl' :: M.Map Text Int -wl' = V.ifoldr' (\i w m -> M.insert w i m) M.empty wl - --- | Standard English dictionary from BIP-39 specification. -wl :: Vector Text -wl = V.fromListN 2048 - [ "abandon", "ability", "able", "about", "above", "absent" - , "absorb", "abstract", "absurd", "abuse", "access", "accident" - , "account", "accuse", "achieve", "acid", "acoustic", "acquire" - , "across", "act", "action", "actor", "actress", "actual" - , "adapt", "add", "addict", "address", "adjust", "admit" - , "adult", "advance", "advice", "aerobic", "affair", "afford" - , "afraid", "again", "age", "agent", "agree", "ahead" - , "aim", "air", "airport", "aisle", "alarm", "album" - , "alcohol", "alert", "alien", "all", "alley", "allow" - , "almost", "alone", "alpha", "already", "also", "alter" - , "always", "amateur", "amazing", "among", "amount", "amused" - , "analyst", "anchor", "ancient", "anger", "angle", "angry" - , "animal", "ankle", "announce", "annual", "another", "answer" - , "antenna", "antique", "anxiety", "any", "apart", "apology" - , "appear", "apple", "approve", "april", "arch", "arctic" - , "area", "arena", "argue", "arm", "armed", "armor" - , "army", "around", "arrange", "arrest", "arrive", "arrow" - , "art", "artefact", "artist", "artwork", "ask", "aspect" - , "assault", "asset", "assist", "assume", "asthma", "athlete" - , "atom", "attack", "attend", "attitude", "attract", "auction" - , "audit", "august", "aunt", "author", "auto", "autumn" - , "average", "avocado", "avoid", "awake", "aware", "away" - , "awesome", "awful", "awkward", "axis", "baby", "bachelor" - , "bacon", "badge", "bag", "balance", "balcony", "ball" - , "bamboo", "banana", "banner", "bar", "barely", "bargain" - , "barrel", "base", "basic", "basket", "battle", "beach" - , "bean", "beauty", "because", "become", "beef", "before" - , "begin", "behave", "behind", "believe", "below", "belt" - , "bench", "benefit", "best", "betray", "better", "between" - , "beyond", "bicycle", "bid", "bike", "bind", "biology" - , "bird", "birth", "bitter", "black", "blade", "blame" - , "blanket", "blast", "bleak", "bless", "blind", "blood" - , "blossom", "blouse", "blue", "blur", "blush", "board" - , "boat", "body", "boil", "bomb", "bone", "bonus" - , "book", "boost", "border", "boring", "borrow", "boss" - , "bottom", "bounce", "box", "boy", "bracket", "brain" - , "brand", "brass", "brave", "bread", "breeze", "brick" - , "bridge", "brief", "bright", "bring", "brisk", "broccoli" - , "broken", "bronze", "broom", "brother", "brown", "brush" - , "bubble", "buddy", "budget", "buffalo", "build", "bulb" - , "bulk", "bullet", "bundle", "bunker", "burden", "burger" - , "burst", "bus", "business", "busy", "butter", "buyer" - , "buzz", "cabbage", "cabin", "cable", "cactus", "cage" - , "cake", "call", "calm", "camera", "camp", "can" - , "canal", "cancel", "candy", "cannon", "canoe", "canvas" - , "canyon", "capable", "capital", "captain", "car", "carbon" - , "card", "cargo", "carpet", "carry", "cart", "case" - , "cash", "casino", "castle", "casual", "cat", "catalog" - , "catch", "category", "cattle", "caught", "cause", "caution" - , "cave", "ceiling", "celery", "cement", "census", "century" - , "cereal", "certain", "chair", "chalk", "champion", "change" - , "chaos", "chapter", "charge", "chase", "chat", "cheap" - , "check", "cheese", "chef", "cherry", "chest", "chicken" - , "chief", "child", "chimney", "choice", "choose", "chronic" - , "chuckle", "chunk", "churn", "cigar", "cinnamon", "circle" - , "citizen", "city", "civil", "claim", "clap", "clarify" - , "claw", "clay", "clean", "clerk", "clever", "click" - , "client", "cliff", "climb", "clinic", "clip", "clock" - , "clog", "close", "cloth", "cloud", "clown", "club" - , "clump", "cluster", "clutch", "coach", "coast", "coconut" - , "code", "coffee", "coil", "coin", "collect", "color" - , "column", "combine", "come", "comfort", "comic", "common" - , "company", "concert", "conduct", "confirm", "congress", "connect" - , "consider", "control", "convince", "cook", "cool", "copper" - , "copy", "coral", "core", "corn", "correct", "cost" - , "cotton", "couch", "country", "couple", "course", "cousin" - , "cover", "coyote", "crack", "cradle", "craft", "cram" - , "crane", "crash", "crater", "crawl", "crazy", "cream" - , "credit", "creek", "crew", "cricket", "crime", "crisp" - , "critic", "crop", "cross", "crouch", "crowd", "crucial" - , "cruel", "cruise", "crumble", "crunch", "crush", "cry" - , "crystal", "cube", "culture", "cup", "cupboard", "curious" - , "current", "curtain", "curve", "cushion", "custom", "cute" - , "cycle", "dad", "damage", "damp", "dance", "danger" - , "daring", "dash", "daughter", "dawn", "day", "deal" - , "debate", "debris", "decade", "december", "decide", "decline" - , "decorate", "decrease", "deer", "defense", "define", "defy" - , "degree", "delay", "deliver", "demand", "demise", "denial" - , "dentist", "deny", "depart", "depend", "deposit", "depth" - , "deputy", "derive", "describe", "desert", "design", "desk" - , "despair", "destroy", "detail", "detect", "develop", "device" - , "devote", "diagram", "dial", "diamond", "diary", "dice" - , "diesel", "diet", "differ", "digital", "dignity", "dilemma" - , "dinner", "dinosaur", "direct", "dirt", "disagree", "discover" - , "disease", "dish", "dismiss", "disorder", "display", "distance" - , "divert", "divide", "divorce", "dizzy", "doctor", "document" - , "dog", "doll", "dolphin", "domain", "donate", "donkey" - , "donor", "door", "dose", "double", "dove", "draft" - , "dragon", "drama", "drastic", "draw", "dream", "dress" - , "drift", "drill", "drink", "drip", "drive", "drop" - , "drum", "dry", "duck", "dumb", "dune", "during" - , "dust", "dutch", "duty", "dwarf", "dynamic", "eager" - , "eagle", "early", "earn", "earth", "easily", "east" - , "easy", "echo", "ecology", "economy", "edge", "edit" - , "educate", "effort", "egg", "eight", "either", "elbow" - , "elder", "electric", "elegant", "element", "elephant", "elevator" - , "elite", "else", "embark", "embody", "embrace", "emerge" - , "emotion", "employ", "empower", "empty", "enable", "enact" - , "end", "endless", "endorse", "enemy", "energy", "enforce" - , "engage", "engine", "enhance", "enjoy", "enlist", "enough" - , "enrich", "enroll", "ensure", "enter", "entire", "entry" - , "envelope", "episode", "equal", "equip", "era", "erase" - , "erode", "erosion", "error", "erupt", "escape", "essay" - , "essence", "estate", "eternal", "ethics", "evidence", "evil" - , "evoke", "evolve", "exact", "example", "excess", "exchange" - , "excite", "exclude", "excuse", "execute", "exercise", "exhaust" - , "exhibit", "exile", "exist", "exit", "exotic", "expand" - , "expect", "expire", "explain", "expose", "express", "extend" - , "extra", "eye", "eyebrow", "fabric", "face", "faculty" - , "fade", "faint", "faith", "fall", "false", "fame" - , "family", "famous", "fan", "fancy", "fantasy", "farm" - , "fashion", "fat", "fatal", "father", "fatigue", "fault" - , "favorite", "feature", "february", "federal", "fee", "feed" - , "feel", "female", "fence", "festival", "fetch", "fever" - , "few", "fiber", "fiction", "field", "figure", "file" - , "film", "filter", "final", "find", "fine", "finger" - , "finish", "fire", "firm", "first", "fiscal", "fish" - , "fit", "fitness", "fix", "flag", "flame", "flash" - , "flat", "flavor", "flee", "flight", "flip", "float" - , "flock", "floor", "flower", "fluid", "flush", "fly" - , "foam", "focus", "fog", "foil", "fold", "follow" - , "food", "foot", "force", "forest", "forget", "fork" - , "fortune", "forum", "forward", "fossil", "foster", "found" - , "fox", "fragile", "frame", "frequent", "fresh", "friend" - , "fringe", "frog", "front", "frost", "frown", "frozen" - , "fruit", "fuel", "fun", "funny", "furnace", "fury" - , "future", "gadget", "gain", "galaxy", "gallery", "game" - , "gap", "garage", "garbage", "garden", "garlic", "garment" - , "gas", "gasp", "gate", "gather", "gauge", "gaze" - , "general", "genius", "genre", "gentle", "genuine", "gesture" - , "ghost", "giant", "gift", "giggle", "ginger", "giraffe" - , "girl", "give", "glad", "glance", "glare", "glass" - , "glide", "glimpse", "globe", "gloom", "glory", "glove" - , "glow", "glue", "goat", "goddess", "gold", "good" - , "goose", "gorilla", "gospel", "gossip", "govern", "gown" - , "grab", "grace", "grain", "grant", "grape", "grass" - , "gravity", "great", "green", "grid", "grief", "grit" - , "grocery", "group", "grow", "grunt", "guard", "guess" - , "guide", "guilt", "guitar", "gun", "gym", "habit" - , "hair", "half", "hammer", "hamster", "hand", "happy" - , "harbor", "hard", "harsh", "harvest", "hat", "have" - , "hawk", "hazard", "head", "health", "heart", "heavy" - , "hedgehog", "height", "hello", "helmet", "help", "hen" - , "hero", "hidden", "high", "hill", "hint", "hip" - , "hire", "history", "hobby", "hockey", "hold", "hole" - , "holiday", "hollow", "home", "honey", "hood", "hope" - , "horn", "horror", "horse", "hospital", "host", "hotel" - , "hour", "hover", "hub", "huge", "human", "humble" - , "humor", "hundred", "hungry", "hunt", "hurdle", "hurry" - , "hurt", "husband", "hybrid", "ice", "icon", "idea" - , "identify", "idle", "ignore", "ill", "illegal", "illness" - , "image", "imitate", "immense", "immune", "impact", "impose" - , "improve", "impulse", "inch", "include", "income", "increase" - , "index", "indicate", "indoor", "industry", "infant", "inflict" - , "inform", "inhale", "inherit", "initial", "inject", "injury" - , "inmate", "inner", "innocent", "input", "inquiry", "insane" - , "insect", "inside", "inspire", "install", "intact", "interest" - , "into", "invest", "invite", "involve", "iron", "island" - , "isolate", "issue", "item", "ivory", "jacket", "jaguar" - , "jar", "jazz", "jealous", "jeans", "jelly", "jewel" - , "job", "join", "joke", "journey", "joy", "judge" - , "juice", "jump", "jungle", "junior", "junk", "just" - , "kangaroo", "keen", "keep", "ketchup", "key", "kick" - , "kid", "kidney", "kind", "kingdom", "kiss", "kit" - , "kitchen", "kite", "kitten", "kiwi", "knee", "knife" - , "knock", "know", "lab", "label", "labor", "ladder" - , "lady", "lake", "lamp", "language", "laptop", "large" - , "later", "latin", "laugh", "laundry", "lava", "law" - , "lawn", "lawsuit", "layer", "lazy", "leader", "leaf" - , "learn", "leave", "lecture", "left", "leg", "legal" - , "legend", "leisure", "lemon", "lend", "length", "lens" - , "leopard", "lesson", "letter", "level", "liar", "liberty" - , "library", "license", "life", "lift", "light", "like" - , "limb", "limit", "link", "lion", "liquid", "list" - , "little", "live", "lizard", "load", "loan", "lobster" - , "local", "lock", "logic", "lonely", "long", "loop" - , "lottery", "loud", "lounge", "love", "loyal", "lucky" - , "luggage", "lumber", "lunar", "lunch", "luxury", "lyrics" - , "machine", "mad", "magic", "magnet", "maid", "mail" - , "main", "major", "make", "mammal", "man", "manage" - , "mandate", "mango", "mansion", "manual", "maple", "marble" - , "march", "margin", "marine", "market", "marriage", "mask" - , "mass", "master", "match", "material", "math", "matrix" - , "matter", "maximum", "maze", "meadow", "mean", "measure" - , "meat", "mechanic", "medal", "media", "melody", "melt" - , "member", "memory", "mention", "menu", "mercy", "merge" - , "merit", "merry", "mesh", "message", "metal", "method" - , "middle", "midnight", "milk", "million", "mimic", "mind" - , "minimum", "minor", "minute", "miracle", "mirror", "misery" - , "miss", "mistake", "mix", "mixed", "mixture", "mobile" - , "model", "modify", "mom", "moment", "monitor", "monkey" - , "monster", "month", "moon", "moral", "more", "morning" - , "mosquito", "mother", "motion", "motor", "mountain", "mouse" - , "move", "movie", "much", "muffin", "mule", "multiply" - , "muscle", "museum", "mushroom", "music", "must", "mutual" - , "myself", "mystery", "myth", "naive", "name", "napkin" - , "narrow", "nasty", "nation", "nature", "near", "neck" - , "need", "negative", "neglect", "neither", "nephew", "nerve" - , "nest", "net", "network", "neutral", "never", "news" - , "next", "nice", "night", "noble", "noise", "nominee" - , "noodle", "normal", "north", "nose", "notable", "note" - , "nothing", "notice", "novel", "now", "nuclear", "number" - , "nurse", "nut", "oak", "obey", "object", "oblige" - , "obscure", "observe", "obtain", "obvious", "occur", "ocean" - , "october", "odor", "off", "offer", "office", "often" - , "oil", "okay", "old", "olive", "olympic", "omit" - , "once", "one", "onion", "online", "only", "open" - , "opera", "opinion", "oppose", "option", "orange", "orbit" - , "orchard", "order", "ordinary", "organ", "orient", "original" - , "orphan", "ostrich", "other", "outdoor", "outer", "output" - , "outside", "oval", "oven", "over", "own", "owner" - , "oxygen", "oyster", "ozone", "pact", "paddle", "page" - , "pair", "palace", "palm", "panda", "panel", "panic" - , "panther", "paper", "parade", "parent", "park", "parrot" - , "party", "pass", "patch", "path", "patient", "patrol" - , "pattern", "pause", "pave", "payment", "peace", "peanut" - , "pear", "peasant", "pelican", "pen", "penalty", "pencil" - , "people", "pepper", "perfect", "permit", "person", "pet" - , "phone", "photo", "phrase", "physical", "piano", "picnic" - , "picture", "piece", "pig", "pigeon", "pill", "pilot" - , "pink", "pioneer", "pipe", "pistol", "pitch", "pizza" - , "place", "planet", "plastic", "plate", "play", "please" - , "pledge", "pluck", "plug", "plunge", "poem", "poet" - , "point", "polar", "pole", "police", "pond", "pony" - , "pool", "popular", "portion", "position", "possible", "post" - , "potato", "pottery", "poverty", "powder", "power", "practice" - , "praise", "predict", "prefer", "prepare", "present", "pretty" - , "prevent", "price", "pride", "primary", "print", "priority" - , "prison", "private", "prize", "problem", "process", "produce" - , "profit", "program", "project", "promote", "proof", "property" - , "prosper", "protect", "proud", "provide", "public", "pudding" - , "pull", "pulp", "pulse", "pumpkin", "punch", "pupil" - , "puppy", "purchase", "purity", "purpose", "purse", "push" - , "put", "puzzle", "pyramid", "quality", "quantum", "quarter" - , "question", "quick", "quit", "quiz", "quote", "rabbit" - , "raccoon", "race", "rack", "radar", "radio", "rail" - , "rain", "raise", "rally", "ramp", "ranch", "random" - , "range", "rapid", "rare", "rate", "rather", "raven" - , "raw", "razor", "ready", "real", "reason", "rebel" - , "rebuild", "recall", "receive", "recipe", "record", "recycle" - , "reduce", "reflect", "reform", "refuse", "region", "regret" - , "regular", "reject", "relax", "release", "relief", "rely" - , "remain", "remember", "remind", "remove", "render", "renew" - , "rent", "reopen", "repair", "repeat", "replace", "report" - , "require", "rescue", "resemble", "resist", "resource", "response" - , "result", "retire", "retreat", "return", "reunion", "reveal" - , "review", "reward", "rhythm", "rib", "ribbon", "rice" - , "rich", "ride", "ridge", "rifle", "right", "rigid" - , "ring", "riot", "ripple", "risk", "ritual", "rival" - , "river", "road", "roast", "robot", "robust", "rocket" - , "romance", "roof", "rookie", "room", "rose", "rotate" - , "rough", "round", "route", "royal", "rubber", "rude" - , "rug", "rule", "run", "runway", "rural", "sad" - , "saddle", "sadness", "safe", "sail", "salad", "salmon" - , "salon", "salt", "salute", "same", "sample", "sand" - , "satisfy", "satoshi", "sauce", "sausage", "save", "say" - , "scale", "scan", "scare", "scatter", "scene", "scheme" - , "school", "science", "scissors", "scorpion", "scout", "scrap" - , "screen", "script", "scrub", "sea", "search", "season" - , "seat", "second", "secret", "section", "security", "seed" - , "seek", "segment", "select", "sell", "seminar", "senior" - , "sense", "sentence", "series", "service", "session", "settle" - , "setup", "seven", "shadow", "shaft", "shallow", "share" - , "shed", "shell", "sheriff", "shield", "shift", "shine" - , "ship", "shiver", "shock", "shoe", "shoot", "shop" - , "short", "shoulder", "shove", "shrimp", "shrug", "shuffle" - , "shy", "sibling", "sick", "side", "siege", "sight" - , "sign", "silent", "silk", "silly", "silver", "similar" - , "simple", "since", "sing", "siren", "sister", "situate" - , "six", "size", "skate", "sketch", "ski", "skill" - , "skin", "skirt", "skull", "slab", "slam", "sleep" - , "slender", "slice", "slide", "slight", "slim", "slogan" - , "slot", "slow", "slush", "small", "smart", "smile" - , "smoke", "smooth", "snack", "snake", "snap", "sniff" - , "snow", "soap", "soccer", "social", "sock", "soda" - , "soft", "solar", "soldier", "solid", "solution", "solve" - , "someone", "song", "soon", "sorry", "sort", "soul" - , "sound", "soup", "source", "south", "space", "spare" - , "spatial", "spawn", "speak", "special", "speed", "spell" - , "spend", "sphere", "spice", "spider", "spike", "spin" - , "spirit", "split", "spoil", "sponsor", "spoon", "sport" - , "spot", "spray", "spread", "spring", "spy", "square" - , "squeeze", "squirrel", "stable", "stadium", "staff", "stage" - , "stairs", "stamp", "stand", "start", "state", "stay" - , "steak", "steel", "stem", "step", "stereo", "stick" - , "still", "sting", "stock", "stomach", "stone", "stool" - , "story", "stove", "strategy", "street", "strike", "strong" - , "struggle", "student", "stuff", "stumble", "style", "subject" - , "submit", "subway", "success", "such", "sudden", "suffer" - , "sugar", "suggest", "suit", "summer", "sun", "sunny" - , "sunset", "super", "supply", "supreme", "sure", "surface" - , "surge", "surprise", "surround", "survey", "suspect", "sustain" - , "swallow", "swamp", "swap", "swarm", "swear", "sweet" - , "swift", "swim", "swing", "switch", "sword", "symbol" - , "symptom", "syrup", "system", "table", "tackle", "tag" - , "tail", "talent", "talk", "tank", "tape", "target" - , "task", "taste", "tattoo", "taxi", "teach", "team" - , "tell", "ten", "tenant", "tennis", "tent", "term" - , "test", "text", "thank", "that", "theme", "then" - , "theory", "there", "they", "thing", "this", "thought" - , "three", "thrive", "throw", "thumb", "thunder", "ticket" - , "tide", "tiger", "tilt", "timber", "time", "tiny" - , "tip", "tired", "tissue", "title", "toast", "tobacco" - , "today", "toddler", "toe", "together", "toilet", "token" - , "tomato", "tomorrow", "tone", "tongue", "tonight", "tool" - , "tooth", "top", "topic", "topple", "torch", "tornado" - , "tortoise", "toss", "total", "tourist", "toward", "tower" - , "town", "toy", "track", "trade", "traffic", "tragic" - , "train", "transfer", "trap", "trash", "travel", "tray" - , "treat", "tree", "trend", "trial", "tribe", "trick" - , "trigger", "trim", "trip", "trophy", "trouble", "truck" - , "true", "truly", "trumpet", "trust", "truth", "try" - , "tube", "tuition", "tumble", "tuna", "tunnel", "turkey" - , "turn", "turtle", "twelve", "twenty", "twice", "twin" - , "twist", "two", "type", "typical", "ugly", "umbrella" - , "unable", "unaware", "uncle", "uncover", "under", "undo" - , "unfair", "unfold", "unhappy", "uniform", "unique", "unit" - , "universe", "unknown", "unlock", "until", "unusual", "unveil" - , "update", "upgrade", "uphold", "upon", "upper", "upset" - , "urban", "urge", "usage", "use", "used", "useful" - , "useless", "usual", "utility", "vacant", "vacuum", "vague" - , "valid", "valley", "valve", "van", "vanish", "vapor" - , "various", "vast", "vault", "vehicle", "velvet", "vendor" - , "venture", "venue", "verb", "verify", "version", "very" - , "vessel", "veteran", "viable", "vibrant", "vicious", "victory" - , "video", "view", "village", "vintage", "violin", "virtual" - , "virus", "visa", "visit", "visual", "vital", "vivid" - , "vocal", "voice", "void", "volcano", "volume", "vote" - , "voyage", "wage", "wagon", "wait", "walk", "wall" - , "walnut", "want", "warfare", "warm", "warrior", "wash" - , "wasp", "waste", "water", "wave", "way", "wealth" - , "weapon", "wear", "weasel", "weather", "web", "wedding" - , "weekend", "weird", "welcome", "west", "wet", "whale" - , "what", "wheat", "wheel", "when", "where", "whip" - , "whisper", "wide", "width", "wife", "wild", "will" - , "win", "window", "wine", "wing", "wink", "winner" - , "winter", "wire", "wisdom", "wise", "wish", "witness" - , "wolf", "woman", "wonder", "wood", "wool", "word" - , "work", "world", "worry", "worth", "wrap", "wreck" - , "wrestle", "wrist", "write", "wrong", "yard", "year" - , "yellow", "you", "young", "youth", "zebra", "zero" - , "zone", "zoo" - ] diff --git a/src/Network/Haskoin/Network.hs b/src/Network/Haskoin/Network.hs deleted file mode 100644 --- a/src/Network/Haskoin/Network.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-| -Module : Network.Haskoin.Network -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -This module provides basic types used for the Bitcoin networking protocol -together with 'Data.Serialize' instances for efficiently serializing and -de-serializing them. --} -module Network.Haskoin.Network - ( module Common - , module Message - , module Bloom - ) where - -import Network.Haskoin.Network.Bloom as Bloom -import Network.Haskoin.Network.Common as Common -import Network.Haskoin.Network.Message as Message diff --git a/src/Network/Haskoin/Network/Bloom.hs b/src/Network/Haskoin/Network/Bloom.hs deleted file mode 100644 --- a/src/Network/Haskoin/Network/Bloom.hs +++ /dev/null @@ -1,263 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-| -Module : Network.Haskoin.Network.Bloom -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Bloom filters are used to reduce data transfer when synchronizing thin cients. -When bloom filters are used a client will obtain filtered blocks that only -contain transactions that pass the bloom filter. Transactions announced via inv -messages also pass the filter. --} -module Network.Haskoin.Network.Bloom - ( -- * Bloom Filters - BloomFlags(..) - , BloomFilter(..) - , FilterLoad(..) - , FilterAdd(..) - , bloomCreate - , bloomInsert - , bloomContains - , isBloomValid - , isBloomEmpty - , isBloomFull - , acceptsFilters - , bloomRelevantUpdate - ) where - -import Control.DeepSeq -import Control.Monad (forM_, replicateM) -import Data.Bits -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.Foldable as F -import Data.Hash.Murmur (murmur3) -import Data.List (foldl') -import qualified Data.Sequence as S -import Data.Serialize (Serialize, encode, get, - put) -import Data.Serialize.Get (getByteString, getWord32le, - getWord8) -import Data.Serialize.Put (putByteString, putWord32le, - putWord8) -import Data.Word -import GHC.Generics (Generic) -import Network.Haskoin.Network.Common -import Network.Haskoin.Script.Common -import Network.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. -data BloomFlags - = BloomUpdateNone -- ^ never update - | BloomUpdateAll -- ^ auto-update on all outputs - | BloomUpdateP2PubKeyOnly - -- ^ auto-update on pay-to-pubkey or pay-to-multisig (default) - deriving (Eq, Show, Read, Generic, NFData) - -instance Serialize BloomFlags where - get = go =<< getWord8 - where - go 0 = return BloomUpdateNone - go 1 = return BloomUpdateAll - go 2 = return BloomUpdateP2PubKeyOnly - go _ = fail "BloomFlags get: Invalid bloom flag" - - put f = putWord8 $ case f of - BloomUpdateNone -> 0 - BloomUpdateAll -> 1 - BloomUpdateP2PubKeyOnly -> 2 - --- | 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 - { 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 Serialize BloomFilter where - - get = BloomFilter <$> (S.fromList <$> (readDat =<< get)) - <*> getWord32le <*> getWord32le - <*> get - where - readDat (VarInt len) = replicateM (fromIntegral len) getWord8 - - put (BloomFilter dat hashFuncs tweak flags) = do - putVarInt $ S.length dat - forM_ (F.toList dat) putWord8 - putWord32le hashFuncs - putWord32le tweak - put flags - --- | Set a new bloom filter on the peer connection. -newtype FilterLoad = FilterLoad { filterLoadBloomFilter :: BloomFilter } - deriving (Eq, Show, Read, Generic, NFData) - -instance Serialize FilterLoad where - get = FilterLoad <$> get - put (FilterLoad f) = put f - --- | 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 Serialize FilterAdd where - get = do - (VarInt len) <- get - dat <- getByteString $ fromIntegral len - return $ FilterAdd dat - - put (FilterAdd bs) = do - putVarInt $ BS.length bs - putByteString bs - - --- | Build a bloom filter that will provide the given false positive rate when --- the given number of elements have been inserted. -bloomCreate :: Int -- ^ number of elements - -> Double -- ^ false positive rate - -> Word32 -- ^ random nonce (tweak) for the hash function - -> BloomFlags -- ^ bloom filter flags - -> BloomFilter -- ^ bloom filter -bloomCreate numElem fpRate = - BloomFilter (S.replicate bloomSize 0) numHashF - where - -- Bloom filter size in bytes - bloomSize = truncate $ min a b / 8 - -- Suggested size in bits - a = -1 / ln2Squared * fromIntegral numElem * log fpRate - -- Maximum size in bits - b = fromIntegral $ maxBloomSize * 8 - numHashF = truncate $ min c (fromIntegral maxHashFuncs) - -- 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. -bloomInsert :: BloomFilter -- ^ Original bloom filter - -> ByteString -- ^ New data to insert - -> BloomFilter -- ^ Bloom filter containing the new data -bloomInsert bfilter bs - | isBloomFull bfilter = bfilter - | otherwise = bfilter { bloomData = newData } - where - idxs = map (\i -> bloomHash bfilter i bs) [0..bloomHashFuncs bfilter - 1] - upd s i = S.adjust (.|. bitMask !! fromIntegral (7 .&. i)) - (fromIntegral $ i `shiftR` 3) 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. -bloomContains :: BloomFilter -- ^ Bloom filter - -> ByteString - -- ^ Data that will be checked against the given bloom filter - -> Bool - -- ^ Returns True if the data matches the filter -bloomContains bfilter bs - | isBloomFull bfilter = True - | isBloomEmpty bfilter = False - | otherwise = all isSet idxs - where - s = bloomData bfilter - 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 - --- | 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 :: BloomFilter - -- ^ Bloom filter - -> Tx - -- ^ Tx that may (or may not) have relevant outputs - -> Maybe BloomFilter - -- ^ Returns an updated bloom filter adding relevant output -bloomRelevantUpdate bfilter tx - | isBloomFull bfilter || isBloomEmpty bfilter = Nothing - | bloomFlags bfilter == BloomUpdateNone = Nothing - | length matchOuts > 0 = Just $ foldl' (addRelevant) bfilter matchOuts - | otherwise = Nothing - where - -- TxHash if we end up inserting an outpoint - h = txHash tx - -- Decode the scriptOutpus and add vOuts in case we make them outpoints - decodedOutputScripts = traverse (decodeOutputBS . scriptOutput) $ txOut tx - err = error $ "Error Decoding output script" - idxOutputScripts = either (const err) (zip [0..]) decodedOutputScripts - -- Check if any txOuts were contained in the bloom filter - matchFilter = filter (\(_,op) -> bloomContains bfilter $ encodeScriptOut op) - matchOuts = matchFilter idxOutputScripts - - addRelevant :: BloomFilter -> (Word32,ScriptOutput) -> BloomFilter - addRelevant bfilter (id,scriptOut) = case (bloomFlags bfilter,scriptType) of - -- We filtered out BloomUpdateNone so we insert any PayPk or PayMulSig - (_, True) -> bloomInsert bfilter outpoint - (BloomUpdateAll, _ ) -> bloomInsert bfilter outpoint - _ -> error "Error Updating Bloom Filter with relevant outpoint" - where - outpoint = encode $ OutPoint{ outPointHash = h, outPointIndex = id} - scriptType = (\s -> isPayPK s ||isPayMulSig s) scriptOut - - -- Encodes a scriptOutput so it can be checked agains the Bloom Filter - encodeScriptOut :: ScriptOutput -> ByteString - encodeScriptOut (PayMulSig outputMuSig _) = encode outputMuSig - encodeScriptOut (PayWitnessScriptHash scriptHash) = encode scriptHash - encodeScriptOut (DataCarrier getOutputData) = encode getOutputData - encodeScriptOut outputHash = (encode . 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 :: BloomFilter -- ^ Bloom filter to test - -> Bool -- ^ True if the given filter is valid -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/Network/Haskoin/Network/Common.hs b/src/Network/Haskoin/Network/Common.hs deleted file mode 100644 --- a/src/Network/Haskoin/Network/Common.hs +++ /dev/null @@ -1,613 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-| -Module : Network.Haskoin.Network.Common -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Common functions and data types related to peer-to-peer network. --} -module Network.Haskoin.Network.Common - ( -- * Network Data Types - Addr(..) - , NetworkAddressTime - , Alert(..) - , GetData(..) - , Inv(..) - , InvVector(..) - , InvType(..) - , HostAddress - , hostToSockAddr - , sockToHostAddress - , NetworkAddress(..) - , NotFound(..) - , Ping(..) - , Pong(..) - , Reject(..) - , RejectCode(..) - , VarInt(..) - , VarString(..) - , Version(..) - , MessageCommand(..) - -- ** Useful Functions - , reject - , nodeNone - , nodeNetwork - , nodeGetUTXO - , nodeBloom - , nodeWitness - , nodeXThin - , commandToString - , stringToCommand - , putVarInt - ) where - -import Control.DeepSeq -import Control.Monad (forM_, liftM2, replicateM, unless) -import Data.Bits (shiftL) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.ByteString.Char8 as C (replicate) -import Data.Serialize as S -import Data.String -import Data.String.Conversions (cs) -import Data.Word (Word32, Word64) -import GHC.Generics (Generic) -import Network.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. -newtype Addr = - Addr { -- List of addresses of other nodes on the network with timestamps. - addrList :: [NetworkAddressTime] - } - deriving (Eq, Show, Generic, NFData) - -instance Serialize Addr where - - get = Addr <$> (repList =<< S.get) - where - repList (VarInt c) = replicateM (fromIntegral c) action - action = liftM2 (,) getWord32le S.get - - put (Addr xs) = do - putVarInt $ length xs - forM_ xs $ \(a,b) -> putWord32le a >> put b - --- | Data type describing signed messages that can be sent between bitcoin --- nodes to display important notifications to end users about the health of --- the network. -data Alert = - Alert { - -- | Alert payload. - alertPayload :: !VarString - -- | ECDSA signature of the payload - , alertSignature :: !VarString - } deriving (Eq, Show, Read, Generic, NFData) - -instance Serialize Alert where - get = Alert <$> S.get <*> S.get - put (Alert p s) = put p >> put s - --- | The 'GetData' type is used to retrieve information on a specific object --- ('Block' or 'Tx') identified by the objects hash. The payload of a 'GetData' --- request is a list of 'InvVector' which represent all the hashes of objects --- that a node wants. The response to a 'GetBlock' message will be either a --- 'Block' or a 'Tx' message depending on the type of the object referenced by --- the hash. Usually, 'GetData' messages are sent after a node receives an 'Inv' --- message that contains unknown object hashes. -newtype GetData = - GetData { -- | list of object hashes - getDataList :: [InvVector] - } deriving (Eq, Show, Generic, NFData) - -instance Serialize GetData where - - get = GetData <$> (repList =<< S.get) - where - repList (VarInt c) = replicateM (fromIntegral c) S.get - - put (GetData xs) = do - putVarInt $ length xs - forM_ xs put - --- | 'Inv' messages are used by nodes to advertise their knowledge of new --- objects by publishing a list of hashes to a peer. 'Inv' messages can be sent --- unsolicited or in response to a 'GetBlocks' message. -newtype Inv = - Inv { - -- | inventory - invList :: [InvVector] - } deriving (Eq, Show, Generic, NFData) - -instance Serialize Inv where - - get = Inv <$> (repList =<< S.get) - where - repList (VarInt c) = replicateM (fromIntegral c) S.get - - put (Inv xs) = do - putVarInt $ length xs - forM_ xs put - --- | Data type identifying the type of an inventory vector. SegWit types are --- only used in 'GetData' messages, not 'Inv'. -data InvType - = InvError -- ^ error - | InvTx -- ^ transaction - | InvBlock -- ^ block - | InvMerkleBlock -- ^ filtered block - | InvWitnessTx -- ^ segwit transaction - | InvWitnessBlock -- ^ segwit block - | InvWitnessMerkleBlock -- ^ segwit filtere block - deriving (Eq, Show, Read, Generic, NFData) - -instance Serialize InvType where - get = go =<< getWord32le - where - go x = - case x of - 0 -> return InvError - 1 -> return InvTx - 2 -> return InvBlock - 3 -> return InvMerkleBlock - _ - | x == 1 `shiftL` 30 + 1 -> return InvWitnessTx - | x == 1 `shiftL` 30 + 2 -> return InvWitnessBlock - | x == 1 `shiftL` 30 + 3 -> return InvWitnessMerkleBlock - | otherwise -> fail "bitcoinGet InvType: Invalid Type" - put x = - putWord32le $ - case x of - InvError -> 0 - InvTx -> 1 - InvBlock -> 2 - InvMerkleBlock -> 3 - InvWitnessTx -> 1 `shiftL` 30 + 1 - InvWitnessBlock -> 1 `shiftL` 30 + 2 - InvWitnessMerkleBlock -> 1 `shiftL` 30 + 3 - --- | Invectory vectors represent hashes identifying objects such as a 'Block' or --- a 'Tx'. They notify other peers about new data or data they have otherwise --- requested. -data InvVector = - InvVector { - -- | type of object - invType :: !InvType - -- | 256-bit hash of object - , invHash :: !Hash256 - } deriving (Eq, Show, Generic, NFData) - -instance Serialize InvVector where - get = InvVector <$> S.get <*> S.get - put (InvVector t h) = put t >> put h - -newtype HostAddress = - HostAddress ByteString - deriving (Eq, Show, Ord, Generic, NFData) - -instance Serialize HostAddress where - put (HostAddress bs) = putByteString bs - get = HostAddress <$> getByteString 18 - --- | Data type describing a bitcoin network address. Addresses are stored in --- IPv6 format. IPv4 addresses are mapped to IPv6 using IPv4 mapped IPv6 --- addresses: . -data NetworkAddress = - NetworkAddress { -- | bitmask of services available for this address - naServices :: !Word64 - -- | address and port information - , naAddress :: !HostAddress - } deriving (Eq, Show, Generic, NFData) - -hostToSockAddr :: HostAddress -> SockAddr -hostToSockAddr (HostAddress bs) = - case runGet getSockAddr bs of - Left e -> error e - Right x -> x - -sockToHostAddress :: SockAddr -> HostAddress -sockToHostAddress = HostAddress . runPut . putSockAddr - -putSockAddr :: SockAddr -> Put -putSockAddr (SockAddrInet6 p _ (a, b, c, d) _) = do - putWord32be a - putWord32be b - putWord32be c - putWord32be d - putWord16be (fromIntegral p) - -putSockAddr (SockAddrInet p a) = do - putWord32be 0x00000000 - putWord32be 0x00000000 - putWord32be 0x0000ffff - putWord32host a - putWord16be (fromIntegral p) - -putSockAddr _ = error "Invalid address type" - -getSockAddr :: Get SockAddr -getSockAddr = do - a <- getWord32be - b <- getWord32be - c <- getWord32be - if a == 0x00000000 && b == 0x00000000 && c == 0x0000ffff - then do - d <- getWord32host - p <- getWord16be - return $ SockAddrInet (fromIntegral p) d - else do - d <- getWord32be - p <- getWord16be - return $ SockAddrInet6 (fromIntegral p) 0 (a, b, c, d) 0 - -instance Serialize NetworkAddress where - get = NetworkAddress <$> getWord64le <*> S.get - put (NetworkAddress s a) = putWord64le s >> put a - --- | A 'NotFound' message is returned as a response to a 'GetData' message --- whe one of the requested objects could not be retrieved. This could happen, --- for example, if a tranasaction was requested and was not available in the --- memory pool of the receiving node. -newtype NotFound = - NotFound { -- | Inventory vectors related to this request - notFoundList :: [InvVector] - } deriving (Eq, Show, Generic, NFData) - -instance Serialize NotFound where - - get = NotFound <$> (repList =<< S.get) - where - repList (VarInt c) = replicateM (fromIntegral c) S.get - - put (NotFound xs) = do - putVarInt $ length xs - forM_ xs put - --- | A 'Ping' message is sent to bitcoin peers to check if a connection is still --- open. -newtype Ping = - Ping { -- | A random nonce used to identify the recipient of the ping - -- request once a Pong response is received. - pingNonce :: Word64 - } deriving (Eq, Show, Read, Generic, NFData) - --- | A Pong message is sent as a response to a ping message. -newtype Pong = - Pong { - -- | nonce from corresponding 'Ping' - pongNonce :: Word64 - } deriving (Eq, Show, Read, Generic, NFData) - -instance Serialize Ping where - get = Ping <$> getWord64le - put (Ping n) = putWord64le n - -instance Serialize Pong where - get = Pong <$> getWord64le - put (Pong n) = putWord64le n - --- | The 'Reject' message is sent when messages are rejected by a peer. -data Reject = - Reject { - -- | type of message rejected - rejectMessage :: !MessageCommand - -- | rejection code - , rejectCode :: !RejectCode - -- | text reason for rejection - , rejectReason :: !VarString - -- | extra data such as block or tx hash - , rejectData :: !ByteString - } deriving (Eq, Show, Read, Generic, NFData) - --- | Rejection code associated to the 'Reject' message. -data RejectCode - = RejectMalformed - | RejectInvalid - | RejectObsolete - | RejectDuplicate - | RejectNonStandard - | RejectDust - | RejectInsufficientFee - | RejectCheckpoint - deriving (Eq, Show, Read, Generic, NFData) - -instance Serialize RejectCode where - - get = getWord8 >>= \code -> case code of - 0x01 -> return RejectMalformed - 0x10 -> return RejectInvalid - 0x11 -> return RejectObsolete - 0x12 -> return RejectDuplicate - 0x40 -> return RejectNonStandard - 0x41 -> return RejectDust - 0x42 -> return RejectInsufficientFee - 0x43 -> return RejectCheckpoint - _ -> fail $ unwords - [ "Reject get: Invalid code" - , show code - ] - - put code = putWord8 $ case code of - RejectMalformed -> 0x01 - RejectInvalid -> 0x10 - RejectObsolete -> 0x11 - RejectDuplicate -> 0x12 - RejectNonStandard -> 0x40 - RejectDust -> 0x41 - RejectInsufficientFee -> 0x42 - RejectCheckpoint -> 0x43 - --- | Convenience function to build a 'Reject' message. -reject :: MessageCommand -> RejectCode -> ByteString -> Reject -reject cmd code reason = - Reject cmd code (VarString reason) B.empty - -instance Serialize Reject where - get = - S.get >>= \(VarString bs) -> - Reject (stringToCommand bs) <$> S.get <*> S.get <*> maybeData - where - maybeData = - isEmpty >>= \done -> - if done - then return B.empty - else getByteString 32 - put (Reject cmd code reason dat) = do - put $ VarString $ commandToString cmd - put code - put reason - unless (B.null dat) $ putByteString dat - --- | 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 Serialize VarInt where - - get = VarInt <$> ( getWord8 >>= go ) - where - go 0xff = getWord64le - go 0xfe = fromIntegral <$> getWord32le - go 0xfd = fromIntegral <$> getWord16le - go x = fromIntegral <$> return x - - put (VarInt x) - | x < 0xfd = - putWord8 $ fromIntegral x - | x <= 0xffff = do - putWord8 0xfd - putWord16le $ fromIntegral x - | x <= 0xffffffff = do - putWord8 0xfe - putWord32le $ fromIntegral x - | otherwise = do - putWord8 0xff - putWord64le x - -putVarInt :: Integral a => a -> Put -putVarInt = put . VarInt . fromIntegral - --- | Data type for serialization of variable-length strings. -newtype VarString = VarString { getVarString :: ByteString } - deriving (Eq, Show, Read, Generic, NFData) - -instance Serialize VarString where - - get = VarString <$> (readBS =<< S.get) - where - readBS (VarInt len) = getByteString (fromIntegral len) - - put (VarString bs) = do - putVarInt $ B.length bs - putByteString bs - --- | When a bitcoin node creates an outgoing connection to another node, --- the first message it will send is a 'Version' message. The other node --- will similarly respond with it's own 'Version' message. -data Version = - Version { - -- | protocol version - version :: !Word32 - -- | features supported by this connection - , services :: !Word64 - -- | unix timestamp - , timestamp :: !Word64 - -- | network address of remote node - , addrRecv :: !NetworkAddress - -- | network address of sending node - , addrSend :: !NetworkAddress - -- | random nonce to detect connection to self - , verNonce :: !Word64 - -- | user agent string - , userAgent :: !VarString - -- | height of the last block in sending node - , startHeight :: !Word32 - -- | relay transactions flag (BIP-37) - , relay :: !Bool - } deriving (Eq, Show, Generic, NFData) - -instance Serialize Version where - - get = Version <$> getWord32le - <*> getWord64le - <*> getWord64le - <*> S.get - <*> S.get - <*> getWord64le - <*> S.get - <*> getWord32le - <*> (go =<< isEmpty) - where - go True = return True - go False = getBool - - put (Version v s t ar as n ua sh r) = do - putWord32le v - putWord64le s - putWord64le t - put ar - put as - putWord64le n - put ua - putWord32le sh - putBool r - --- | 0x00 is 'False', anything else is 'True'. -getBool :: Get Bool -getBool = go =<< getWord8 - where - go 0 = return False - go _ = return True - -putBool :: Bool -> Put -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. -data MessageCommand - = MCVersion - | MCVerAck - | MCAddr - | MCInv - | MCGetData - | MCNotFound - | MCGetBlocks - | MCGetHeaders - | MCTx - | MCBlock - | MCMerkleBlock - | MCHeaders - | MCGetAddr - | MCFilterLoad - | MCFilterAdd - | MCFilterClear - | MCPing - | MCPong - | MCAlert - | MCMempool - | MCReject - | MCSendHeaders - | MCOther ByteString - deriving (Eq, Generic, NFData) - -instance Show MessageCommand where - showsPrec _ = shows . commandToString - -instance Read MessageCommand where - readPrec = do - String str <- lexP - return (stringToCommand (cs str)) - -instance Serialize MessageCommand where - get = go <$> getByteString 12 - where - go bs = - let str = unpackCommand bs - in stringToCommand str - put mc = putByteString $ packCommand $ commandToString mc - -instance IsString MessageCommand where - fromString str = stringToCommand (cs str) - --- | Read a 'MessageCommand' from its string representation. -stringToCommand :: ByteString -> MessageCommand -stringToCommand str = case str of - "version" -> MCVersion - "verack" -> MCVerAck - "addr" -> MCAddr - "inv" -> MCInv - "getdata" -> MCGetData - "notfound" -> MCNotFound - "getblocks" -> MCGetBlocks - "getheaders" -> MCGetHeaders - "tx" -> MCTx - "block" -> MCBlock - "merkleblock" -> MCMerkleBlock - "headers" -> MCHeaders - "getaddr" -> MCGetAddr - "filterload" -> MCFilterLoad - "filteradd" -> MCFilterAdd - "filterclear" -> MCFilterClear - "ping" -> MCPing - "pong" -> MCPong - "alert" -> MCAlert - "mempool" -> MCMempool - "reject" -> MCReject - "sendheaders" -> MCSendHeaders - _ -> MCOther str - --- | Convert a 'MessageCommand' to its string representation. -commandToString :: MessageCommand -> ByteString -commandToString mc = case mc of - MCVersion -> "version" - MCVerAck -> "verack" - MCAddr -> "addr" - MCInv -> "inv" - MCGetData -> "getdata" - MCNotFound -> "notfound" - MCGetBlocks -> "getblocks" - MCGetHeaders -> "getheaders" - MCTx -> "tx" - MCBlock -> "block" - MCMerkleBlock -> "merkleblock" - MCHeaders -> "headers" - MCGetAddr -> "getaddr" - MCFilterLoad -> "filterload" - MCFilterAdd -> "filteradd" - MCFilterClear -> "filterclear" - MCPing -> "ping" - MCPong -> "pong" - MCAlert -> "alert" - MCMempool -> "mempool" - MCReject -> "reject" - MCSendHeaders -> "sendheaders" - MCOther c -> c - --- | 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/Network/Haskoin/Network/Message.hs b/src/Network/Haskoin/Network/Message.hs deleted file mode 100644 --- a/src/Network/Haskoin/Network/Message.hs +++ /dev/null @@ -1,203 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-| -Module : Network.Haskoin.Network.Message -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Peer-to-peer network message serialization. --} -module Network.Haskoin.Network.Message - ( -- * Network Message - Message(..) - , MessageHeader(..) - , msgType - , putMessage - , getMessage - ) where - -import Control.Monad (unless) -import Control.DeepSeq -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.Serialize (Serialize, encode, get, - put) -import Data.Serialize.Get (Get, getByteString, - getWord32be, getWord32le, - isolate, lookAhead) -import Data.Serialize.Put (Putter, putByteString, - putWord32be, putWord32le) -import Data.Word (Word32) -import GHC.Generics (Generic) -import Network.Haskoin.Block.Common -import Network.Haskoin.Block.Merkle -import Network.Haskoin.Constants -import Network.Haskoin.Crypto.Hash -import Network.Haskoin.Network.Bloom -import Network.Haskoin.Network.Common -import Network.Haskoin.Transaction.Common - --- | Data type representing the header of a 'Message'. All messages sent between --- nodes contain a message header. -data MessageHeader = MessageHeader - { -- | magic bytes identify network - headMagic :: !Word32 - -- | message type - , headCmd :: !MessageCommand - -- | length of payload - , headPayloadSize :: !Word32 - -- | checksum of payload - , headChecksum :: !CheckSum32 - } deriving (Eq, Show, Generic, NFData) - -instance Serialize MessageHeader where - - get = MessageHeader <$> getWord32be - <*> get - <*> getWord32le - <*> get - - put (MessageHeader m c l chk) = do - putWord32be m - put c - putWord32le l - put chk - --- | The 'Message' type is used to identify all the valid messages that can be --- sent between bitcoin peers. Only values of type 'Message' will be accepted --- by other bitcoin peers as bitcoin protocol messages need to be correctly --- serialized with message headers. Serializing a 'Message' value will --- include the 'MessageHeader' with the correct checksum value automatically. --- No need to add the 'MessageHeader' separately. -data Message - = MVersion !Version - | MVerAck - | MAddr !Addr - | MInv !Inv - | MGetData !GetData - | MNotFound !NotFound - | MGetBlocks !GetBlocks - | MGetHeaders !GetHeaders - | MTx !Tx - | MBlock !Block - | MMerkleBlock !MerkleBlock - | MHeaders !Headers - | MGetAddr - | MFilterLoad !FilterLoad - | MFilterAdd !FilterAdd - | MFilterClear - | MPing !Ping - | MPong !Pong - | MAlert !Alert - | MMempool - | MReject !Reject - | MSendHeaders - | MOther !ByteString !ByteString - deriving (Eq, Show, Generic, NFData) - --- | Get 'MessageCommand' assocated with a message. -msgType :: Message -> MessageCommand -msgType (MVersion _) = MCVersion -msgType MVerAck = MCVerAck -msgType (MAddr _) = MCAddr -msgType (MInv _) = MCInv -msgType (MGetData _) = MCGetData -msgType (MNotFound _) = MCNotFound -msgType (MGetBlocks _) = MCGetBlocks -msgType (MGetHeaders _) = MCGetHeaders -msgType (MTx _) = MCTx -msgType (MBlock _) = MCBlock -msgType (MMerkleBlock _) = MCMerkleBlock -msgType (MHeaders _) = MCHeaders - -msgType (MFilterLoad _) = MCFilterLoad -msgType (MFilterAdd _) = MCFilterAdd -msgType MFilterClear = MCFilterClear -msgType (MPing _) = MCPing -msgType (MPong _) = MCPong -msgType (MAlert _) = MCAlert -msgType MMempool = MCMempool -msgType (MReject _) = MCReject -msgType MSendHeaders = MCSendHeaders -msgType MGetAddr = MCGetAddr -msgType (MOther c _) = MCOther c - --- | Deserializer for network messages. -getMessage :: Network -> Get Message -getMessage net = do - (MessageHeader mgc cmd len chk) <- get - bs <- lookAhead $ getByteString $ fromIntegral len - unless - (mgc == getNetworkMagic net) - (fail $ "get: Invalid network magic bytes: " ++ show mgc) - unless - (checkSum32 bs == chk) - (fail $ "get: Invalid message checksum: " ++ show chk) - if len > 0 - then isolate (fromIntegral len) $ - case cmd of - MCVersion -> MVersion <$> get - MCAddr -> MAddr <$> get - MCInv -> MInv <$> get - MCGetData -> MGetData <$> get - MCNotFound -> MNotFound <$> get - MCGetBlocks -> MGetBlocks <$> get - MCGetHeaders -> MGetHeaders <$> get - MCTx -> MTx <$> get - MCBlock -> MBlock <$> get - MCMerkleBlock -> MMerkleBlock <$> get - MCHeaders -> MHeaders <$> get - MCFilterLoad -> MFilterLoad <$> get - MCFilterAdd -> MFilterAdd <$> get - MCPing -> MPing <$> get - MCPong -> MPong <$> get - MCAlert -> MAlert <$> get - MCReject -> MReject <$> get - MCOther c -> MOther c <$> getByteString (fromIntegral len) - _ -> fail $ "get: command " ++ show cmd ++ - " should not carry a payload" - else case cmd of - MCGetAddr -> return MGetAddr - MCVerAck -> return MVerAck - MCFilterClear -> return MFilterClear - MCMempool -> return MMempool - MCSendHeaders -> return MSendHeaders - _ -> fail $ "get: command " ++ show cmd ++ - " is expected to carry a payload" - --- | Serializer for network messages. -putMessage :: Network -> Putter Message -putMessage net msg = do - let (cmd, payload) = - case msg of - MVersion m -> (MCVersion, encode m) - MVerAck -> (MCVerAck, BS.empty) - MAddr m -> (MCAddr, encode m) - MInv m -> (MCInv, encode m) - MGetData m -> (MCGetData, encode m) - MNotFound m -> (MCNotFound, encode m) - MGetBlocks m -> (MCGetBlocks, encode m) - MGetHeaders m -> (MCGetHeaders, encode m) - MTx m -> (MCTx, encode m) - MBlock m -> (MCBlock, encode m) - MMerkleBlock m -> (MCMerkleBlock, encode m) - MHeaders m -> (MCHeaders, encode m) - MGetAddr -> (MCGetAddr, BS.empty) - MFilterLoad m -> (MCFilterLoad, encode m) - MFilterAdd m -> (MCFilterAdd, encode m) - MFilterClear -> (MCFilterClear, BS.empty) - MPing m -> (MCPing, encode m) - MPong m -> (MCPong, encode m) - MAlert m -> (MCAlert, encode m) - MMempool -> (MCMempool, BS.empty) - MReject m -> (MCReject, encode m) - MSendHeaders -> (MCSendHeaders, BS.empty) - MOther c p -> (MCOther c, p) - chk = checkSum32 payload - len = fromIntegral $ BS.length payload - header = MessageHeader (getNetworkMagic net) cmd len chk - put header - putByteString payload diff --git a/src/Network/Haskoin/Script.hs b/src/Network/Haskoin/Script.hs deleted file mode 100644 --- a/src/Network/Haskoin/Script.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-| -Module : Network.Haskoin.Script -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -This module provides functions for parsing and evaluating bitcoin -transaction scripts. Data types are provided for building and -deconstructing all of the standard input and output script types. --} -module Network.Haskoin.Script - ( module X - ) where - -import Network.Haskoin.Script.Common as X -import Network.Haskoin.Script.SigHash as X -import Network.Haskoin.Script.Standard as X diff --git a/src/Network/Haskoin/Script/Common.hs b/src/Network/Haskoin/Script/Common.hs deleted file mode 100644 --- a/src/Network/Haskoin/Script/Common.hs +++ /dev/null @@ -1,731 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-| -Module : Network.Haskoin.Script.Common -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Common script-related functions and data types. --} -module Network.Haskoin.Script.Common - ( ScriptOp(..) - , Script(..) - , PushDataType(..) - , ScriptOutput(..) - , isPayPK - , isPayPKHash - , isPayMulSig - , isPayScriptHash - , isPayWitnessPKHash - , isPayWitnessScriptHash - , isDataCarrier - , encodeOutput - , encodeOutputBS - , decodeOutput - , decodeOutputBS - , toP2SH - , toP2WSH - , isPushOp - , opPushData - , intToScriptOp - , scriptOpToInt - ) where - -import Control.DeepSeq -import Control.Monad -import Data.Aeson as A -import Data.Aeson.Encoding (text) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Hashable -import Data.Serialize as S -import Data.Word (Word8) -import GHC.Generics (Generic) -import Network.Haskoin.Crypto.Hash -import Network.Haskoin.Keys.Common -import Network.Haskoin.Util - --- | Data type representing a transaction script. Scripts are defined as lists --- of script operators 'ScriptOp'. Scripts are used to: --- --- * Define the spending conditions in the output of a transaction. --- * Provide signatures in the input of a transaction (except SegWit). --- --- SigWit only: the segregated witness data structure, and not the input script, --- contains signatures and redeem script for pay-to-witness-script and --- pay-to-witness-public-key-hash transactions. -newtype Script = - Script { - -- | script operators defining this script - scriptOps :: [ScriptOp] - } - deriving (Eq, Show, Read, Generic, Hashable, NFData) - -instance Serialize Script where - get = - Script <$> getScriptOps - where - getScriptOps = do - empty <- isEmpty - if empty - then return [] - else (:) <$> get <*> getScriptOps - - put (Script ops) = forM_ ops put - --- | Data type representing the type of an OP_PUSHDATA opcode. -data PushDataType - = - -- | next opcode bytes is data to be pushed - OPCODE - -- | next byte contains number of bytes of data to be pushed - | OPDATA1 - -- | next two bytes contains number of bytes to be pushed - | OPDATA2 - -- | next four bytes contains the number of bytes to be pushed - | OPDATA4 - deriving (Show, Read, Eq, Generic, Hashable, NFData) - --- | Data type representing an operator allowed inside a 'Script'. -data ScriptOp - -- Pushing Data - = OP_PUSHDATA !ByteString - !PushDataType - | OP_0 - | OP_1NEGATE - | OP_RESERVED - | OP_1 - | OP_2 - | OP_3 - | OP_4 - | OP_5 - | OP_6 - | OP_7 - | OP_8 - | OP_9 - | OP_10 - | OP_11 - | OP_12 - | OP_13 - | OP_14 - | OP_15 - | OP_16 - -- Flow control - | OP_NOP - | OP_VER -- reserved - | OP_IF - | OP_NOTIF - | OP_VERIF -- resreved - | OP_VERNOTIF -- reserved - | OP_ELSE - | OP_ENDIF - | OP_VERIFY - | OP_RETURN - -- Stack operations - | OP_TOALTSTACK - | OP_FROMALTSTACK - | OP_IFDUP - | OP_DEPTH - | OP_DROP - | OP_DUP - | OP_NIP - | OP_OVER - | OP_PICK - | OP_ROLL - | OP_ROT - | OP_SWAP - | OP_TUCK - | OP_2DROP - | OP_2DUP - | OP_3DUP - | OP_2OVER - | OP_2ROT - | OP_2SWAP - -- Splice - | OP_CAT - | OP_SUBSTR - | OP_LEFT - | OP_RIGHT - | OP_SIZE - -- Bitwise logic - | OP_INVERT - | OP_AND - | OP_OR - | OP_XOR - | OP_EQUAL - | OP_EQUALVERIFY - | OP_RESERVED1 - | OP_RESERVED2 - -- Arithmetic - | OP_1ADD - | OP_1SUB - | OP_2MUL - | OP_2DIV - | OP_NEGATE - | OP_ABS - | OP_NOT - | OP_0NOTEQUAL - | OP_ADD - | OP_SUB - | OP_MUL - | OP_DIV - | OP_MOD - | OP_LSHIFT - | OP_RSHIFT - | OP_BOOLAND - | OP_BOOLOR - | OP_NUMEQUAL - | OP_NUMEQUALVERIFY - | OP_NUMNOTEQUAL - | OP_LESSTHAN - | OP_GREATERTHAN - | OP_LESSTHANOREQUAL - | OP_GREATERTHANOREQUAL - | OP_MIN - | OP_MAX - | OP_WITHIN - -- Crypto - | OP_RIPEMD160 - | OP_SHA1 - | OP_SHA256 - | OP_HASH160 - | OP_HASH256 - | OP_CODESEPARATOR - | OP_CHECKSIG - | OP_CHECKSIGVERIFY - | OP_CHECKMULTISIG - | OP_CHECKMULTISIGVERIFY - -- Expansion - | OP_NOP1 - | OP_NOP2 - | OP_NOP3 - | OP_NOP4 - | OP_NOP5 - | OP_NOP6 - | OP_NOP7 - | OP_NOP8 - | OP_NOP9 - | OP_NOP10 - -- Bitcoin Cash Nov 2018 hard fork - | OP_CHECKDATASIG - | OP_CHECKDATASIGVERIFY - -- Other - | OP_PUBKEYHASH - | OP_PUBKEY - | OP_INVALIDOPCODE !Word8 - deriving (Show, Read, Eq, Generic, Hashable, NFData) - -instance Serialize ScriptOp where - get = go =<< (fromIntegral <$> getWord8) - where - go op - | op == 0x00 = return OP_0 - | op <= 0x4b = do - payload <- getByteString (fromIntegral op) - return $ OP_PUSHDATA payload OPCODE - | op == 0x4c = do - len <- getWord8 - payload <- getByteString (fromIntegral len) - return $ OP_PUSHDATA payload OPDATA1 - | op == 0x4d = do - len <- getWord16le - payload <- getByteString (fromIntegral len) - return $ OP_PUSHDATA payload OPDATA2 - | op == 0x4e = do - len <- getWord32le - payload <- getByteString (fromIntegral len) - return $ OP_PUSHDATA payload OPDATA4 - - | op == 0x4f = return OP_1NEGATE - | op == 0x50 = return OP_RESERVED - | op == 0x51 = return OP_1 - | op == 0x52 = return OP_2 - | op == 0x53 = return OP_3 - | op == 0x54 = return OP_4 - | op == 0x55 = return OP_5 - | op == 0x56 = return OP_6 - | op == 0x57 = return OP_7 - | op == 0x58 = return OP_8 - | op == 0x59 = return OP_9 - | op == 0x5a = return OP_10 - | op == 0x5b = return OP_11 - | op == 0x5c = return OP_12 - | op == 0x5d = return OP_13 - | op == 0x5e = return OP_14 - | op == 0x5f = return OP_15 - | op == 0x60 = return OP_16 - - -- Flow control - | op == 0x61 = return OP_NOP - | op == 0x62 = return OP_VER -- reserved - | op == 0x63 = return OP_IF - | op == 0x64 = return OP_NOTIF - | op == 0x65 = return OP_VERIF -- reserved - | op == 0x66 = return OP_VERNOTIF -- reserved - | op == 0x67 = return OP_ELSE - | op == 0x68 = return OP_ENDIF - | op == 0x69 = return OP_VERIFY - | op == 0x6a = return OP_RETURN - - -- Stack - | op == 0x6b = return OP_TOALTSTACK - | op == 0x6c = return OP_FROMALTSTACK - | op == 0x6d = return OP_2DROP - | op == 0x6e = return OP_2DUP - | op == 0x6f = return OP_3DUP - | op == 0x70 = return OP_2OVER - | op == 0x71 = return OP_2ROT - | op == 0x72 = return OP_2SWAP - | op == 0x73 = return OP_IFDUP - | op == 0x74 = return OP_DEPTH - | op == 0x75 = return OP_DROP - | op == 0x76 = return OP_DUP - | op == 0x77 = return OP_NIP - | op == 0x78 = return OP_OVER - | op == 0x79 = return OP_PICK - | op == 0x7a = return OP_ROLL - | op == 0x7b = return OP_ROT - | op == 0x7c = return OP_SWAP - | op == 0x7d = return OP_TUCK - - -- Splice - | op == 0x7e = return OP_CAT - | op == 0x7f = return OP_SUBSTR - | op == 0x80 = return OP_LEFT - | op == 0x81 = return OP_RIGHT - | op == 0x82 = return OP_SIZE - - -- Bitwise logic - | op == 0x83 = return OP_INVERT - | op == 0x84 = return OP_AND - | op == 0x85 = return OP_OR - | op == 0x86 = return OP_XOR - | op == 0x87 = return OP_EQUAL - | op == 0x88 = return OP_EQUALVERIFY - | op == 0x89 = return OP_RESERVED1 - | op == 0x8a = return OP_RESERVED2 - - -- Arithmetic - | op == 0x8b = return OP_1ADD - | op == 0x8c = return OP_1SUB - | op == 0x8d = return OP_2MUL - | op == 0x8e = return OP_2DIV - | op == 0x8f = return OP_NEGATE - | op == 0x90 = return OP_ABS - | op == 0x91 = return OP_NOT - | op == 0x92 = return OP_0NOTEQUAL - | op == 0x93 = return OP_ADD - | op == 0x94 = return OP_SUB - | op == 0x95 = return OP_MUL - | op == 0x96 = return OP_DIV - | op == 0x97 = return OP_MOD - | op == 0x98 = return OP_LSHIFT - | op == 0x99 = return OP_RSHIFT - | op == 0x9a = return OP_BOOLAND - | op == 0x9b = return OP_BOOLOR - | op == 0x9c = return OP_NUMEQUAL - | op == 0x9d = return OP_NUMEQUALVERIFY - | op == 0x9e = return OP_NUMNOTEQUAL - | op == 0x9f = return OP_LESSTHAN - | op == 0xa0 = return OP_GREATERTHAN - | op == 0xa1 = return OP_LESSTHANOREQUAL - | op == 0xa2 = return OP_GREATERTHANOREQUAL - | op == 0xa3 = return OP_MIN - | op == 0xa4 = return OP_MAX - | op == 0xa5 = return OP_WITHIN - - -- Crypto - | op == 0xa6 = return OP_RIPEMD160 - | op == 0xa7 = return OP_SHA1 - | op == 0xa8 = return OP_SHA256 - | op == 0xa9 = return OP_HASH160 - | op == 0xaa = return OP_HASH256 - | op == 0xab = return OP_CODESEPARATOR - | op == 0xac = return OP_CHECKSIG - | op == 0xad = return OP_CHECKSIGVERIFY - | op == 0xae = return OP_CHECKMULTISIG - | op == 0xaf = return OP_CHECKMULTISIGVERIFY - - -- More NOPs - | op == 0xb0 = return OP_NOP1 - | op == 0xb1 = return OP_NOP2 - | op == 0xb2 = return OP_NOP3 - | op == 0xb3 = return OP_NOP4 - | op == 0xb4 = return OP_NOP5 - | op == 0xb5 = return OP_NOP6 - | op == 0xb6 = return OP_NOP7 - | op == 0xb7 = return OP_NOP8 - | op == 0xb8 = return OP_NOP9 - | op == 0xb9 = return OP_NOP10 - - -- Bitcoin Cash Nov 2018 hard fork - | op == 0xba = return OP_CHECKDATASIG - | op == 0xbb = return OP_CHECKDATASIGVERIFY - - -- Constants - | op == 0xfd = return OP_PUBKEYHASH - | op == 0xfe = return OP_PUBKEY - - | otherwise = return $ OP_INVALIDOPCODE op - - put op = case op of - - (OP_PUSHDATA payload optype)-> do - let len = B.length payload - case optype of - OPCODE -> do - unless (len <= 0x4b) $ - error "OP_PUSHDATA OPCODE: Payload size too big" - putWord8 $ fromIntegral len - OPDATA1 -> do - unless (len <= 0xff) $ - error "OP_PUSHDATA OPDATA1: Payload size too big" - putWord8 0x4c - putWord8 $ fromIntegral len - OPDATA2 -> do - unless (len <= 0xffff) $ - error "OP_PUSHDATA OPDATA2: Payload size too big" - putWord8 0x4d - putWord16le $ fromIntegral len - OPDATA4 -> do - unless (len <= 0x7fffffff) $ - error "OP_PUSHDATA OPDATA4: Payload size too big" - putWord8 0x4e - putWord32le $ fromIntegral len - putByteString payload - - -- Constants - OP_0 -> putWord8 0x00 - OP_1NEGATE -> putWord8 0x4f - OP_RESERVED -> putWord8 0x50 - OP_1 -> putWord8 0x51 - OP_2 -> putWord8 0x52 - OP_3 -> putWord8 0x53 - OP_4 -> putWord8 0x54 - OP_5 -> putWord8 0x55 - OP_6 -> putWord8 0x56 - OP_7 -> putWord8 0x57 - OP_8 -> putWord8 0x58 - OP_9 -> putWord8 0x59 - OP_10 -> putWord8 0x5a - OP_11 -> putWord8 0x5b - OP_12 -> putWord8 0x5c - OP_13 -> putWord8 0x5d - OP_14 -> putWord8 0x5e - OP_15 -> putWord8 0x5f - OP_16 -> putWord8 0x60 - - -- Crypto Constants - OP_PUBKEY -> putWord8 0xfe - OP_PUBKEYHASH -> putWord8 0xfd - - -- Invalid Opcodes - (OP_INVALIDOPCODE x) -> putWord8 x - - -- Flow Control - OP_NOP -> putWord8 0x61 - OP_VER -> putWord8 0x62 - OP_IF -> putWord8 0x63 - OP_NOTIF -> putWord8 0x64 - OP_VERIF -> putWord8 0x65 - OP_VERNOTIF -> putWord8 0x66 - OP_ELSE -> putWord8 0x67 - OP_ENDIF -> putWord8 0x68 - OP_VERIFY -> putWord8 0x69 - OP_RETURN -> putWord8 0x6a - - -- Stack Operations - OP_TOALTSTACK -> putWord8 0x6b - OP_FROMALTSTACK -> putWord8 0x6c - OP_2DROP -> putWord8 0x6d - OP_2DUP -> putWord8 0x6e - OP_3DUP -> putWord8 0x6f - OP_2OVER -> putWord8 0x70 - OP_2ROT -> putWord8 0x71 - OP_2SWAP -> putWord8 0x72 - OP_IFDUP -> putWord8 0x73 - OP_DEPTH -> putWord8 0x74 - OP_DROP -> putWord8 0x75 - OP_DUP -> putWord8 0x76 - OP_NIP -> putWord8 0x77 - OP_OVER -> putWord8 0x78 - OP_PICK -> putWord8 0x79 - OP_ROLL -> putWord8 0x7a - OP_ROT -> putWord8 0x7b - OP_SWAP -> putWord8 0x7c - OP_TUCK -> putWord8 0x7d - - -- Splice - OP_CAT -> putWord8 0x7e - OP_SUBSTR -> putWord8 0x7f - OP_LEFT -> putWord8 0x80 - OP_RIGHT -> putWord8 0x81 - OP_SIZE -> putWord8 0x82 - - -- Bitwise Logic - OP_INVERT -> putWord8 0x83 - OP_AND -> putWord8 0x84 - OP_OR -> putWord8 0x85 - OP_XOR -> putWord8 0x86 - OP_EQUAL -> putWord8 0x87 - OP_EQUALVERIFY -> putWord8 0x88 - OP_RESERVED1 -> putWord8 0x89 - OP_RESERVED2 -> putWord8 0x8a - - -- Arithmetic - OP_1ADD -> putWord8 0x8b - OP_1SUB -> putWord8 0x8c - OP_2MUL -> putWord8 0x8d - OP_2DIV -> putWord8 0x8e - OP_NEGATE -> putWord8 0x8f - OP_ABS -> putWord8 0x90 - OP_NOT -> putWord8 0x91 - OP_0NOTEQUAL -> putWord8 0x92 - OP_ADD -> putWord8 0x93 - OP_SUB -> putWord8 0x94 - OP_MUL -> putWord8 0x95 - OP_DIV -> putWord8 0x96 - OP_MOD -> putWord8 0x97 - OP_LSHIFT -> putWord8 0x98 - OP_RSHIFT -> putWord8 0x99 - OP_BOOLAND -> putWord8 0x9a - OP_BOOLOR -> putWord8 0x9b - OP_NUMEQUAL -> putWord8 0x9c - OP_NUMEQUALVERIFY -> putWord8 0x9d - OP_NUMNOTEQUAL -> putWord8 0x9e - OP_LESSTHAN -> putWord8 0x9f - OP_GREATERTHAN -> putWord8 0xa0 - OP_LESSTHANOREQUAL -> putWord8 0xa1 - OP_GREATERTHANOREQUAL-> putWord8 0xa2 - OP_MIN -> putWord8 0xa3 - OP_MAX -> putWord8 0xa4 - OP_WITHIN -> putWord8 0xa5 - - -- Crypto - OP_RIPEMD160 -> putWord8 0xa6 - OP_SHA1 -> putWord8 0xa7 - OP_SHA256 -> putWord8 0xa8 - OP_HASH160 -> putWord8 0xa9 - OP_HASH256 -> putWord8 0xaa - OP_CODESEPARATOR -> putWord8 0xab - OP_CHECKSIG -> putWord8 0xac - OP_CHECKSIGVERIFY -> putWord8 0xad - OP_CHECKMULTISIG -> putWord8 0xae - OP_CHECKMULTISIGVERIFY -> putWord8 0xaf - - -- More NOPs - OP_NOP1 -> putWord8 0xb0 - OP_NOP2 -> putWord8 0xb1 - OP_NOP3 -> putWord8 0xb2 - OP_NOP4 -> putWord8 0xb3 - OP_NOP5 -> putWord8 0xb4 - OP_NOP6 -> putWord8 0xb5 - OP_NOP7 -> putWord8 0xb6 - OP_NOP8 -> putWord8 0xb7 - OP_NOP9 -> putWord8 0xb8 - OP_NOP10 -> putWord8 0xb9 - - -- Bitcoin Cash Nov 2018 hard fork - OP_CHECKDATASIG -> putWord8 0xba - OP_CHECKDATASIGVERIFY -> putWord8 0xbb - - --- | Check whether opcode is only data. -isPushOp :: ScriptOp -> Bool -isPushOp op = case op of - OP_PUSHDATA _ _ -> True - OP_0 -> True - OP_1NEGATE -> True - OP_1 -> True - OP_2 -> True - OP_3 -> True - OP_4 -> True - OP_5 -> True - OP_6 -> True - OP_7 -> True - OP_8 -> True - OP_9 -> True - OP_10 -> True - OP_11 -> True - OP_12 -> True - OP_13 -> True - OP_14 -> True - OP_15 -> True - OP_16 -> True - _ -> False - --- | Optimally encode data using one of the 4 types of data pushing opcodes. -opPushData :: ByteString -> ScriptOp -opPushData bs - | len <= 0x4b = OP_PUSHDATA bs OPCODE - | len <= 0xff = OP_PUSHDATA bs OPDATA1 - | len <= 0xffff = OP_PUSHDATA bs OPDATA2 - | len <= 0xffffffff = OP_PUSHDATA bs OPDATA4 - | otherwise = error "opPushData: payload size too big" - where - len = B.length bs - --- | Transforms integers @[1 .. 16]@ to 'ScriptOp' @[OP_1 .. OP_16]@. -intToScriptOp :: Int -> ScriptOp -intToScriptOp i - | i `elem` [1 .. 16] = op - | otherwise = err - where - op = either (const err) id . S.decode . B.singleton . fromIntegral $ i + 0x50 - err = error $ "intToScriptOp: Invalid integer " ++ show i - --- | Decode 'ScriptOp' @[OP_1 .. OP_16]@ to integers @[1 .. 16]@. This functions --- fails for other values of 'ScriptOp' -scriptOpToInt :: ScriptOp -> Either String Int -scriptOpToInt s - | res `elem` [1..16] = return res - | otherwise = Left $ "scriptOpToInt: invalid opcode " ++ show s - where - res = fromIntegral (B.head $ S.encode s) - 0x50 - --- | Data type describing standard transaction output scripts. Output scripts --- provide the conditions that must be fulfilled for someone to spend the funds --- in a transaction output. -data ScriptOutput - -- | pay to public key - = PayPK { getOutputPubKey :: !PubKeyI } - -- | pay to public key hash - | PayPKHash { getOutputHash :: !Hash160 } - -- | multisig - | PayMulSig { getOutputMulSigKeys :: ![PubKeyI] - , getOutputMulSigRequired :: !Int } - -- | pay to a script hash - | PayScriptHash { getOutputHash :: !Hash160 } - -- | pay to witness public key hash - | PayWitnessPKHash { getOutputHash :: !Hash160 } - -- | pay to witness script hash - | PayWitnessScriptHash { getScriptHash :: !Hash256 } - -- | provably unspendable data carrier - | DataCarrier { getOutputData :: !ByteString } - deriving (Eq, Show, Read, Generic, Hashable, NFData) - -instance FromJSON ScriptOutput where - parseJSON = withText "scriptoutput" $ \t -> either fail return $ - maybeToEither "scriptoutput not hex" (decodeHex t) >>= - decodeOutputBS - -instance ToJSON ScriptOutput where - toJSON = String . encodeHex . encodeOutputBS - toEncoding = 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 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. -decodeOutput :: Script -> Either String ScriptOutput -decodeOutput s = case scriptOps s of - -- Pay to PubKey - [OP_PUSHDATA bs _, OP_CHECKSIG] -> PayPK <$> S.decode bs - -- Pay to PubKey Hash - [OP_DUP, OP_HASH160, OP_PUSHDATA bs _, OP_EQUALVERIFY, OP_CHECKSIG] -> - PayPKHash <$> S.decode bs - -- Pay to Script Hash - [OP_HASH160, OP_PUSHDATA bs _, OP_EQUAL] -> - PayScriptHash <$> S.decode bs - -- Pay to Witness - [OP_0, OP_PUSHDATA bs OPCODE] - | B.length bs == 20 -> PayWitnessPKHash <$> S.decode bs - | B.length bs == 32 -> PayWitnessScriptHash <$> S.decode bs - -- Provably unspendable data carrier output - [OP_RETURN, OP_PUSHDATA bs _] -> Right $ DataCarrier bs - -- Pay to MultiSig Keys - _ -> matchPayMulSig s - --- | Similar to 'decodeOutput' but decodes from a 'ByteString'. -decodeOutputBS :: ByteString -> Either String ScriptOutput -decodeOutputBS = decodeOutput <=< S.decode - --- | Computes a 'Script' from a standard 'ScriptOutput'. -encodeOutput :: ScriptOutput -> Script -encodeOutput s = Script $ case s of - -- Pay to PubKey - (PayPK k) -> [opPushData $ S.encode k, OP_CHECKSIG] - -- Pay to PubKey Hash Address - (PayPKHash h) -> - [ OP_DUP, OP_HASH160, opPushData $ S.encode h, OP_EQUALVERIFY, OP_CHECKSIG] - -- Pay to MultiSig Keys - (PayMulSig ps r) - | r <= length ps -> - let opM = intToScriptOp r - opN = intToScriptOp $ length ps - keys = map (opPushData . S.encode) ps - in opM : keys ++ [opN, OP_CHECKMULTISIG] - | otherwise -> error "encodeOutput: PayMulSig r must be <= than pkeys" - -- Pay to Script Hash Address - (PayScriptHash h) -> - [ OP_HASH160, opPushData $ S.encode h, OP_EQUAL] - -- Pay to Witness PubKey Hash Address - (PayWitnessPKHash h) -> - [ OP_0, opPushData $ S.encode h ] - (PayWitnessScriptHash h) -> - [ OP_0, opPushData $ S.encode h ] - -- Provably unspendable output - (DataCarrier d) -> [OP_RETURN, opPushData d] - --- | Similar to 'encodeOutput' but encodes to a ByteString -encodeOutputBS :: ScriptOutput -> ByteString -encodeOutputBS = S.encode . encodeOutput - --- | Encode script as pay-to-script-hash script -toP2SH :: Script -> ScriptOutput -toP2SH = PayScriptHash . addressHash . S.encode - --- | Encode script as a pay-to-witness-script-hash script -toP2WSH :: Script -> ScriptOutput -toP2WSH = PayWitnessScriptHash . sha256 . S.encode - --- | Match @[OP_N, PubKey1, ..., PubKeyM, OP_M, OP_CHECKMULTISIG]@ -matchPayMulSig :: Script -> Either String ScriptOutput -matchPayMulSig (Script ops) = case splitAt (length ops - 2) ops of - (m:xs,[n,OP_CHECKMULTISIG]) -> do - (intM,intN) <- liftM2 (,) (scriptOpToInt m) (scriptOpToInt n) - if intM <= intN && length xs == intN - then liftM2 PayMulSig (go xs) (return intM) - else Left "matchPayMulSig: Invalid M or N parameters" - _ -> Left "matchPayMulSig: script did not match output template" - where - go (OP_PUSHDATA bs _:xs) = liftM2 (:) (S.decode bs) (go xs) - go [] = return [] - go _ = Left "matchPayMulSig: invalid multisig opcode" diff --git a/src/Network/Haskoin/Script/SigHash.hs b/src/Network/Haskoin/Script/SigHash.hs deleted file mode 100644 --- a/src/Network/Haskoin/Script/SigHash.hs +++ /dev/null @@ -1,319 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-| -Module : Network.Haskoin.Script.SigHash -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Transaction signatures and related functions. --} -module Network.Haskoin.Script.SigHash -( SigHash -, SigHashFlag(..) -, sigHashAll -, sigHashNone -, sigHashSingle -, hasAnyoneCanPayFlag -, hasForkIdFlag -, setAnyoneCanPayFlag -, setForkIdFlag -, isSigHashAll -, isSigHashNone -, isSigHashSingle -, isSigHashUnknown -, sigHashAddForkId -, sigHashGetForkId -, sigHashAddNetworkId -, txSigHash -, txSigHashForkId -, TxSignature(..) -, encodeTxSig -, decodeTxSig -) where - -import Control.DeepSeq -import Control.Monad -import Crypto.Secp256k1 -import qualified Data.Aeson as J -import Data.Bits -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.Hashable -import Data.Maybe -import Data.Scientific -import Data.Serialize -import Data.Word -import GHC.Generics (Generic) -import Network.Haskoin.Constants -import Network.Haskoin.Crypto.Hash -import Network.Haskoin.Crypto.Signature -import Network.Haskoin.Network -import Network.Haskoin.Script.Common -import Network.Haskoin.Transaction.Common -import Network.Haskoin.Util - --- | Constant representing a SIGHASH flag that controls what is being signed. -data SigHashFlag - = SIGHASH_ALL - -- ^ sign all outputs - | SIGHASH_NONE - -- ^ sign no outputs - | SIGHASH_SINGLE - -- ^ sign the output index corresponding to the input - | SIGHASH_FORKID - -- ^ replay protection for Bitcoin Cash transactions - | SIGHASH_ANYONECANPAY - -- ^ new inputs can be added - 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). -newtype SigHash = - SigHash Word32 - deriving ( Eq - , Ord - , Bits - , Enum - , Integral - , Num - , Real - , Show - , Read - , Generic - , Hashable - , 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 :: Network - -> Tx -- ^ transaction to sign - -> Script -- ^ script from output being spent - -> Word64 -- ^ value of output being spent - -> Int -- ^ index of input being signed - -> SigHash -- ^ what to sign - -> Hash256 -- ^ hash to be signed -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 $ - runPut $ do - put 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 - | hasAnyoneCanPayFlag sh = - [ (txins !! i) { scriptInput = encode out } ] - | isSigHashAll sh || isSigHashUnknown sh = single - | otherwise = zipWith noSeq single [0 ..] - where - emptyIn = map (\ti -> ti { scriptInput = BS.empty }) txins - single = - updateIndex i emptyIn $ \ti -> ti { scriptInput = encode out } - noSeq ti j = - if i == j - then ti - else ti { txInSequence = 0 } - --- | Build transaction outputs for computing sighashes. -buildOutputs :: [TxOut] -> Int -> SigHash -> Maybe [TxOut] -buildOutputs txos i sh - | isSigHashAll sh || isSigHashUnknown sh = return txos - | isSigHashNone sh = return [] - | i >= length txos = Nothing - | otherwise = return $ buffer ++ [txos !! i] - 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 - :: Network - -> Tx -- ^ transaction to sign - -> Script -- ^ script from output being spent - -> Word64 -- ^ value of output being spent - -> Int -- ^ index of input being signed - -> SigHash -- ^ what to sign - -> Hash256 -- ^ hash to be signed -txSigHashForkId net tx out v i sh = - doubleSHA256 . runPut $ do - putWord32le $ txVersion tx - put hashPrevouts - put hashSequence - put $ prevOutput $ txIn tx !! i - putScript out - putWord64le v - putWord32le $ txInSequence $ txIn tx !! i - put hashOutputs - putWord32le $ txLockTime tx - putWord32le $ fromIntegral $ sigHashAddNetworkId net sh - where - hashPrevouts - | not $ hasAnyoneCanPayFlag sh = - doubleSHA256 $ runPut $ mapM_ (put . prevOutput) $ txIn tx - | otherwise = zeros - hashSequence - | not (hasAnyoneCanPayFlag sh) && - not (isSigHashSingle sh) && not (isSigHashNone sh) = - doubleSHA256 $ runPut $ mapM_ (putWord32le . txInSequence) $ txIn tx - | otherwise = zeros - hashOutputs - | not (isSigHashSingle sh) && not (isSigHashNone sh) = - doubleSHA256 $ runPut $ mapM_ put $ txOut tx - | isSigHashSingle sh && i < length (txOut tx) = - doubleSHA256 $ encode $ txOut tx !! i - | otherwise = zeros - putScript s = do - let encodedScript = encode s - putVarInt $ BS.length encodedScript - putByteString encodedScript - zeros :: Hash256 - zeros = "0000000000000000000000000000000000000000000000000000000000000000" - --- | Data type representing a signature together with a 'SigHash'. The 'SigHash' --- is serialized as one byte at the end of an ECDSA 'Sig'. All signatures in --- transaction inputs are of type 'TxSignature'. -data TxSignature - = TxSignature { txSignature :: !Sig - , txSignatureSigHash :: !SigHash - } - | TxSignatureEmpty - deriving (Eq, Show, Generic) - -instance NFData TxSignature - --- | Serialize a 'TxSignature'. -encodeTxSig :: TxSignature -> ByteString -encodeTxSig TxSignatureEmpty = error "Can not encode an empty signature" -encodeTxSig (TxSignature sig (SigHash n)) = - runPut $ putSig sig >> putWord8 (fromIntegral n) - --- | Deserialize a 'TxSignature'. -decodeTxSig :: Network -> ByteString -> Either String TxSignature -decodeTxSig _ bs | BS.null bs = Left "Empty signature candidate" -decodeTxSig net bs = - case decodeStrictSig $ BS.init bs of - Just sig -> do - let sh = fromIntegral $ BS.last bs - when (isSigHashUnknown sh) $ - Left "Non-canonical signature: unknown hashtype byte" - when (isNothing (getSigHashForkId net) && hasForkIdFlag sh) $ - Left "Non-canonical signature: invalid network for forkId" - return $ TxSignature sig sh - Nothing -> Left "Non-canonical signature: could not parse signature" diff --git a/src/Network/Haskoin/Script/Standard.hs b/src/Network/Haskoin/Script/Standard.hs deleted file mode 100644 --- a/src/Network/Haskoin/Script/Standard.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-| -Module : Network.Haskoin.Script.Standard -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Standard scripts like pay-to-public-key, pay-to-public-key-hash, -pay-to-script-hash, pay-to-multisig and corresponding SegWit variants. --} -module Network.Haskoin.Script.Standard - ( ScriptInput(..) - , SimpleInput(..) - , RedeemScript - , encodeInput - , encodeInputBS - , decodeInput - , decodeInputBS - , sortMulSig - , scriptOpToInt - , isSpendPK - , isSpendPKHash - , isSpendMulSig - , isScriptHashInput - ) where - -import Control.Applicative ((<|>)) -import Control.DeepSeq -import Control.Monad (guard, (<=<)) -import Data.ByteString (ByteString) -import Data.Function (on) -import Data.List (sortBy) -import Data.Serialize (decode, encode) -import GHC.Generics (Generic) -import Network.Haskoin.Constants -import Network.Haskoin.Keys.Common -import Network.Haskoin.Script.Common -import Network.Haskoin.Script.SigHash -import Network.Haskoin.Util - - --- | 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 - -- | spend pay-to-public-key output - = SpendPK { getInputSig :: !TxSignature - -- ^ transaction signature - } - -- | spend pay-to-public-key-hash output - | SpendPKHash { getInputSig :: !TxSignature - -- ^ embedded signature - , getInputKey :: !PubKeyI - -- ^ public key - } - -- | spend multisig output - | SpendMulSig { 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. -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. -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. -type RedeemScript = ScriptOutput - --- | Standard input script high-level representation. -data ScriptInput - = RegularInput - { getRegularInput :: !SimpleInput - -- ^ get wrapped simple input - } - | ScriptHashInput - { 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) = - maybeToEither errMsg $ matchPK ops <|> matchPKHash ops <|> matchMulSig ops - where - matchPK [op] = SpendPK <$> f op - matchPK _ = Nothing - matchPKHash [op, OP_PUSHDATA pub _] = - SpendPKHash <$> f op <*> eitherToMaybe (decode pub) - matchPKHash _ = Nothing - matchMulSig (x:xs) = do - guard $ x == OP_0 - SpendMulSig <$> mapM f xs - matchMulSig _ = Nothing - f OP_0 = return TxSignatureEmpty - f (OP_PUSHDATA "" OPCODE) = f OP_0 - f (OP_PUSHDATA bs _) = eitherToMaybe $ decodeTxSig net bs - f _ = Nothing - errMsg = "decodeInput: Could not decode script input" - --- | Heuristic to decode a 'ScriptInput' from a 'Script'. This function fails if --- the script can not be parsed as a standard script input. -decodeInput :: Network -> Script -> Either String ScriptInput -decodeInput net s@(Script ops) = - maybeToEither errMsg $ matchSimpleInput <|> matchPayScriptHash - where - matchSimpleInput = - RegularInput <$> eitherToMaybe (decodeSimpleInput net s) - matchPayScriptHash = - case splitAt (length (scriptOps s) - 1) ops of - (is, [OP_PUSHDATA bs _]) -> do - rdm <- eitherToMaybe $ decodeOutputBS bs - inp <- eitherToMaybe $ decodeSimpleInput net $ Script is - return $ ScriptHashInput inp rdm - _ -> Nothing - errMsg = "decodeInput: Could not decode script input" - --- | Like 'decodeInput' but decodes directly from a serialized script --- 'ByteString'. -decodeInputBS :: Network -> ByteString -> Either String ScriptInput -decodeInputBS net = decodeInput net <=< decode - --- | Encode a standard input into a script. -encodeInput :: ScriptInput -> Script -encodeInput s = case s of - RegularInput ri -> encodeSimpleInput ri - ScriptHashInput i o -> Script $ - scriptOps (encodeSimpleInput i) ++ [opPushData $ encodeOutputBS o] - --- | Similar to 'encodeInput' but encodes directly to a serialized script --- 'ByteString'. -encodeInputBS :: ScriptInput -> ByteString -encodeInputBS = encode . encodeInput - --- | Encode a standard 'SimpleInput' into opcodes as an input 'Script'. -encodeSimpleInput :: SimpleInput -> Script -encodeSimpleInput s = - Script $ - case s of - SpendPK ts -> [f ts] - SpendPKHash ts p -> [f ts, opPushData $ encode p] - SpendMulSig xs -> OP_0 : map f xs - where - f TxSignatureEmpty = OP_0 - f ts = opPushData $ encodeTxSig ts - --- | 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` encode) keys) r - _ -> error "Can only call orderMulSig on PayMulSig scripts" diff --git a/src/Network/Haskoin/Transaction.hs b/src/Network/Haskoin/Transaction.hs deleted file mode 100644 --- a/src/Network/Haskoin/Transaction.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-| -Module : Network.Haskoin.Transaction -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Transactions and related code. --} -module Network.Haskoin.Transaction - ( module Common - -- * Builder - , module Builder - -- * Segwit - , module Segwit - -- * Partial - , module Partial - ) where - -import Network.Haskoin.Transaction.Builder as Builder -import Network.Haskoin.Transaction.Common as Common -import Network.Haskoin.Transaction.Partial as Partial -import Network.Haskoin.Transaction.Segwit as Segwit diff --git a/src/Network/Haskoin/Transaction/Builder.hs b/src/Network/Haskoin/Transaction/Builder.hs deleted file mode 100644 --- a/src/Network/Haskoin/Transaction/Builder.hs +++ /dev/null @@ -1,472 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-| -Module : Network.Haskoin.Transaction.Builder -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Code to simplify transaction creation, signing, fee calculation and coin -selection. --} -module Network.Haskoin.Transaction.Builder - ( -- * Transaction Creation & Signing - buildAddrTx - , buildTx - , buildInput - , SigInput(..) - , signTx - , signNestedWitnessTx - , makeSignature - , signInput - , signNestedInput - , verifyStdTx - , mergeTxs - , sigKeys - , mergeTxInput - , findSigInput - , verifyStdInput - -- * Coin Selection - , Coin(..) - , chooseCoins - , chooseCoinsSink - , chooseMSCoins - , chooseMSCoinsSink - , countMulSig - , greedyAddSink - , guessTxFee - , guessMSTxFee - , guessTxSize - , guessMSSize - ) where - -import Control.Applicative ((<|>)) -import Control.Arrow (first) -import Control.Monad (foldM, unless) -import Control.Monad.Identity (runIdentity) -import Crypto.Secp256k1 -import qualified Data.ByteString as B -import Data.Conduit (ConduitT, Void, - await, runConduit, - (.|)) -import Data.Conduit.List (sourceList) -import Data.Either (fromRight) -import Data.List (nub) -import Data.Maybe (catMaybes, fromJust, - isJust) -import Data.Serialize (decode, encode) -import Data.String.Conversions (cs) -import Data.Text (Text) -import Data.Word (Word64) -import Network.Haskoin.Address -import Network.Haskoin.Constants -import Network.Haskoin.Crypto.Hash (Hash256, addressHash) -import Network.Haskoin.Crypto.Signature -import Network.Haskoin.Keys.Common -import Network.Haskoin.Network.Common -import Network.Haskoin.Script -import Network.Haskoin.Transaction.Builder.Sign (SigInput (..), - buildInput, - makeSignature, - sigKeys) -import qualified Network.Haskoin.Transaction.Builder.Sign as S -import Network.Haskoin.Transaction.Common -import Network.Haskoin.Transaction.Segwit (decodeWitnessInput, - isSegwit, - viewWitnessProgram) -import Network.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. -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. -chooseCoins :: Coin c - => Word64 -- ^ value to send - -> Word64 -- ^ fee per byte - -> Int -- ^ number of outputs (including change) - -> Bool -- ^ try to find better solutions - -> [c] -- ^ list of ordered coins to choose from - -> Either String ([c], Word64) - -- ^ coin selection and change -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. -chooseCoinsSink :: (Monad m, Coin c) - => Word64 -- ^ value to send - -> Word64 -- ^ fee per byte - -> Int -- ^ number of outputs (including change) - -> Bool -- ^ try to find better solution - -> ConduitT c Void m (Either String ([c], Word64)) - -- ^ coin selection and change -chooseCoinsSink target fee nOut continue - | target > 0 = - maybeToEither err <$> - greedyAddSink target (guessTxFee fee nOut) continue - | otherwise = return $ Left "chooseCoins: Target must be > 0" - where - err = "chooseCoins: No solution found" - --- | Coin selection algorithm for multisig transactions. This function returns --- the selected coins together with the amount of change to send back to --- yourself, taking the fee into account. This function assumes all the coins --- are script hash outputs that send funds to a multisignature address. -chooseMSCoins :: Coin c - => Word64 -- ^ value to send - -> Word64 -- ^ fee per byte - -> (Int, Int) -- ^ m of n multisig - -> Int -- ^ number of outputs (including change) - -> Bool -- ^ try to find better solution - -> [c] - -> Either String ([c], Word64) - -- ^ coin selection change amount -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. -chooseMSCoinsSink :: (Monad m, Coin c) - => Word64 -- ^ value to send - -> Word64 -- ^ fee per byte - -> (Int, Int) -- ^ m of n multisig - -> Int -- ^ number of outputs (including change) - -> Bool -- ^ try to find better solution - -> ConduitT c Void m (Either String ([c], Word64)) - -- ^ coin selection and change -chooseMSCoinsSink target fee ms nOut continue - | target > 0 = - maybeToEither err <$> - greedyAddSink target (guessMSTxFee fee ms nOut) continue - | otherwise = return $ Left "chooseMSCoins: Target must be > 0" - 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. -greedyAddSink :: (Monad m, Coin c) - => Word64 -- ^ value to send - -> (Int -> Word64) -- ^ coin count to fee function - -> Bool -- ^ try to find better solutions - -> ConduitT c Void m (Maybe ([c], Word64)) - -- ^ coin selection and change -greedyAddSink target guessFee continue = - go [] 0 [] 0 - where - -- The goal is the value we must reach (including the fee) for a certain - -- amount of selected coins. - goal c = target + guessFee c - go acc aTot ps pTot = await >>= \case - -- A coin is available in the stream - Just coin -> do - let val = coinValue coin - -- We have reached the goal using this coin - if val + aTot >= goal (length acc + 1) - -- If we want to continue searching for better solutions - then if continue - -- This solution is the first one or - -- This solution is better than the previous one - then if pTot == 0 || val + aTot < pTot - -- Continue searching for better solutions in the stream - then go [] 0 (coin:acc) (val + aTot) - -- Otherwise, we stop here and return the previous - -- solution - else return $ Just (ps, pTot - goal (length ps)) - -- Otherwise, return this solution - else return $ - Just (coin : acc, val + aTot - goal (length acc + 1)) - -- We have not yet reached the goal. Add the coin to the - -- accumulator - else go (coin:acc) (val + aTot) ps pTot - -- We reached the end of the stream - Nothing -> - return $ if null ps - -- If no solution was found, return Nothing - then Nothing - -- If we have a solution, return it - else 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. -guessTxSize :: Int -- ^ number of regular transaction inputs - -> [(Int,Int)] -- ^ multisig m of n for each input - -> Int -- ^ number of P2PKH outputs - -> Int -- ^ number of P2SH outputs - -> Int -- ^ upper bound on transaction size -guessTxSize pki msi pkout msout = - 8 + inpLen + inp + outLen + out - where - inpLen = B.length $ encode $ VarInt $ fromIntegral $ length msi + pki - outLen = B.length $ encode $ VarInt $ fromIntegral $ pkout + msout - inp = pki * 148 + sum (map guessMSSize msi) - -- (20: hash160) + (5: opcodes) + - -- (1: script len) + (8: Word64) - out = - pkout * 34 + - -- (20: hash160) + (3: opcodes) + - -- (1: script len) + (8: Word64) - msout * 32 - --- | Size of a multisig P2SH input. -guessMSSize :: (Int,Int) -> Int -guessMSSize (m, n) - -- OutPoint (36) + Sequence (4) + Script - = 40 + fromIntegral (B.length $ encode $ VarInt $ fromIntegral scp) + scp - -- OP_M + n*PubKey + OP_N + OP_CHECKMULTISIG - where - rdm = - fromIntegral $ - B.length $ encode $ opPushData $ B.replicate (n * 34 + 3) 0 - -- Redeem + m*sig + OP_0 - scp = rdm + m * 73 + 1 - -{- Build a new Tx -} - --- | Build a transaction by providing a list of outpoints as inputs --- and a list of recipient addresses and amounts as outputs. -buildAddrTx :: Network -> [OutPoint] -> [(Text, Word64)] -> Either String Tx -buildAddrTx net xs ys = buildTx xs =<< mapM f ys - where - f (s, v) = - maybe (Left ("buildAddrTx: Invalid address " ++ cs s)) Right $ do - a <- stringToAddr net s - let o = addressToOutput a - return (o, v) - --- | Build a transaction by providing a list of outpoints as inputs --- and a list of 'ScriptOutput' and amounts as outputs. -buildTx :: [OutPoint] -> [(ScriptOutput, Word64)] -> Either String Tx -buildTx xs ys = - mapM fo ys >>= \os -> return $ Tx 1 (map fi xs) os [] 0 - where - fi outPoint = TxIn outPoint B.empty maxBound - fo (o, v) - | v <= 2100000000000000 = return $ TxOut v $ encodeOutputBS o - | otherwise = - Left $ "buildTx: Invalid amount " ++ show v - --- | 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 - -> Tx -- ^ transaction to sign - -> [SigInput] -- ^ signing parameters - -> [SecKey] -- ^ private keys to sign with - -> Either String Tx -- ^ signed transaction -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'. -signNestedWitnessTx :: Network - -> Tx -- ^ transaction to sign - -> [SigInput] -- ^ signing parameters - -> [SecKey] -- ^ private keys to sign with - -> Either String Tx -- ^ signed transaction -signNestedWitnessTx net tx si = S.signTx net tx $ nested <$> si - where - -- NOTE: the nesting flag is ignored for non-segwit inputs - nested s = (s, True) - - --- | Sign a single input in a transaction deterministically (RFC-6979). -signInput :: Network -> Tx -> Int -> SigInput -> SecKeyI -> Either String Tx -signInput net tx i si = S.signInput net tx i (si, False) - --- | 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. -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. -mergeTxs :: Network -> [Tx] -> [(ScriptOutput, Word64, OutPoint)] -> Either String Tx -mergeTxs net txs os - | null txs = Left "Transaction list is empty" - | length (nub emptyTxs) /= 1 = Left "Transactions do not match" - | length txs == 1 = return $ head txs - | otherwise = foldM (mergeTxInput net txs) (head emptyTxs) outs - where - zipOp = zip (matchTemplate os (txIn $ head txs) f) [0..] - outs = map (first $ (\(o,v,_) -> (o,v)) . fromJust) $ filter (isJust . fst) zipOp - f (_, _, o) txin = o == prevOutput txin - emptyTxs = map (\tx -> foldl clearInput tx outs) txs - ins is i = updateIndex i is (\ti -> ti{ scriptInput = B.empty }) - 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. -mergeTxInput :: - Network - -> [Tx] - -> Tx - -> ((ScriptOutput, Word64), Int) - -> Either String Tx -mergeTxInput net txs tx ((so, val), i) - -- Ignore transactions with empty inputs - = do - let ins = map (scriptInput . (!! i) . txIn) txs - sigRes <- mapM extractSigs $ filter (not . B.null) ins - let rdm = snd $ head sigRes - unless (all (== rdm) $ map snd sigRes) $ Left "Redeem scripts do not match" - si <- encodeInputBS <$> go (nub $ concatMap fst sigRes) so rdm - let ins' = updateIndex i (txIn tx) (\ti -> ti {scriptInput = si}) - return $ Tx (txVersion tx) ins' (txOut tx) [] (txLockTime tx) - where - go allSigs out rdmM = - case out of - PayMulSig msPubs r -> - let sigs = - take r $ - catMaybes $ matchTemplate allSigs msPubs $ f out - in return $ RegularInput $ SpendMulSig sigs - PayScriptHash _ -> - case rdmM of - Just rdm -> do - si <- go allSigs rdm Nothing - return $ ScriptHashInput (getRegularInput si) rdm - _ -> Left "Invalid output script type" - _ -> Left "Invalid output script type" - extractSigs si = - case decodeInputBS net si of - Right (RegularInput (SpendMulSig sigs)) -> Right (sigs, Nothing) - Right (ScriptHashInput (SpendMulSig sigs) rdm) -> - Right (sigs, Just rdm) - _ -> Left "Invalid script input type" - f out (TxSignature x sh) p = - verifyHashSig - (txSigHash net tx (encodeOutput out) val i sh) - x - (pubKeyPoint p) - f _ TxSignatureEmpty _ = False - -{- Tx verification -} - --- | Verify if a transaction is valid and all of its inputs are standard. -verifyStdTx :: Network -> Tx -> [(ScriptOutput, Word64, OutPoint)] -> Bool -verifyStdTx net tx xs = - not (null (txIn tx)) && all go (zip (matchTemplate xs (txIn tx) f) [0 ..]) - where - f (_, _, o) txin = o == prevOutput txin - 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 - | isSegwit so0 = fromRight False $ (inp == mempty &&) . verifySegwitInput so0 <$> wp so0 - | otherwise = fromRight False - $ verifyLegacyInput so0 <$> decodeInputBS net inp - <|> (nestedScriptOutput >>= \so -> verifyNestedInput so0 so <$> wp so) - where - verifyLegacyInput so si = case (so, si) of - (PayPK pub, RegularInput (SpendPK (TxSignature sig sh))) -> - verifyHashSig (theTxSigHash so sh Nothing) sig (pubKeyPoint pub) - (PayPKHash h, RegularInput (SpendPKHash (TxSignature sig sh) pub)) -> - pubKeyAddr pub == p2pkhAddr h && - verifyHashSig (theTxSigHash so sh Nothing) sig (pubKeyPoint pub) - (PayMulSig pubs r, RegularInput (SpendMulSig sigs)) -> - countMulSig net tx out val i (pubKeyPoint <$> pubs) sigs == r - (PayScriptHash h, ScriptHashInput si' rdm) -> - payToScriptAddress rdm == p2shAddr h && verifyLegacyInput rdm (RegularInput si') - _ -> False - where out = encodeOutput so - - verifySegwitInput so (rdm, si) = case (so, rdm, si) of - (PayWitnessPKHash h, Nothing, SpendPKHash (TxSignature sig sh) pub) -> - pubKeyWitnessAddr pub == p2wpkhAddr h && - verifyHashSig (theTxSigHash so sh Nothing) sig (pubKeyPoint pub) - (PayWitnessScriptHash h, Just rdm'@(PayPK pub), SpendPK (TxSignature sig sh)) -> - payToWitnessScriptAddress rdm' == p2wshAddr h && - verifyHashSig (theTxSigHash so sh $ Just rdm') sig (pubKeyPoint pub) - (PayWitnessScriptHash h, Just rdm'@(PayPKHash kh), SpendPKHash (TxSignature sig sh) pub) -> - payToWitnessScriptAddress rdm' == p2wshAddr h && - addressHash (encode pub) == kh && - verifyHashSig (theTxSigHash so sh $ Just rdm') sig (pubKeyPoint pub) - (PayWitnessScriptHash h, Just rdm'@(PayMulSig pubs r), SpendMulSig sigs) -> - payToWitnessScriptAddress rdm' == p2wshAddr h && - countMulSig' (\sh -> theTxSigHash so sh $ Just rdm') (pubKeyPoint <$> pubs) sigs == r - _ -> False - - verifyNestedInput so so' x = case so of - PayScriptHash h -> payToScriptAddress so' == p2shAddr h && verifySegwitInput so' x - _ -> False - - inp = scriptInput $ txIn tx !! i - theTxSigHash so = S.makeSigHash net tx i so val - - ws | length (txWitness tx) > i = txWitness tx !! i - | otherwise = [] - wp so = decodeWitnessInput net =<< viewWitnessProgram net so ws - - nestedScriptOutput = scriptOps <$> decode inp >>= \case - [OP_PUSHDATA bs _] -> decodeOutputBS bs - _ -> Left "nestedScriptOutput: not a nested output" - --- | Count the number of valid signatures for a multi-signature transaction. -countMulSig :: - Network - -> Tx - -> Script - -> Word64 - -> Int - -> [PubKey] - -> [TxSignature] - -> Int -countMulSig net tx out val i = countMulSig' h - where - h = txSigHash net tx out val i - -countMulSig' :: (SigHash -> Hash256) -> [PubKey] -> [TxSignature] -> Int -countMulSig' _ [] _ = 0 -countMulSig' _ _ [] = 0 -countMulSig' h (_:pubs) (TxSignatureEmpty:sigs) = countMulSig' h pubs sigs -countMulSig' h (pub:pubs) sigs@(TxSignature sig sh : sigs') - | verifyHashSig (h sh) sig pub = 1 + countMulSig' h pubs sigs' - | otherwise = countMulSig' h pubs sigs diff --git a/src/Network/Haskoin/Transaction/Builder/Sign.hs b/src/Network/Haskoin/Transaction/Builder/Sign.hs deleted file mode 100644 --- a/src/Network/Haskoin/Transaction/Builder/Sign.hs +++ /dev/null @@ -1,279 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-| -Module : Network.Haskoin.Transaction.Builder.Sign -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Types and logic for signing transactions. --} -module Network.Haskoin.Transaction.Builder.Sign - ( SigInput (..) - , makeSignature - , makeSigHash - , signTx - , findInputIndex - , signInput - , buildInput - , sigKeys - ) where - -import Control.DeepSeq (NFData) -import Control.Monad (foldM, mzero, when) -import Data.Aeson (FromJSON, ToJSON (..), - Value (Object), object, - parseJSON, (.:), (.:?), - (.=), pairs) -import Data.Either (rights) -import Data.Hashable (Hashable) -import Data.List (find, nub) -import Data.Maybe (catMaybes, fromMaybe, - mapMaybe, maybeToList) -import qualified Data.Serialize as S -import Data.Word (Word64) -import GHC.Generics (Generic) - -import Network.Haskoin.Address (getAddrHash160, pubKeyAddr) -import Network.Haskoin.Constants (Network) -import Network.Haskoin.Crypto (Hash256, SecKey) -import Network.Haskoin.Crypto.Signature (signHash, verifyHashSig) -import Network.Haskoin.Keys.Common (PubKeyI (..), SecKeyI (..), - derivePubKeyI, wrapSecKey) -import Network.Haskoin.Script.Common (ScriptOutput (..), - encodeOutput, - encodeOutputBS, opPushData) -import Network.Haskoin.Script.SigHash (SigHash, TxSignature (..), - decodeTxSig, txSigHash, - txSigHashForkId) -import Network.Haskoin.Script.Standard (RedeemScript, - ScriptInput (..), - SimpleInput (..), - decodeInputBS, - encodeInputBS) -import Network.Haskoin.Transaction.Common (OutPoint, Tx (..), - TxIn (..), WitnessData) -import Network.Haskoin.Transaction.Segwit (WitnessProgram (..), - calcWitnessProgram, - isSegwit, toWitnessStack) -import Network.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 SigInput = SigInput - { sigInputScript :: !ScriptOutput -- ^ output script to spend - , sigInputValue :: !Word64 -- ^ output script value - , sigInputOP :: !OutPoint -- ^ outpoint to spend - , sigInputSH :: !SigHash -- ^ signature type - , sigInputRedeem :: !(Maybe RedeemScript) -- ^ redeem script - } deriving (Eq, Show, Read, Generic, Hashable, NFData) - -instance ToJSON SigInput where - toJSON (SigInput so val op sh rdm) = object $ - [ "pkscript" .= so - , "value" .= val - , "outpoint" .= op - , "sighash" .= sh - ] ++ [ "redeem" .= r | r <- maybeToList rdm ] - toEncoding (SigInput so val op sh rdm) = pairs $ - "pkscript" .= so - <> "value" .= val - <> "outpoint" .= op - <> "sighash" .= sh - <> (case rdm of Nothing -> mempty - Just r -> "redeem" .= r) - -instance FromJSON SigInput where - parseJSON (Object o) = do - so <- o .: "pkscript" - val <- o .: "value" - op <- o .: "outpoint" - sh <- o .: "sighash" - rdm <- o .:? "redeem" - return $ SigInput so val op sh rdm - parseJSON _ = mzero - --- | 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 - -> Tx -- ^ transaction to sign - -> [(SigInput, Bool)] -- ^ signing parameters, with nesting flag - -> [SecKey] -- ^ private keys to sign with - -> Either String Tx -- ^ signed transaction -signTx net otx sigis allKeys - | null ti = Left "signTx: Transaction has no inputs" - | otherwise = foldM go otx $ findInputIndex (sigInputOP . fst) sigis ti - where - ti = txIn otx - go tx (sigi@(SigInput so _ _ _ rdmM, _), i) = do - 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. -signInput :: - Network - -> Tx - -> Int - -> (SigInput, Bool) -- ^ boolean flag: nest input - -> SecKeyI - -> Either String Tx -signInput net tx i (sigIn@(SigInput so val _ _ rdmM), nest) key = do - let sig = makeSignature net tx i sigIn key - si <- buildInput net tx i so val rdmM sig $ derivePubKeyI key - w <- updatedWitnessData tx i so si - return tx { txIn = nextTxIn so si - , txWitness = w - } - where - f si x = x {scriptInput = encodeInputBS si} - g so' x = x {scriptInput = S.encode . opPushData $ encodeOutputBS so'} - txis = txIn tx - nextTxIn so' si - | isSegwit so' && nest = updateIndex i txis (g so') - | 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 -updatedWitnessData :: Tx -> Int -> ScriptOutput -> ScriptInput -> Either String WitnessData -updatedWitnessData tx i so si - | isSegwit so = updateWitness . toWitnessStack =<< calcWitnessProgram so si - | otherwise = return $ txWitness tx - where - updateWitness w - | null $ txWitness tx = return $ updateIndex i defaultStack (const w) - | length (txWitness tx) /= n = Left "Invalid number of witness stacks" - | otherwise = return $ updateIndex i (txWitness tx) (const w) - defaultStack = replicate n $ toWitnessStack EmptyWitnessProgram - n = length $ txIn tx - --- | Associate an input index to each value in a list -findInputIndex :: - (a -> OutPoint) -- ^ extract an outpoint - -> [a] -- ^ input list - -> [TxIn] -- ^ reference list of inputs - -> [(a, Int)] -findInputIndex getOutPoint as ti = - mapMaybe g $ zip (matchTemplate as ti f) [0..] - where - f s txin = getOutPoint s == prevOutput txin - 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'. -sigKeys :: - ScriptOutput - -> Maybe RedeemScript - -> [SecKey] - -> Either String [SecKeyI] -sigKeys so rdmM keys = - case (so, rdmM) of - (PayPK p, Nothing) -> - return . map fst . maybeToList $ find ((== p) . snd) zipKeys - (PayPKHash h, Nothing) -> return $ keyByHash h - (PayMulSig ps r, Nothing) -> - return $ map fst $ take r $ filter ((`elem` ps) . snd) zipKeys - (PayScriptHash _, Just rdm) -> sigKeys rdm Nothing keys - (PayWitnessPKHash h, _) -> return $ keyByHash h - (PayWitnessScriptHash _, Just rdm) -> sigKeys rdm Nothing keys - _ -> Left "sigKeys: Could not decode output script" - where - zipKeys = - [ (prv, pub) - | k <- keys - , t <- [True, False] - , let prv = wrapSecKey t k - , let pub = derivePubKeyI prv - ] - 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. -buildInput :: - Network - -> Tx -- ^ transaction where input will be added - -> Int -- ^ input index where signature will go - -> ScriptOutput -- ^ output script being spent - -> Word64 -- ^ amount of previous output - -> Maybe RedeemScript -- ^ redeem script if pay-to-script-hash - -> TxSignature - -> PubKeyI - -> Either String ScriptInput -buildInput net tx i so val rdmM sig pub = do - when (i >= length (txIn tx)) $ Left "buildInput: Invalid input index" - case (so, rdmM) of - (PayScriptHash _, Just rdm) -> buildScriptHashInput rdm - (PayWitnessScriptHash _, Just rdm) -> buildScriptHashInput rdm - (PayWitnessPKHash _, Nothing) -> return . RegularInput $ SpendPKHash sig pub - (_, Nothing) -> buildRegularInput so - _ -> Left "buildInput: Invalid output/redeem script combination" - where - buildRegularInput = \case - PayPK _ -> return $ RegularInput $ SpendPK sig - PayPKHash _ -> return $ RegularInput $ SpendPKHash sig pub - PayMulSig msPubs r -> do - let mSigs = take r $ catMaybes $ matchTemplate allSigs msPubs f - allSigs = nub $ sig : parseExistingSigs net tx so i - return $ RegularInput $ SpendMulSig mSigs - _ -> Left "buildInput: Invalid output/redeem script combination" - buildScriptHashInput rdm = do - inp <- buildRegularInput rdm - return $ ScriptHashInput (getRegularInput inp) rdm - f (TxSignature x sh) p = - 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 -parseExistingSigs :: Network -> Tx -> ScriptOutput -> Int -> [TxSignature] -parseExistingSigs net tx so i = insSigs <> witSigs - where - insSigs = case decodeInputBS net scp of - Right (ScriptHashInput (SpendMulSig xs) _) -> xs - Right (RegularInput (SpendMulSig xs)) -> xs - _ -> [] - scp = scriptInput $ txIn tx !! i - witSigs - | not $ isSegwit so = [] - | 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 = - TxSignature (signHash (secKeyData key) m) sh - 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 -makeSigHash :: - Network - -> Tx - -> Int - -> ScriptOutput - -> Word64 - -> SigHash - -> Maybe RedeemScript - -> Hash256 -makeSigHash net tx i so val sh rdmM = h net tx (encodeOutput so') val i sh - where - so' = case so of - PayWitnessPKHash h' -> PayPKHash h' - _ -> fromMaybe so rdmM - h | isSegwit so = txSigHashForkId - | otherwise = txSigHash diff --git a/src/Network/Haskoin/Transaction/Common.hs b/src/Network/Haskoin/Transaction/Common.hs deleted file mode 100644 --- a/src/Network/Haskoin/Transaction/Common.hs +++ /dev/null @@ -1,312 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-| -Module : Network.Haskoin.Transaction.Common -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Code related to transactions parsing and serialization. --} -module Network.Haskoin.Transaction.Common - ( Tx(..) - , TxIn(..) - , TxOut(..) - , OutPoint(..) - , TxHash(..) - , WitnessData - , WitnessStack - , WitnessStackItem - , txHash - , hexToTxHash - , txHashToHex - , nosigTxHash - , nullOutPoint - , genesisTx - ) where - -import Control.Applicative ((<|>)) -import Control.DeepSeq -import Control.Monad (forM_, guard, liftM2, mzero, - replicateM, (<=<)) -import Data.Aeson as A -import Data.Aeson.Encoding (unsafeToEncoding) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.ByteString.Builder (char7) -import Data.Hashable (Hashable) -import Data.Maybe (fromMaybe) -import Data.Serialize as S -import Data.String (IsString, fromString) -import Data.String.Conversions (cs) -import Data.Text (Text) -import Data.Word (Word32, Word64) -import GHC.Generics (Generic) -import Network.Haskoin.Crypto.Hash -import Network.Haskoin.Network.Common -import Network.Haskoin.Script.Common -import Network.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, Serialize, NFData) - -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 (TxHash h) = - unsafeToEncoding $ - char7 '"' <> hexBuilder (B.reverse (S.encode h)) <> char7 '"' - --- | Transaction hash excluding signatures. -nosigTxHash :: Tx -> TxHash -nosigTxHash tx = - TxHash $ doubleSHA256 $ S.encode tx { txIn = map clearInput $ txIn 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 (S.encode h)) - --- | Convert transaction hash from hex, reversing bytes. -hexToTxHash :: Text -> Maybe TxHash -hexToTxHash hex = do - bs <- B.reverse <$> decodeHex hex - h <- either (const Nothing) Just (S.decode 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 - } deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) - --- | Compute transaction hash. -txHash :: Tx -> TxHash -txHash tx = TxHash (doubleSHA256 (S.encode tx {txWitness = []})) - -instance IsString Tx where - fromString = - fromMaybe e . (eitherToMaybe . S.decode <=< decodeHex) . cs - where - e = error "Could not read transaction from hex string" - -instance Serialize Tx where - get = parseWitnessTx <|> parseLegacyTx - put tx - | null (txWitness tx) = putLegacyTx tx - | otherwise = putWitnessTx tx - -putInOut :: Tx -> Put -putInOut tx = do - putVarInt $ length (txIn tx) - forM_ (txIn tx) put - putVarInt $ length (txOut tx) - forM_ (txOut tx) put - --- | Non-SegWit transaction serializer. -putLegacyTx :: Tx -> Put -putLegacyTx tx = do - putWord32le (txVersion tx) - putInOut tx - putWord32le (txLockTime tx) - --- | Witness transaciton serializer. -putWitnessTx :: Tx -> Put -putWitnessTx tx = do - putWord32le (txVersion tx) - putWord8 0x00 - putWord8 0x01 - putInOut tx - putWitnessData (txWitness tx) - putWord32le (txLockTime tx) - --- | Non-SegWit transaction deseralizer. -parseLegacyTx :: Get Tx -parseLegacyTx = do - v <- getWord32le - is <- replicateList =<< S.get - os <- replicateList =<< S.get - l <- getWord32le - return - Tx - {txVersion = v, txIn = is, txOut = os, txWitness = [], txLockTime = l} - where - replicateList (VarInt c) = replicateM (fromIntegral c) S.get - --- | Witness transaction deserializer. -parseWitnessTx :: Get Tx -parseWitnessTx = do - v <- getWord32le - m <- getWord8 - f <- getWord8 - guard $ m == 0x00 - guard $ f == 0x01 - is <- replicateList =<< S.get - os <- replicateList =<< S.get - w <- parseWitnessData $ length is - l <- getWord32le - return - Tx {txVersion = v, txIn = is, txOut = os, txWitness = w, txLockTime = l} - where - replicateList (VarInt c) = replicateM (fromIntegral c) S.get - --- | Witness data deserializer. Requires count of inputs. -parseWitnessData :: Int -> Get WitnessData -parseWitnessData n = replicateM n parseWitnessStack - where - parseWitnessStack = do - VarInt i <- S.get - replicateM (fromIntegral i) parseWitnessStackItem - parseWitnessStackItem = do - VarInt i <- S.get - getByteString $ fromIntegral i - --- | Witness data serializer. -putWitnessData :: WitnessData -> Put -putWitnessData = mapM_ putWitnessStack - where - putWitnessStack ws = do - putVarInt $ length ws - mapM_ putWitnessStackItem ws - putWitnessStackItem bs = do - putVarInt $ B.length bs - putByteString bs - -instance FromJSON Tx where - parseJSON = withText "Tx" $ - maybe mzero return . (eitherToMaybe . S.decode <=< decodeHex) - -instance ToJSON Tx where - toJSON = A.String . encodeHex . S.encode - toEncoding tx = - unsafeToEncoding $ char7 '"' <> hexBuilder (S.encode tx) <> char7 '"' - --- | Data type representing a transaction input. -data TxIn = - TxIn { - -- | output being spent - prevOutput :: !OutPoint - -- | signatures and redeem script - , scriptInput :: !ByteString - -- | lock-time using sequence numbers (BIP-68) - , txInSequence :: !Word32 - } deriving (Eq, Show, Read, Ord, Generic, Hashable, NFData) - -instance Serialize TxIn where - get = - TxIn <$> S.get <*> (readBS =<< S.get) <*> getWord32le - where - readBS (VarInt len) = getByteString $ fromIntegral len - - put (TxIn o s q) = do - put o - putVarInt $ B.length s - putByteString s - putWord32le q - --- | Data type representing a transaction output. -data TxOut = - TxOut { - -- | value of output is satoshi - outValue :: !Word64 - -- | pubkey script - , scriptOutput :: !ByteString - } deriving (Eq, Show, Read, Ord, Generic, Hashable, NFData) - -instance Serialize TxOut where - get = do - val <- getWord64le - (VarInt len) <- S.get - TxOut val <$> getByteString (fromIntegral len) - - put (TxOut o s) = do - putWord64le o - putVarInt $ B.length s - putByteString s - --- | The 'OutPoint' refers to a transaction output being spent. -data OutPoint = OutPoint - { -- | hash of previous transaction - outPointHash :: !TxHash - -- | position of output in previous transaction - , outPointIndex :: !Word32 - } deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) - -instance FromJSON OutPoint where - parseJSON = withText "OutPoint" $ - maybe mzero return . (eitherToMaybe . S.decode <=< decodeHex) - -instance ToJSON OutPoint where - toJSON = A.String . encodeHex . S.encode - toEncoding op = - unsafeToEncoding $ char7 '"' <> hexBuilder (S.encode op) <> char7 '"' - -instance Serialize OutPoint where - get = do - (h,i) <- liftM2 (,) S.get getWord32le - return $ OutPoint h i - put (OutPoint h i) = put h >> putWord32le i - --- | Outpoint used in coinbase transactions. -nullOutPoint :: OutPoint -nullOutPoint = - OutPoint - { outPointHash = - "0000000000000000000000000000000000000000000000000000000000000000" - , outPointIndex = maxBound - } - --- | Transaction from Genesis block. -genesisTx :: Tx -genesisTx = - Tx 1 [txin] [txout] [] locktime - where - txin = TxIn outpoint inputBS maxBound - txout = TxOut 5000000000 (encodeOutputBS output) - locktime = 0 - outpoint = OutPoint z maxBound - Just inputBS = decodeHex $ fromString $ - "04ffff001d0104455468652054696d65732030332f4a616e2f323030392043686" ++ - "16e63656c6c6f72206f6e206272696e6b206f66207365636f6e64206261696c6f" ++ - "757420666f722062616e6b73" - output = PayPK $ fromString $ - "04678afdb0fe5548271967f1a67130b7105cd6a828e03909a67962e0ea1f61deb" ++ - "649f6bc3f4cef38c4f35504e51ec112de5c384df7ba0b8d578a4c702b6bf11d5f" - z = "0000000000000000000000000000000000000000000000000000000000000000" diff --git a/src/Network/Haskoin/Transaction/Partial.hs b/src/Network/Haskoin/Transaction/Partial.hs deleted file mode 100644 --- a/src/Network/Haskoin/Transaction/Partial.hs +++ /dev/null @@ -1,505 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-| -Module : Network.Haskoin.Transaction.Partial -Copyright : No rights reserved -License : UNLICENSE -Maintainer : matt@bitnomial.com -Stability : experimental -Portability : POSIX - -Code related to PSBT parsing and serialization. --} -module Network.Haskoin.Transaction.Partial - ( PartiallySignedTransaction (..) - , Input (..) - , Output (..) - , UnknownMap (..) - , Key (..) - , merge - , mergeInput - , mergeOutput - , complete - , finalTransaction - , emptyPSBT - , emptyInput - , emptyOutput - ) where - -import Control.Applicative ((<|>)) -import Control.DeepSeq -import Control.Monad (guard, replicateM, void) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Hashable (Hashable) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.List (foldl') -import Data.Maybe (fromMaybe, isJust) -import Data.Serialize as S -import GHC.Generics (Generic) -import GHC.Word (Word32, Word8) -import Network.Haskoin.Address (Address (..), pubKeyAddr) -import Network.Haskoin.Keys (Fingerprint, KeyIndex, - PubKeyI) -import Network.Haskoin.Network (VarInt (..), - VarString (..), putVarInt) -import Network.Haskoin.Script (Script (..), ScriptOp (..), - ScriptOutput (..), SigHash, - decodeOutput, - decodeOutputBS, - encodeOutputBS, - isPayScriptHash, - opPushData, toP2SH, - toP2WSH) -import Network.Haskoin.Transaction.Common (Tx (..), TxOut, - WitnessStack, - outPointIndex, prevOutput, - scriptInput, scriptOutput) -import Network.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. -data PartiallySignedTransaction = PartiallySignedTransaction - { unsignedTransaction :: Tx - , globalUnknown :: UnknownMap - , inputs :: [Input] - , outputs :: [Output] - } 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. -data Input = Input - { nonWitnessUtxo :: Maybe Tx - , witnessUtxo :: Maybe TxOut - , partialSigs :: HashMap PubKeyI ByteString - , sigHashType :: Maybe SigHash - , inputRedeemScript :: Maybe Script - , inputWitnessScript :: Maybe Script - , inputHDKeypaths :: HashMap PubKeyI (Fingerprint, [KeyIndex]) - , finalScriptSig :: Maybe Script - , finalScriptWitness :: Maybe WitnessStack - , inputUnknown :: UnknownMap - } deriving (Show, Eq, Generic) - -instance NFData Input - --- | Outputs can contain information needed to spend the output at a later date. -data Output = Output - { outputRedeemScript :: Maybe Script - , outputWitnessScript :: Maybe Script - , outputHDKeypaths :: HashMap PubKeyI (Fingerprint, [KeyIndex]) - , outputUnknown :: UnknownMap - } deriving (Show, Eq, Generic) - -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. -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 - , key :: ByteString - } 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. -merge :: PartiallySignedTransaction -> PartiallySignedTransaction -> Maybe PartiallySignedTransaction -merge psbt1 psbt2 - | unsignedTransaction psbt1 == unsignedTransaction psbt2 - = Just $ psbt1 - { globalUnknown = globalUnknown psbt1 <> globalUnknown psbt2 - , inputs = zipWith mergeInput (inputs psbt1) (inputs psbt2) - , outputs = zipWith mergeOutput (outputs psbt1) (outputs psbt2) - } -merge _ _ = Nothing - -mergeInput :: Input -> Input -> Input -mergeInput a b = Input - { nonWitnessUtxo = if isJust witUtx then Nothing else nonWitnessUtxo a <|> nonWitnessUtxo b - , witnessUtxo = witUtx - , sigHashType = sigHashType a <|> sigHashType b - , partialSigs = partialSigs a <> partialSigs b - , inputHDKeypaths = inputHDKeypaths a <> inputHDKeypaths b - , inputUnknown = inputUnknown a <> inputUnknown b - , inputRedeemScript = inputRedeemScript a <|> inputRedeemScript b - , inputWitnessScript = inputWitnessScript a <|> inputWitnessScript b - , finalScriptSig = finalScriptSig a <|> finalScriptSig b - , finalScriptWitness = finalScriptWitness a <|> finalScriptWitness b - } - where - witUtx = witnessUtxo a <|> witnessUtxo b - -mergeOutput :: Output -> Output -> Output -mergeOutput a b = Output - { outputRedeemScript = outputRedeemScript a <|> outputRedeemScript b - , outputWitnessScript = outputWitnessScript a <|> outputWitnessScript b - , outputHDKeypaths = outputHDKeypaths a <> outputHDKeypaths b - , outputUnknown = outputUnknown a <> outputUnknown b - } - --- | Take partial signatures from all of the 'Input's and finalize the signature. -complete :: PartiallySignedTransaction -> PartiallySignedTransaction -complete psbt = psbt { inputs = map (completeInput . analyzeInputs) (indexed $ inputs psbt) } - where - analyzeInputs (i, input) = (outputScript =<< witnessUtxo input <|> nonWitScript, input) - where - nonWitScript = getPrevOut i =<< nonWitnessUtxo input - - getPrevOut i tx = - (txOut tx !!?) . fromIntegral . outPointIndex . prevOutput =<< txIn (unsignedTransaction psbt) !!? i - xs !!? i = lookup i $ indexed xs - - outputScript = eitherToMaybe . decodeOutputBS . scriptOutput - - completeInput (Nothing, input) = input - completeInput (Just script, input) = completeSig input script - - indexed :: [a] -> [(Word32, a)] - indexed = zip [0..] - -completeSig :: Input -> ScriptOutput -> Input -completeSig input (PayPK k) = - input { finalScriptSig = eitherToMaybe . S.decode =<< HashMap.lookup k (partialSigs input) } -completeSig input (PayPKHash h) - | [(k, sig)] <- HashMap.toList $ partialSigs input - , PubKeyAddress h == pubKeyAddr k - = input { finalScriptSig = Just $ Script [opPushData sig, opPushData (S.encode k)] } -completeSig input (PayMulSig pubKeys m) | length sigs >= m = input { finalScriptSig = finalSig } - where - sigs = collectSigs m pubKeys input - finalSig = Script . (OP_0 :) . (map opPushData sigs <>) . pure . opPushData . S.encode <$> inputRedeemScript input -completeSig input (PayScriptHash h) - | Just rdmScript <- inputRedeemScript input - , PayScriptHash h == toP2SH rdmScript - , Right decodedScript <- decodeOutput rdmScript - , not (isPayScriptHash decodedScript) - = completeSig input decodedScript -completeSig input (PayWitnessPKHash h) - | [(k, sig)] <- HashMap.toList $ partialSigs input - , PubKeyAddress h == pubKeyAddr k - = input { finalScriptWitness = Just [sig, S.encode k] - , finalScriptSig = Script . pure . opPushData . S.encode <$> inputRedeemScript input - } -completeSig input (PayWitnessScriptHash h) - | Just witScript <- inputWitnessScript input - , PayWitnessScriptHash h == toP2WSH witScript - , Right decodedScript <- decodeOutput witScript - = completeWitnessSig input decodedScript -completeSig input _ = input - -completeWitnessSig :: Input -> ScriptOutput -> Input -completeWitnessSig input script@(PayMulSig pubKeys m) | length sigs >= m = input - { finalScriptWitness = Just finalWit - , finalScriptSig = finalSig - } - where - sigs = collectSigs m pubKeys input - finalSig = Script . pure . opPushData . S.encode <$> inputRedeemScript input - finalWit = mempty : sigs <> [encodeOutputBS script] -completeWitnessSig input _ = input - -collectSigs :: Int -> [PubKeyI] -> Input -> [ByteString] -collectSigs m pubKeys input = take m . reverse $ foldl' lookupKey [] pubKeys - where - lookupKey sigs key = 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. -finalTransaction :: PartiallySignedTransaction -> Tx -finalTransaction psbt = setInputs . foldl' finalizeInput ([], []) $ zip (txIn tx) (inputs psbt) - where - tx = unsignedTransaction psbt - hasWitness = any (isJust . finalScriptWitness) (inputs psbt) - setInputs (ins, witData) = tx { txIn = reverse ins, txWitness = if hasWitness then reverse witData else [] } - finalizeInput (ins, witData) (txInput, psbtInput) = maybe finalWitness finalScript $ finalScriptSig psbtInput - where - finalScript script = (txInput { scriptInput = encode script }:ins, []:witData) - finalWitness = (ins, fromMaybe [] (finalScriptWitness psbtInput):witData) - --- | Take an unsigned transaction and produce an empty 'PartiallySignedTransaction' -emptyPSBT :: Tx -> PartiallySignedTransaction -emptyPSBT tx = PartiallySignedTransaction - { unsignedTransaction = tx - , globalUnknown = mempty - , inputs = replicate (length (txIn tx)) emptyInput - , outputs = replicate (length (txOut tx)) emptyOutput - } - -emptyInput :: Input -emptyInput = Input - Nothing Nothing HashMap.empty Nothing - Nothing Nothing HashMap.empty - Nothing Nothing (UnknownMap HashMap.empty) - -emptyOutput :: Output -emptyOutput = Output Nothing Nothing HashMap.empty (UnknownMap HashMap.empty) - -instance Serialize PartiallySignedTransaction where - get = do - magic <- getBytes 4 - guard $ magic == "psbt" - headerSep <- getWord8 - guard $ headerSep == 0xff - - keySize <- getWord8 - guard $ keySize == 1 - globalUnsignedTxType <- getWord8 - guard $ globalUnsignedTxType == 0x00 - unsignedTransaction <- getSizedBytes - guard $ all (B.null . scriptInput) (txIn unsignedTransaction) - guard $ null (txWitness unsignedTransaction) - - globalUnknown <- get - globalEnd <- getWord8 - guard $ globalEnd == 0x00 - - inputs <- replicateM (length $ txIn unsignedTransaction) get - outputs <- replicateM (length $ txOut unsignedTransaction) get - - return PartiallySignedTransaction { unsignedTransaction, globalUnknown, inputs, outputs } - - put PartiallySignedTransaction{ unsignedTransaction, globalUnknown, inputs, outputs } = do - putByteString "psbt" - putWord8 0xff -- Header separator - - putWord8 0x01 -- Key size - putWord8 0x00 -- Unsigned Transaction type - putSizedBytes unsignedTransaction - put globalUnknown - putWord8 0x00 -- Global end - - mapM_ put inputs - mapM_ put outputs - -instance Serialize Key where - get = do - VarInt keySize <- get - guard $ keySize > 0 - t <- getWord8 - k <- getBytes (fromIntegral keySize - 1) - return (Key t k) - - put (Key t k) = do - putVarInt $ 1 + B.length k - putWord8 t - putByteString k - -instance Serialize UnknownMap where - get = go HashMap.empty - where - getItem m = do - k <- get - VarString v <- get - go $ HashMap.insert k v m - go m = do - isEnd <- lookAhead getWord8 - if isEnd == 0x00 - then return (UnknownMap m) - else getItem m - - put (UnknownMap m) = void $ HashMap.traverseWithKey (\k v -> put k >> put (VarString v)) m - -instance Serialize Input where - get = getMap getInputItem setInputUnknown emptyInput - where - setInputUnknown f input = input { inputUnknown = UnknownMap $ f (unknownMap $ inputUnknown input) } - - put Input { nonWitnessUtxo, witnessUtxo, partialSigs, sigHashType - , inputRedeemScript, inputWitnessScript, inputHDKeypaths - , finalScriptSig, finalScriptWitness, inputUnknown - } = do - whenJust (putKeyValue InNonWitnessUtxo) nonWitnessUtxo - whenJust (putKeyValue InWitnessUtxo) witnessUtxo - putPartialSig partialSigs - whenJust putSigHash sigHashType - whenJust (putKeyValue InRedeemScript) inputRedeemScript - whenJust (putKeyValue InWitnessScript) inputWitnessScript - putHDPath InBIP32Derivation inputHDKeypaths - whenJust (putKeyValue InFinalScriptSig) finalScriptSig - whenJust (putKeyValue InFinalScriptWitness) finalScriptWitness - put inputUnknown - putWord8 0x00 - where - putPartialSig = putPubKeyMap InPartialSig . fmap VarString - putSigHash sigHash = do - putKey InSigHashType - putWord8 0x04 - putWord32le (fromIntegral sigHash) - -instance Serialize Output where - get = getMap getOutputItem setOutputUnknown emptyOutput - where - setOutputUnknown f output = output { outputUnknown = UnknownMap $ f (unknownMap $ outputUnknown output) } - - put Output{ outputRedeemScript, outputWitnessScript, outputHDKeypaths, outputUnknown } = do - whenJust (putKeyValue OutRedeemScript) outputRedeemScript - whenJust (putKeyValue OutWitnessScript) outputWitnessScript - putHDPath OutBIP32Derivation outputHDKeypaths - put outputUnknown - putWord8 0x00 - -putSizedBytes :: Serialize a => a -> Put -putSizedBytes a = putVarInt (B.length bs) >> putByteString bs - where bs = encode a - -getSizedBytes :: Serialize a => Get a -getSizedBytes = getNested (fromIntegral . getVarInt <$> get) get - -putKeyValue :: (Enum t, Serialize v) => t -> v -> Put -putKeyValue t v = putKey t >> putSizedBytes v - -putKey :: Enum t => t -> Put -putKey t = putVarInt (1 :: Word8) >> putWord8 (enumWord8 t) - -getMap :: (Bounded t, Enum t) - => (Int -> a -> t -> Get a) - -> ((HashMap Key ByteString -> HashMap Key ByteString) -> a -> a) - -> a -> Get a -getMap getMapItem setUnknown = go - where - getItem keySize m (Right t) = getMapItem (fromIntegral keySize - 1) m t >>= go - getItem keySize m (Left t) = do - k <- getBytes (fromIntegral keySize - 1) - VarString v <- get - go $ setUnknown (HashMap.insert (Key t k) v) m - go m = do - keySize <- getVarInt <$> get - if keySize == 0 - then return m - else getItem keySize m =<< (word8Enum <$> getWord8) - -data InputType - = InNonWitnessUtxo - | InWitnessUtxo - | InPartialSig - | InSigHashType - | InRedeemScript - | InWitnessScript - | InBIP32Derivation - | InFinalScriptSig - | InFinalScriptWitness - deriving (Show, Eq, Enum, Bounded, Generic) - -instance NFData InputType - -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 - return $ input { nonWitnessUtxo = Just utxo } -getInputItem 0 input@Input{witnessUtxo = Nothing} InWitnessUtxo = do - utxo <- getSizedBytes - return $ input { witnessUtxo = Just utxo } -getInputItem keySize input InPartialSig = do - (k, v) <- getPartialSig - return $ input { partialSigs = HashMap.insert k v (partialSigs input) } - where - getPartialSig = (,) <$> isolate keySize get <*> (getVarString <$> get) -getInputItem 0 input@Input{sigHashType = Nothing} InSigHashType = do - VarInt size <- get - guard $ size == 0x04 - sigHash <- fromIntegral <$> getWord32le - return $ input { sigHashType = Just sigHash } -getInputItem 0 input@Input{inputRedeemScript = Nothing} InRedeemScript = do - script <- getSizedBytes - return $ input { inputRedeemScript = Just script } -getInputItem 0 input@Input{inputWitnessScript = Nothing} InWitnessScript = do - script <- getSizedBytes - return $ input { inputWitnessScript = Just script } -getInputItem keySize input InBIP32Derivation = do - (k, v) <- getHDPath keySize - return $ input { inputHDKeypaths = HashMap.insert k v (inputHDKeypaths input) } -getInputItem 0 input@Input{finalScriptSig = Nothing} InFinalScriptSig = do - script <- getSizedBytes - return $ input { finalScriptSig = Just script } -getInputItem 0 input@Input{finalScriptWitness = Nothing} InFinalScriptWitness = do - scripts <- map getVarString <$> getVarIntList - return $ input { finalScriptWitness = Just scripts } - where - getVarIntList = do - VarInt n <- get - replicateM (fromIntegral n) get -getInputItem keySize input inputType = fail $ - "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 - return $ output { outputRedeemScript = Just script } -getOutputItem 0 output@Output{outputWitnessScript = Nothing} OutWitnessScript = do - script <- getSizedBytes - return $ output { outputWitnessScript = Just script } -getOutputItem keySize output OutBIP32Derivation = do - (k, v) <- getHDPath keySize - return $ output { outputHDKeypaths = HashMap.insert k v (outputHDKeypaths output) } -getOutputItem keySize output outputType = fail $ - "Incorrect key size for output item or item already existed: " <> - show (keySize, output, outputType) - -getHDPath :: Int -> Get (PubKeyI, (Fingerprint, [KeyIndex])) -getHDPath keySize = (,) <$> isolate keySize get <*> (unPSBTHDPath <$> get) - -putHDPath :: Enum t => t -> HashMap PubKeyI (Fingerprint, [KeyIndex]) -> Put -putHDPath t = putPubKeyMap t . fmap PSBTHDPath - -newtype PSBTHDPath = PSBTHDPath { unPSBTHDPath :: (Fingerprint, [KeyIndex]) } - deriving (Show, Eq, Generic) - -instance NFData PSBTHDPath - -instance Serialize PSBTHDPath where - get = do - VarInt valueSize <- get - guard $ valueSize `mod` 4 == 0 - let numIndices = (fromIntegral valueSize - 4) `div` 4 - PSBTHDPath <$> - isolate - (fromIntegral valueSize) - ((,) <$> getWord32le <*> getKeyIndexList numIndices) - where - getKeyIndexList n = replicateM n getWord32le - put (PSBTHDPath (fp, kis)) = putVarInt (B.length bs) >> putByteString bs - where - bs = runPut $ putWord32le fp >> mapM_ putWord32le kis - -putPubKeyMap :: (Serialize a, Enum t) => t -> HashMap PubKeyI a -> Put -putPubKeyMap t = void . HashMap.traverseWithKey putItem - where - putItem k v = put (Key (enumWord8 t) (encode k)) >> put 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 ()) diff --git a/src/Network/Haskoin/Transaction/Segwit.hs b/src/Network/Haskoin/Transaction/Segwit.hs deleted file mode 100644 --- a/src/Network/Haskoin/Transaction/Segwit.hs +++ /dev/null @@ -1,141 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-| -Module : Network.Haskoin.Transaction.Segwit -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Types to represent segregated witness data and auxilliary functions to -manipulate it. See [BIP 141](https://github.com/bitcoin/bips/blob/master/bip-0141.mediawiki) -and [BIP 143](https://github.com/bitcoin/bips/blob/master/bip-0143.mediawiki) for -details. --} -module Network.Haskoin.Transaction.Segwit - ( WitnessProgram (..) - , WitnessProgramPKH (..) - , WitnessProgramSH (..) - , isSegwit - - , viewWitnessProgram - , decodeWitnessInput - - , calcWitnessProgram - , simpleInputStack - , toWitnessStack - ) where - -import Data.ByteString (ByteString) -import qualified Data.Serialize as S -import Network.Haskoin.Constants (Network) -import Network.Haskoin.Keys.Common (PubKeyI) -import Network.Haskoin.Script.Common (Script (..), - ScriptOutput (..), - decodeOutput, encodeOutput) -import Network.Haskoin.Script.SigHash (TxSignature (..), - decodeTxSig, encodeTxSig) -import Network.Haskoin.Script.Standard (ScriptInput (..), - SimpleInput (..)) -import Network.Haskoin.Transaction.Common (WitnessStack) - --- | 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 -data WitnessProgram = P2WPKH WitnessProgramPKH | P2WSH WitnessProgramSH | EmptyWitnessProgram - deriving (Eq, Show) - --- | Encode a witness program --- --- @since 0.11.0.0 -toWitnessStack :: WitnessProgram -> WitnessStack -toWitnessStack = \case - P2WPKH (WitnessProgramPKH sig key) -> [encodeTxSig sig, S.encode key] - P2WSH (WitnessProgramSH stack scr) -> stack <> [S.encode scr] - EmptyWitnessProgram -> mempty - --- | 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 -data WitnessProgramSH = WitnessProgramSH - { witnessScriptHashStack :: ![ByteString] - , witnessScriptHashScript :: !Script - } deriving (Eq, Show) - --- | Calculate the witness program from the transaction data --- --- @since 0.11.0.0 -viewWitnessProgram :: Network -> ScriptOutput -> WitnessStack -> Either String WitnessProgram -viewWitnessProgram net so witness = case so of - PayWitnessPKHash _ | length witness == 2 -> do - sig <- decodeTxSig net $ head witness - pubkey <- S.decode $ witness !! 1 - return . P2WPKH $ WitnessProgramPKH sig pubkey - PayWitnessScriptHash _ | not (null witness) -> do - redeemScript <- S.decode $ last witness - return . P2WSH $ WitnessProgramSH (init witness) redeemScript - _ | null witness -> return EmptyWitnessProgram - | otherwise -> Left "viewWitnessProgram: Invalid witness program" - --- | Analyze the witness, trying to match it with standard input structures --- --- @since 0.11.0.0 -decodeWitnessInput :: Network -> WitnessProgram -> Either String (Maybe ScriptOutput, SimpleInput) -decodeWitnessInput net = \case - P2WPKH (WitnessProgramPKH sig key) -> return (Nothing, SpendPKHash sig key) - P2WSH (WitnessProgramSH st scr) -> do - so <- decodeOutput scr - fmap (Just so, ) $ case (so, st) of - (PayPK _, [sigBS]) -> - SpendPK <$> decodeTxSig net sigBS - (PayPKHash _, [sigBS, keyBS]) -> - SpendPKHash <$> decodeTxSig net sigBS <*> S.decode keyBS - (PayMulSig _ _, "" : sigsBS) -> - SpendMulSig <$> traverse (decodeTxSig net) sigsBS - _ -> Left "decodeWitnessInput: Non-standard script output" - EmptyWitnessProgram -> Left "decodeWitnessInput: Empty witness program" - --- | Create the witness program for a standard input --- --- @since 0.11.0.0 -calcWitnessProgram :: ScriptOutput -> ScriptInput -> Either String WitnessProgram -calcWitnessProgram so si = case (so, si) of - (PayWitnessPKHash{}, RegularInput (SpendPKHash sig pk)) -> p2wpkh sig pk - (PayScriptHash{}, RegularInput (SpendPKHash sig pk)) -> p2wpkh sig pk - (PayWitnessScriptHash{}, ScriptHashInput i o) -> p2wsh i o - (PayScriptHash{}, ScriptHashInput i o) -> p2wsh i o - _ -> Left "calcWitnessProgram: Invalid segwit SigInput" - where - 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 -simpleInputStack :: SimpleInput -> [ByteString] -simpleInputStack = \case - SpendPK sig -> [f sig] - SpendPKHash sig k -> [f sig, S.encode k] - SpendMulSig sigs -> "" : fmap f sigs - where - f TxSignatureEmpty = "" - f sig = encodeTxSig sig diff --git a/src/Network/Haskoin/Util.hs b/src/Network/Haskoin/Util.hs deleted file mode 100644 --- a/src/Network/Haskoin/Util.hs +++ /dev/null @@ -1,202 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-| -Module : Network.Haskoin.Util -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -This module defines various utility functions used across the library. --} -module Network.Haskoin.Util - ( - -- * ByteString Helpers - bsToInteger - , integerToBS - , hexBuilder - , encodeHex - , decodeHex - , getBits - - -- * Maybe & Either Helpers - , eitherToMaybe - , maybeToEither - , liftEither - , liftMaybe - - -- * Other Helpers - , updateIndex - , matchTemplate - , convertBits - - -- * Triples - , fst3 - , snd3 - , lst3 - - -- * JSON Utilities - , dropFieldLabel - , dropSumLabels - - ) where - -import Control.Monad (guard) -import Control.Monad.Except (ExceptT (..), liftEither) -import Data.Aeson.Types (Options (..), SumEncoding (..), - defaultOptions, defaultTaggedObject) -import Data.Bits -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base16 as B16 -import Data.ByteString.Builder -import qualified Data.ByteString.Lazy as BL -import Data.Char (toLower) -import Data.List -import Data.Text (Text) -import qualified Data.Text.Encoding as E -import Data.Word (Word8) - --- ByteString helpers - --- | Decode a big endian 'Integer' from a 'ByteString'. -bsToInteger :: ByteString -> Integer -bsToInteger = BS.foldr f 0 . BS.reverse - where - f w n = toInteger w .|. shiftL n 8 - --- | Encode an 'Integer' to a 'ByteString' as big endian. -integerToBS :: Integer -> ByteString -integerToBS 0 = BS.pack [0] -integerToBS i - | i > 0 = BS.reverse $ BS.unfoldr f i - | otherwise = error "integerToBS not defined for negative values" - where - f 0 = Nothing - f x = Just (fromInteger x :: Word8, x `shiftR` 8) - -hexBuilder :: ByteString -> Builder -hexBuilder = byteStringHex - --- | Encode as string of human-readable hex characters. -encodeHex :: ByteString -> Text -encodeHex = E.decodeUtf8 . BL.toStrict . toLazyByteString . byteStringHex - --- | Decode string of human-readable hex characters. -decodeHex :: Text -> Maybe ByteString -decodeHex text = - let (x, b) = B16.decode (E.encodeUtf8 text) - in guard (b == BS.empty) >> return x - --- | Obtain 'Int' bits from beginning of 'ByteString'. Resulting 'ByteString' --- will be smallest required to hold that many bits, padded with zeroes to the --- right. -getBits :: Int -> ByteString -> ByteString -getBits b bs - | r == 0 = BS.take q bs - | otherwise = i `BS.snoc` l - where - (q, r) = b `quotRem` 8 - s = BS.take (q + 1) bs - i = BS.init s - l = BS.last s .&. (0xff `shiftL` (8 - r)) -- zero unneeded bits - --- Maybe and Either monad helpers - --- | Transform an 'Either' value into a 'Maybe' value. 'Right' is mapped to --- 'Just' and 'Left' is mapped to 'Nothing'. The value inside 'Left' is lost. -eitherToMaybe :: Either a b -> Maybe b -eitherToMaybe (Right b) = Just b -eitherToMaybe _ = Nothing - --- | Transform a 'Maybe' value into an 'Either' value. 'Just' is mapped to --- 'Right' and 'Nothing' is mapped to 'Left'. Default 'Left' required. -maybeToEither :: b -> Maybe a -> Either b a -maybeToEither err = maybe (Left err) Right - --- | Lift a 'Maybe' computation into the 'ExceptT' monad. -liftMaybe :: Monad m => b -> Maybe a -> ExceptT b m a -liftMaybe err = liftEither . maybeToEither err - --- Various helpers - --- | Applies a function to only one element of a list defined by its index. If --- the index is out of the bounds of the list, the original list is returned. -updateIndex :: Int -- ^ index of the element to change - -> [a] -- ^ list of elements - -> (a -> a) -- ^ function to apply - -> [a] -- ^ result with one element changed -updateIndex i xs f - | i < 0 || i >= length xs = xs - | otherwise = l ++ (f h : r) - where - (l,h:r) = splitAt i xs - --- | Use the list @[b]@ as a template and try to match the elements of @[a]@ --- against it. For each element of @[b]@ return the (first) matching element of --- @[a]@, or 'Nothing'. Output list has same size as @[b]@ and contains results --- in same order. Elements of @[a]@ can only appear once. -matchTemplate :: [a] -- ^ input list - -> [b] -- ^ list to serve as a template - -> (a -> b -> Bool) -- ^ comparison function - -> [Maybe a] -matchTemplate [] bs _ = replicate (length bs) Nothing -matchTemplate _ [] _ = [] -matchTemplate as (b:bs) f = case break (`f` b) as of - (l,r:rs) -> Just r : matchTemplate (l ++ rs) bs f - _ -> Nothing : matchTemplate as bs f - --- | Returns the first value of a triple. -fst3 :: (a,b,c) -> a -fst3 (a,_,_) = a - --- | Returns the second value of a triple. -snd3 :: (a,b,c) -> b -snd3 (_,b,_) = b - --- | Returns the last value of a triple. -lst3 :: (a,b,c) -> c -lst3 (_,_,c) = c - --- | Field label goes lowercase and first @n@ characters get removed. -dropFieldLabel :: Int -> Options -dropFieldLabel n = defaultOptions - { fieldLabelModifier = map toLower . drop n - } - --- | Transformation from 'dropFieldLabel' is applied with argument @f@, plus --- constructor tags are lowercased and first @c@ characters removed. @tag@ is --- used as the name of the object field name that will hold the transformed --- constructor tag as its value. -dropSumLabels :: Int -> Int -> String -> Options -dropSumLabels c f tag = (dropFieldLabel f) - { constructorTagModifier = map toLower . drop c - , sumEncoding = defaultTaggedObject { tagFieldName = tag } - } - --- | Convert from one power-of-two base to another, as long as it fits in a --- 'Word'. -convertBits :: Bool -> Int -> Int -> [Word] -> ([Word], Bool) -convertBits pad frombits tobits i = (reverse yout, rem') - where - (xacc, xbits, xout) = foldl' outer (0, 0, []) i - (yout, rem') - | pad && xbits /= 0 = - let xout' = (xacc `shiftL` (tobits - xbits)) .&. maxv : xout - in (xout', False) - | pad = (xout, False) - | xbits /= 0 = (xout, True) - | otherwise = (xout, False) - maxv = 1 `shiftL` tobits - 1 - max_acc = 1 `shiftL` (frombits + tobits - 1) - 1 - outer (acc, bits, out) it = - let acc' = ((acc `shiftL` frombits) .|. it) .&. max_acc - bits' = bits + frombits - (out', bits'') = inner acc' out bits' - in (acc', bits'', out') - inner acc out bits - | bits >= tobits = - let bits' = bits - tobits - out' = ((acc `shiftR` bits') .&. maxv) : out - in inner acc out' bits' - | otherwise = (out, bits) diff --git a/test/Haskoin/Address/Bech32Spec.hs b/test/Haskoin/Address/Bech32Spec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Address/Bech32Spec.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE OverloadedStrings #-} +module Haskoin.Address.Bech32Spec + ( spec + ) where + +import Control.Monad +import Data.Bits (xor) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Char (chr, ord, toLower) +import Data.Maybe +import Data.String.Conversions +import Data.Text (Text, append, pack, snoc, uncons) +import qualified Data.Text as T +import Data.Word (Word8) +import Haskoin.Address +import Haskoin.Address.Bech32 +import Haskoin.Util +import Test.Hspec +import Test.HUnit + +spec = do + describe "bech32 checksum" $ do + it "should have valid checksum" $ forM_ validChecksums testValidChecksum + it "should have invalid checksum" $ + forM_ invalidChecksums testInvalidChecksum + it "should be a valid address" $ forM_ validAddresses testValidAddress + it "should be an invalid address" $ + forM_ invalidAddresses testInvalidAddress + it "should be same for the input in different case" $ + all (== Just "test12hrzfj") . map (flip bech32Encode []) $ hrpCaseVariants + describe "more encoding/decoding cases" $ do + it "length > 90" $ + assert $ + isNothing $ + bech32Encode "bc" (replicate 82 (word5 (1 :: Word8))) + it "segwit version bounds" $ + assert $ isNothing $ segwitEncode "bc" 17 [] + it "segwit prog len version 0" $ + assert $ isNothing $ segwitEncode "bc" 0 (replicate 30 1) + it "segwit prog len version != 0" $ + assert $ isJust $ segwitEncode "bc" 1 (replicate 30 1) + it "segwit prog len version != 0" $ + assert $ isNothing $ segwitEncode "bc" 1 (replicate 41 1) + it "empty HRP encode" $ assert $ isNothing $ bech32Encode "" [] + it "empty HRP encode" $ + assert $ isNothing $ bech32Decode "10a06t8" + it "hrp lowercased" $ + bech32Encode "HRP" [] `shouldBe` bech32Encode "hrp" [] + + +testValidChecksum :: Bech32 -> Assertion +testValidChecksum checksum = case bech32Decode checksum of + Nothing -> assertFailure (show checksum) + Just (resultHRP, resultData) -> do + -- test that a corrupted checksum fails decoding. + let (hrp, rest) = T.breakOnEnd "1" checksum + Just (first, rest') = uncons rest + checksumCorrupted = (hrp `snoc` chr (ord first `xor` 1)) `append` rest' + assertBool (show checksum ++ " corrupted") + $ isNothing (bech32Decode checksumCorrupted) + -- test that re-encoding the decoded checksum results in the same checksum. + let checksumEncoded = bech32Encode resultHRP resultData + expectedChecksum = Just $ T.toLower checksum + assertEqual (show checksum ++ " re-encode") + 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 + hrp = T.take 2 address' + case segwitDecode hrp address of + Nothing -> assertFailure "decode failed" + Just (witver, witprog) -> do + assertEqual (show address) + (decodeHex hexscript) + (Just $ segwitScriptPubkey witver witprog) + assertEqual (show address) + (Just address') + (segwitEncode hrp witver witprog) + +testInvalidAddress :: Text -> Assertion +testInvalidAddress address = do + assertBool (show address) (isNothing $ segwitDecode "bc" address) + assertBool (show address) (isNothing $ segwitDecode "tb" address) + +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 :: [Text] +validChecksums = + [ "A12UEL5L" + , "an83characterlonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1tt5tgs" + , "abcdef1qpzry9x8gf2tvdw0s3jn54khce6mua7lmqqqxw" + , "11qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqc8247j" + , "split1checkupstagehandshakeupstreamerranterredcaperred2y9e3w" + ] + +invalidChecksums :: [Text] +invalidChecksums = + [ " 1nwldj5" + , "\DEL1axkwrx" + , "an84characterslonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1569pvx" + , "pzry9x0s0muk" + , "1pzry9x0s0muk" + , "x1b4n0q5v" + , "li1dgmt3" + , "de1lg7wt\xFF" + ] + +validAddresses :: [(Text, Text)] +validAddresses = + [ ("BC1QW508D6QEJXTDG4Y5R3ZARVARY0C5XW7KV8F3T4", "0014751e76e8199196d454941c45d1b3a323f1433bd6") + , ("tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sl5k7" + ,"00201863143c14c5166804bd19203356da136c985678cd4d27a1b8c6329604903262") + , ("bc1pw508d6qejxtdg4y5r3zarvary0c5xw7kw508d6qejxtdg4y5r3zarvary0c5xw7k7grplx" + ,"5128751e76e8199196d454941c45d1b3a323f1433bd6751e76e8199196d454941c45d1b3a323f1433bd6") + , ("BC1SW50QA3JX3S", "6002751e") + , ("bc1zw508d6qejxtdg4y5r3zarvaryvg6kdaj", "5210751e76e8199196d454941c45d1b3a323") + , ("tb1qqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesrxh6hy" + ,"0020000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433") + ] + +invalidAddresses :: [Text] +invalidAddresses = + [ "tc1qw508d6qejxtdg4y5r3zarvary0c5xw7kg3g4ty" + , "bc1qw508d6qejxtdg4y5r3zarvary0c5xw7kv8f3t5" + , "BC13W508D6QEJXTDG4Y5R3ZARVARY0C5XW7KN40WF2" + , "bc1rw5uspcuh" + , "bc10w508d6qejxtdg4y5r3zarvary0c5xw7kw508d6qejxtdg4y5r3zarvary0c5xw7kw5rljs90" + , "BC1QR508D6QEJXTDG4Y5R3ZARVARYV98GJ9P" + , "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sL5k7" + , "bc1zw508d6qejxtdg4y5r3zarvaryvqyzf3du" + , "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3pjxtptv" + , "bc1gmk9yu" + ] + +hrpCaseVariants:: [Text] +hrpCaseVariants = map T.pack hrpTestPermutations + +hrpTestPermutations :: [String] +hrpTestPermutations = do + a <- ['t', 'T'] + b <- ['e', 'E'] + c <- ['s', 'S'] + d <- ['t', 'T'] + return [a, b, c, d] diff --git a/test/Haskoin/Address/CashAddrSpec.hs b/test/Haskoin/Address/CashAddrSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Address/CashAddrSpec.hs @@ -0,0 +1,280 @@ +{-# 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.Address.CashAddr +import Haskoin.Constants +import Haskoin.Util +import Test.Hspec +import Test.HUnit + +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 = + addrToString bch =<< + stringToAddr btc "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu" + addr `shouldBe` + Just "bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a" + it "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR" $ do + let addr = + addrToString bch =<< + stringToAddr btc "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR" + addr `shouldBe` + Just "bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy" + it "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb" $ do + let addr = + addrToString bch =<< + stringToAddr btc "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb" + addr `shouldBe` + Just "bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r" + it "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC" $ do + let addr = + addrToString bch =<< + stringToAddr btc "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC" + addr `shouldBe` + Just "bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq" + it "3LDsS579y7sruadqu11beEJoTjdFiFCdX4" $ do + let addr = + addrToString bch =<< + stringToAddr btc "3LDsS579y7sruadqu11beEJoTjdFiFCdX4" + addr `shouldBe` + Just "bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e" + it "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw" $ do + let addr = + addrToString bch =<< + stringToAddr btc "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw" + addr `shouldBe` + Just "bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37" + describe "base58 to cashaddr translation test vectors" $ do + it "bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a" $ do + let addr = + addrToString btc =<< + stringToAddr + bch + "bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a" + addr `shouldBe` Just "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu" + it "bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy" $ do + let addr = + addrToString btc =<< + stringToAddr + bch + "bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy" + addr `shouldBe` Just "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR" + it "bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r" $ do + let addr = + addrToString btc =<< + stringToAddr + bch + "bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r" + addr `shouldBe` Just "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb" + it "bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq" $ do + let addr = + addrToString btc =<< + stringToAddr + bch + "bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq" + addr `shouldBe` Just "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC" + it "bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e" $ do + let addr = + addrToString btc =<< + stringToAddr + bch + "bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e" + addr `shouldBe` Just "3LDsS579y7sruadqu11beEJoTjdFiFCdX4" + it "bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37" $ do + let addr = + addrToString btc =<< + stringToAddr + 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 new file mode 100644 --- /dev/null +++ b/test/Haskoin/AddressSpec.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE OverloadedStrings #-} +module Haskoin.AddressSpec (spec) where + +import Data.Aeson +import Data.Aeson.Types +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS (append, empty, pack) +import Data.Either (isRight) +import Data.Maybe (fromJust, isJust) +import qualified Data.Serialize as S +import Data.Text (Text) +import Haskoin.Address +import Haskoin.Address.Base58 +import Haskoin.Constants +import Haskoin.Keys (derivePubKeyI) +import Haskoin.Test +import Test.Hspec +import Test.HUnit (Assertion, assertBool, assertEqual) +import Test.QuickCheck + +spec :: Spec +spec = do + let net = btc + describe "btc address" . it "base58 encodings" $ mapM_ runVector vectors + describe "btc-test address" $ props btcTest + describe "bch address" $ props bch + describe "bch-test address" $ props bchTest + describe "bch-regtest address" $ props bchRegTest + describe "json serialization" . it "encodes and decodes address" $ + forAll arbitraryAddress (testCustom (addrFromJSON net) (addrToJSON net)) + describe "witness address vectors" . it "p2sh(pwpkh)" $ + mapM_ testCompatWitness compatWitnessVectors + +props :: Network -> Spec +props net = do + it "encodes and decodes base58 bytestring" $ + property $ + forAll arbitraryBS $ \bs -> decodeBase58 (encodeBase58 bs) == Just bs + it "encodes and decodes base58 bytestring with checksum" $ + property $ + forAll arbitraryBS $ \bs -> + decodeBase58Check (encodeBase58Check bs) == Just bs + it "encodes and decodes address" $ + property $ + forAll arbitraryAddress $ \a -> + (stringToAddr net =<< addrToString net a) == Just a + it "shows and reads address" $ + property $ forAll arbitraryAddress $ \a -> read (show a) == a + +runVector :: (ByteString, Text, Text) -> Assertion +runVector (bs, e, chk) = do + assertEqual "encodeBase58" e b58 + assertEqual "encodeBase58Check" chk b58Chk + assertEqual "decodeBase58" (Just bs) (decodeBase58 b58) + assertEqual "decodeBase58Check" (Just bs) (decodeBase58Check b58Chk) + where + b58 = encodeBase58 bs + b58Chk = encodeBase58Check bs + +vectors :: [(ByteString, Text, Text)] +vectors = + [ ( BS.empty, "", "3QJmnh" ) + , ( BS.pack [0], "1", "1Wh4bh" ) + , ( BS.pack [0,0,0,0], "1111", "11114bdQda" ) + , ( BS.pack [0,0,1,0,0], "11LUw", "113CUwsFVuo" ) + , ( BS.pack [255], "5Q", "VrZDWwe" ) + , ( BS.pack [0,0,0,0] `BS.append` BS.pack [1..255] + , "1111cWB5HCBdLjAuqGGReWE3R3CguuwSjw6RHn39s2yuDRTS5NsBgNiFpWgAnEx6VQi8csexkgYw3mdYrMHr8x9i7aEwP8kZ7vccXWqKDvGv3u1GxFKPuAkn8JCPPGDMf3vMMnbzm6Nh9zh1gcNsMvH3ZNLmP5fSG6DGbbi2tuwMWPthr4boWwCxf7ewSgNQeacyozhKDDQQ1qL5fQFUW52QKUZDZ5fw3KXNQJMcNTcaB723LchjeKun7MuGW5qyCBZYzA1KjofN1gYBV3NqyhQJ3Ns746GNuf9N2pQPmHz4xpnSrrfCvy6TVVz5d4PdrjeshsWQwpZsZGzvbdAdN8MKV5QsBDY" + , "111151KWPPBRzdWPr1ASeu172gVgLf1YfUp6VJyk6K9t4cLqYtFHcMa2iX8S3NJEprUcW7W5LvaPRpz7UG7puBj5STE3nKhCGt5eckYq7mMn5nT7oTTic2BAX6zDdqrmGCnkszQkzkz8e5QLGDjf7KeQgtEDm4UER6DMSdBjFQVa6cHrrJn9myVyyhUrsVnfUk2WmNFZvkWv3Tnvzo2cJ1xW62XDfUgYz1pd97eUGGPuXvDFfLsBVd1dfdUhPwxW7pMPgdWHTmg5uqKGFF6vE4xXpAqZTbTxRZjCDdTn68c2wrcxApm8hq3JX65Hix7VtcD13FF8b7BzBtwjXq1ze6NMjKgUcqpJTN9vt" + ) + ] + +testCustom :: Eq a => (Value -> Parser a) -> (a -> Value) -> a -> Bool +testCustom f g x = parseMaybe f (g x) == Just x + +compatWitnessVectors :: [(Network, Text, Text)] +compatWitnessVectors = + [ ( btcTest + , "cNUnpYpMsJXYCERYBciJnsWBpcYEFjdcbq6dxj4SskGhs7uHuJ7Q" + , "2N6PDTueBHvXzW61B4oe5SW1D3v2Z3Vpbvw") + ] + +testCompatWitness :: (Network, Text, Text) -> Assertion +testCompatWitness (net, seckey, addr) = do + let seckeyM = fromWif net seckey + assertBool "decode seckey" (isJust seckeyM) + let pubkey = derivePubKeyI (fromJust seckeyM) + let addrM = addrToString btcTest (pubKeyCompatWitnessAddr pubkey) + assertBool "address can be encoded" (isJust addrM) + assertEqual "witness address matches" addr (fromJust addrM) diff --git a/test/Haskoin/BlockSpec.hs b/test/Haskoin/BlockSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/BlockSpec.hs @@ -0,0 +1,359 @@ +{-# LANGUAGE OverloadedStrings #-} +module Haskoin.BlockSpec + ( spec + ) where + +import Control.Monad.State.Strict +import Data.Aeson as A +import Data.Either (fromRight) +import Data.Map.Strict (singleton) +import Data.Maybe (fromJust) +import Data.Serialize as S +import Data.String (fromString) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Haskoin.Block +import Haskoin.Block.Headers +import Haskoin.Block.Merkle +import Haskoin.Constants +import Haskoin.Test +import Haskoin.Transaction +import Test.Hspec +import Test.HUnit hiding (State) +import Test.QuickCheck + +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 + either error (const $ return ()) bnsE + where + bhs = appendBlocks net 6 bh i + +spec :: Spec +spec = do + let net = bchRegTest + describe "blockchain headers" $ do + it "gets best block" $ + let bb = + withChain net $ do + chain net (getGenesisHeader net) 100 + getBestBlockHeader + in nodeHeight bb `shouldBe` 100 + it "builds a block locator" $ + let 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" $ + let bb = withChain net $ splitChain net >> getBestBlockHeader + in nodeHeight bb `shouldBe` 4035 + describe "block hash" $ do + it "encodes and decodes block hash" $ + property $ + forAll arbitraryBlockHash $ \h -> + hexToBlockHash (blockHashToHex h) == Just h + it "from string block hash" $ + property $ + forAll arbitraryBlockHash $ \h -> + fromString (cs $ blockHashToHex h) == h + it "show and read block hash" $ + property $ forAll arbitraryBlockHash $ \h -> read (show h) == h + it "json block hash" $ property $ forAll arbitraryBlockHash testID + describe "merkle trees" $ do + let net' = btc + it "builds tree of right width at height 1" $ property testTreeWidth + it "builds tree of right width at height 0" $ property testBaseWidth + it "builds and extracts partial merkle tree" $ + property $ + forAll + (listOf1 ((,) <$> arbitraryTxHash <*> arbitrary)) + (buildExtractTree net') + it "merkle root test vectors" $ + mapM_ runMerkleVector merkleVectors + describe "compact number" $ do + it "compact number local vectors" testCompact + it "compact number imported vectors" testCompactBitcoinCore + describe "block serialization" $ do + it "encodes and decodes block" $ + property $ forAll (arbitraryBlock net) cerealID + it "encodes and decodes block JSON" $ + property $ forAll (arbitraryBlock net) testID + it "encodes and decodes block header" $ + property $ forAll arbitraryBlockHeader cerealID + it "encodes and decodes block header JSON" $ + property $ forAll arbitraryBlockHeader testID + it "encodes and decodes getblocks" $ + property $ forAll arbitraryGetBlocks cerealID + it "encodes and decodes getheaders" $ + property $ forAll arbitraryGetHeaders cerealID + it "encodes and decdoes headers" $ + property $ forAll arbitraryHeaders cerealID + it "encodes and decodes merkle block" $ + property $ forAll arbitraryMerkleBlock cerealID + describe "helper functions" $ do + it "computes bitcoin block subsidy correctly" (testSubsidy btc) + it "computes regtest block subsidy correctly" (testSubsidy btcRegTest) + +-- 0 → → 2015 → → → → → → → 4031 +-- ↓ +-- → → 2035 → → → → → → 4035* +-- ↓ +-- → → 2185 +splitChain :: Network -> State HeaderMemory () +splitChain net = do + start <- go 1 (getGenesisHeader net) 2015 + e 2015 (head start) + tail1 <- go 2 (nodeHeader $ head start) 2016 + e 4031 (head tail1) + tail2 <- go 3 (nodeHeader $ head start) 20 + e 2035 (head tail2) + tail3 <- go 4 (nodeHeader $ head tail2) 2000 + e 4035 (head tail3) + tail4 <- go 5 (nodeHeader $ head tail2) 150 + e 2185 (head tail4) + sp1 <- splitPoint (head tail1) (head tail3) + unless (sp1 == head start) $ + error $ + "Split point wrong between blocks 4031 and 4035: " ++ + show (nodeHeight sp1) + sp2 <- splitPoint (head tail4) (head tail3) + unless (sp2 == head tail2) $ + error $ + "Split point wrong between blocks 2185 and 4035: " ++ + show (nodeHeight sp2) + where + e n bn = + unless (nodeHeight bn == n) $ + error $ + "Node height " ++ + show (nodeHeight bn) ++ " of first chunk should be " ++ show n + go seed start n = do + let bhs = appendBlocks net seed start n + bnE <- connectBlocks net myTime bhs + case bnE of + Right bn -> return bn + Left ex -> error ex + +{- 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) + where + (f, h) = buildPartialMerkle txs + (r, m) = + fromRight (error "Could not extract matches from Merkle tree") $ + extractMatches net f h (length txs) + +testCompact :: Assertion +testCompact = do + assertEqual "vector 1" 0x05123456 (encodeCompact 0x1234560000) + assertEqual "vector 2" (0x1234560000, False) (decodeCompact 0x05123456) + assertEqual "vector 3" 0x0600c0de (encodeCompact 0xc0de000000) + assertEqual "vector 4" (0xc0de000000, False) (decodeCompact 0x0600c0de) + assertEqual "vector 5" 0x05c0de00 (encodeCompact (-0x40de000000)) + assertEqual "vector 6" (-0x40de000000, False) (decodeCompact 0x05c0de00) + +testCompactBitcoinCore :: Assertion +testCompactBitcoinCore = do + assertEqual "zero" (0, False) (decodeCompact 0x00000000) + assertEqual + "zero (encode · decode)" + 0x00000000 + (encodeCompact . fst $ decodeCompact 0x00000000) + assertEqual "rounds to zero" (0, False) (decodeCompact 0x00123456) + assertEqual "rounds to zero" (0, False) (decodeCompact 0x01003456) + assertEqual "rounds to zero" (0, False) (decodeCompact 0x02000056) + assertEqual "rounds to zero" (0, False) (decodeCompact 0x03000000) + assertEqual "rounds to zero" (0, False) (decodeCompact 0x04000000) + assertEqual "rounds to zero" (0, False) (decodeCompact 0x00923456) + assertEqual "rounds to zero" (0, False) (decodeCompact 0x01803456) + assertEqual "rounds to zero" (0, False) (decodeCompact 0x02800056) + assertEqual "rounds to zero" (0, False) (decodeCompact 0x03800000) + assertEqual "rounds to zero" (0, False) (decodeCompact 0x04800000) + assertEqual "vector 1 (decode)" (0x12, False) (decodeCompact 0x01123456) + assertEqual + "vector 1 (encode · decode)" + 0x01120000 + (encodeCompact . fst $ decodeCompact 0x01123456) + assertEqual "0x80 bit set" 0x02008000 (encodeCompact 0x80) + assertEqual + "vector 2 (negative) (decode)" + (-0x7e, False) + (decodeCompact 0x01fedcba) + assertEqual + "vector 2 (negative) (encode · decode)" + 0x01fe0000 + (encodeCompact . fst $ decodeCompact 0x01fedcba) + assertEqual "vector 3 (decode)" (0x1234, False) (decodeCompact 0x02123456) + assertEqual + "vector 3 (encode · decode)" + 0x02123400 + (encodeCompact . fst $ decodeCompact 0x02123456) + assertEqual "vector 4 (decode)" (0x123456, False) (decodeCompact 0x03123456) + assertEqual + "vector 4 (encode · decode)" + 0x03123456 + (encodeCompact . fst $ decodeCompact 0x03123456) + assertEqual + "vector 5 (decode)" + (0x12345600, False) + (decodeCompact 0x04123456) + assertEqual + "vector 5 (encode · decode)" + 0x04123456 + (encodeCompact . fst $ decodeCompact 0x04123456) + assertEqual + "vector 6 (decode)" + (-0x12345600, False) + (decodeCompact 0x04923456) + assertEqual + "vector 6 (encode · decode)" + 0x04923456 + (encodeCompact . fst $ decodeCompact 0x04923456) + assertEqual + "vector 7 (decode)" + (0x92340000, False) + (decodeCompact 0x05009234) + assertEqual + "vector 7 (encode · decode)" + 0x05009234 + (encodeCompact . fst $ decodeCompact 0x05009234) + assertEqual + "vector 8 (decode)" + ( 0x1234560000000000000000000000000000000000000000000000000000000000 + , False) + (decodeCompact 0x20123456) + assertEqual + "vector 8 (encode · decode)" + 0x20123456 + (encodeCompact . fst $ decodeCompact 0x20123456) + assertBool "vector 9 (decode) (overflow)" (snd $ decodeCompact 0xff123456) + assertBool + "vector 9 (decode) (positive)" + ((> 0) . fst $ decodeCompact 0xff123456) + +runMerkleVector :: (Text, [Text]) -> Assertion +runMerkleVector (r, hs) = + assertBool "merkle vector" $ + buildMerkleRoot (map f hs) == getTxHash (f r) + where + f = fromJust . hexToTxHash + +merkleVectors :: [(Text, [Text])] +merkleVectors = + -- Block 000000000000cd7e8cf6510303dde76121a1a791c15dba0be4be7022b07cf9e1 + [ ( "fb6698ac95b754256c5e71b4fbe07638cb6ca83ee67f44e181b91727f09f4b1f" + , [ "dd96fdcfaec994bf583af650ff6022980ee0ba1686d84d0a3a2d24eabf34bc52" + , "1bc216f786a564378710ae589916fc8e092ddfb9f24fe6c47b733550d476d5d9" + , "a1db0b0194426064b067899ff2d975fb277fd52dbb1a38370800c76dd6503d41" + , "d69f7fb0e668fbd437d1bf5211cc34d7eb8746f50cfddf705fe10bc2f8f7035f" + , "5b4057cd80be7df5ed2ac42b776897ed3c26e3a01e4072075b8129c587094ef6" + , "ed6dabcfba0ef43c50d89a8a0e4b236b1bc6585d4c3bbf49728b55f44312d6bc" + , "056aaa9a3c635909c794e9b0acc7dccb0456c59a84c6b08417335bee4515e3d3" + , "05bae5f1d1c874171692e1fc06f664e63eb143d3f096601ef938e4a9012eee66" + , "b5e48e94e3f2fba197b3f591e01f47e185d7834d669529d44078e41c671aab0f" + , "3b56aeadfc0c5484fd507bc89f13f2e5f61c42e0a4ae9062eda9a9aeef7db6a4" + , "2affa187e1ebb94a2a86578b9f64951e854ff3d346fef259acfb6d0f5212e0d3" + ] + ) + -- Block 00000000000007cc4b6f07bfed72bccc1ed8dd031a93969a4c22211f784457d4 + , ( "886fea311d2dc64c315519f2d647e43998d780d2170f77e53dc0d85bf2ee680c" + , [ "c9c9e5211512629fd111cc071d745b8c79bf486b4ea95489eb5de08b5d786b8e" + , "20beb0ee30dfd323ade790ce9a46ae7a174f9ea44ce22a17c4d4eb23b7016f51" + , "d4cb7dd741e78a8f57e12f6c8ddb0361ff2a5bf9365bd7d7df761060847daf9a" + , "ddbfa6fdd29d4b47aeaadf82a4bf0a93d58cd7d8401fabf860a1ae8eeb51f42e" + , "9d82bafe44abee248b968c86f165051c8413482c232659795335c52922dab471" + , "86035372d31b53efd848cea7231aa9738c209aff64d3c59b1619341afb5b6ba3" + , "11e7a7393d9658813dfaebc04fa6d4b73bac8d641bffa7067da879523d43d030" + , "2f676b9aa5bc0ebf3395032c84c466e40cac29f80434cd1138e31c2d0fcc5c13" + , "37567d559fbfae07fda9a90de0ce30b202128bc8ebdfef5ad2b53e865a3478c2" + , "0b8e6c1200c454361e94e261738429e9c9b8dcffd85ec8511bbf5dc7e2e0ada8" + ] + ) + -- Block 00000000839a8e6886ab5951d76f411475428afc90947ee320161bbf18eb6048 + , ( "0e3e2357e806b6cdb1f70b54c3a3a17b6714ee1f0e68bebb44a74b1efd512098" + , [ "0e3e2357e806b6cdb1f70b54c3a3a17b6714ee1f0e68bebb44a74b1efd512098" ] + ) + -- Block 000000000004d160ac1f7b775d7c1823345aeadd5fcb29ca2ad2403bb7babd4c + , ( "aae018650f513fc42d55b2210ec3ceeeb194fb1261d37989de07451fc0cbac5c" + , [ "a4454f22831acd7904a9902c5070a3ee4bf4c2b13bc6b2dc66735dd3c4414028" + , "45297f334278885108dd38a0b689ed95a4373dd3f7e4413e6aebdc2654fb771b" + ] + ) + -- Block 000000000001d1b13a7e86ddb20da178f20d6da5cd037a29c2a15b8b84cc774e + , ( "ca3580505feb87544760ac14a5859659e23be05f765bbed9f86a3c9aad1a5d0c" + , [ "60702384c6e9d34ff03c2b3e726bdc649befe603216815bd0a2974921d0d9549" + , "11f40f58941d2a81a1616a3b84b7dd8b9d07e68750827de488c11a18f54220bb" + , "d78e82527aa8cf16e375010bc666362c0258d3c0da1885a1871121706da8b633" + ] + ) + -- Block 0000000000000630a4e2266a31776e952a19b7c99a6387917d9de9032f608021 + , ( "dcce8be0a9a41e7bb726c5b49d957d90b5308e3dc5dce070ccbc8996e265a6c2" + , [ "c0f58ff12cd1023b05f8f7035cc62bf50958ddb216a4e0eb5471deb7ef25fe81" + , "24e5bbf9008641b8fcf3d076fef66c28c695362ba9f6a6042f8275a98414ee92" + , "e8e1f72abad5e34dabc0f6de46a484b17a9af857d1c41de19482fadf6f7f4b27" + , "540e4d34d9fd9e5ec02853054be7ad9260379bc23388489049cca1b0f7cf518a" + , "324444835c5fe0545f98c4240011b75e6ea1bb76f41829e4cfbe7f75b6cee924" + , "e7d31437ac21bceb0c222a82b2723e2b8a7654147e33397679f041537022a4b2" + , "a8b5768d8b33525ee89d546a6a6897f8e42ba9d56a2c5e871a5d2ab40258dc95" + , "7ba712b31bae8d45810a5cda3838c7e7fb9abd6e88bb4b3ee79be9ea2f714bb4" + , "2ae1c4d927b06edaa626b230976ad8062bbae24da9378d1de2409da5ab08a26d" + , "3c417dc8087d6878003624b74431e17fec9ca761389034b1b1e0f32cbfb11f4f" + , "de6de7beae8d8c98c7d46b4409d5460e58e3204d8b4caed256c7471998595909" + , "c7c3c211402b7c4379f7b01fadc67260ee58d11e8d0bcce3d68cb45f3467e99d" + , "77aa2717e727a096d81074bd46ae59462692d20a1acc1a01b2535518ae5aeb53" + , "4859a710bb673aca46208bbd59d1000ae990dafff5f70b56f0853aeeaea3948b" + , "38deca6991988e461b83aa0d49ffef0f304c4b760371682d152eeb8c56a48174" + , "648f4f50dada3574e2dfe2dc68956b01dd97d543859a3540bbe1ef5418d0e494" + , "9cd7be42c2f0cd8bf38738c162cd05108e213ec7958bf2571cb627872963f5c4" + , "6740e0dd8b97e23864af41839fc197238d2f0dbefce9a82c657556be65c465fa" + , "f75c2e4b70db4b0aabc44b77af1ae75d305340fcf6e7b5f806ddcba4aa42b55d" + , "e125c488636749da68e6696b97525a77146c0777c7946927e37afd513d74a4e6" + , "c20526f119aea10880af631eba7f0b60385a22e0b0c402fe8508d41952e58be9" + , "6456c023c7e245f5c57a168633a23f57f4fadb651115f807694a6bed14ae3b55" + , "98b26e364e2888c9f264e4b5e13103c89608609774eb07ce933d8a2a45d19776" + , "2efaa4f167bb65ba5684f8076cd9279fd67fd9c67388c8862809bab5542e637d" + , "ec44eeb84d8d976d77079a822710b4dfdb11a2d9a03d8cc00bab0ae424e84666" + , "410730d9f807d81ac48b8eafac6f1d36642c1c370241b367a35f0bac6ac7c05f" + , "e95a7d0d477fd3db22756a3fd390a50c7bc48dc9e946fea9d24bd0866b3bb0e9" + , "a72fec99d14939216628aaf7a0afc4c017113bcae964e777e6b508864eeaacc4" + , "8548433310fcf75dbbc042121e8318c678e0a017534786dd322a91cebe8d213f" + ] + ) + ] + +testID :: (FromJSON a, ToJSON a, Eq a) => a -> Bool +testID x = + (A.decode . A.encode) (singleton ("object" :: String) x) == + Just (singleton ("object" :: String) x) + +cerealID :: (Serialize a, Eq a) => a -> Bool +cerealID x = S.decode (S.encode x) == Right x + +testSubsidy :: Network -> Assertion +testSubsidy net = go (2 * 50 * 100 * 1000 * 1000) 0 + where + go previous_subsidy halvings = do + let height = halvings * getHalvingInterval net + subsidy = computeSubsidy net height + if halvings >= 64 + then subsidy `shouldBe` 0 + else do + subsidy `shouldBe` (previous_subsidy `div` 2) + go subsidy (halvings + 1) diff --git a/test/Haskoin/Crypto/HashSpec.hs b/test/Haskoin/Crypto/HashSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Crypto/HashSpec.hs @@ -0,0 +1,1269 @@ +{-# LANGUAGE OverloadedStrings #-} +module Haskoin.Crypto.HashSpec (spec) where + +import Data.ByteString (ByteString) +import Data.Map.Strict (singleton) +import Data.Maybe (fromJust) +import Data.Serialize as S +import Data.String (fromString) +import Data.String.Conversions +import Haskoin.Block +import Haskoin.Crypto +import Haskoin.Test +import Haskoin.Util +import Test.Hspec +import Test.HUnit (Assertion, assertBool) +import Test.QuickCheck + +-- Test vectors from NIST +-- http://csrc.nist.gov/groups/STM/cavp/documents/drbg/drbgtestvectors.zip +-- About 1/3 of HMAC DRBG SHA-256 test vectors are tested here + +spec :: Spec +spec = + describe "hash" $ do + it "join512( split512(h) ) == h" $ + property $ + forAll arbitraryHash256 $ forAll arbitraryHash256 . joinSplit512 + it "decodeCompact . encodeCompact i == i" $ property decEncCompact + it "from string 64-byte hash" $ + property $ + forAll arbitraryHash512 $ \h -> + fromString (cs $ encodeHex $ encode h) == h + it "from string 32-byte hash" $ + property $ + forAll arbitraryHash256 $ \h -> + fromString (cs $ encodeHex $ encode h) == h + it "from string 20-byte hash" $ + property $ + forAll arbitraryHash160 $ \h -> + fromString (cs $ encodeHex $ encode h) == h + it "encodes and decodes bytestring" $ + property $ forAll arbitraryBS cerealID + it "encodes and decodes hash160" $ + property $ forAll arbitraryHash160 cerealID + it "encodes and decodes hash256" $ + property $ forAll arbitraryHash256 cerealID + it "encodes and decodes hash512" $ + property $ forAll arbitraryHash512 cerealID + +type TestVector = [ByteString] + +{- + [SHA-256] + [PredictionResistance = False] + [EntropyInputLen = 256] + [NonceLen = 128] + [PersonalizationStringLen = 0] + [AdditionalInputLen = 0] + [ReturnedBitsLen = 1024] +-} + +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 +decEncCompact i + -- Integer completely fits inside the mantisse + | abs i <= 0x007fffff = decodeCompact (encodeCompact i) == (i, False) + -- Otherwise precision will be lost and the decoded result will + -- be smaller than the original number + | i >= 0 = fst (decodeCompact (encodeCompact i)) < i + | otherwise = fst (decodeCompact (encodeCompact i)) > i + +cerealID :: (Serialize a, Eq a) => a -> Bool +cerealID x = decode (encode x) == Right x + +t1 :: [TestVector] +t1 = + [ + -- COUNT = 0 + [ "ca851911349384bffe89de1cbdc46e6831e44d34a4fb935ee285dd14b71a7488" + , "659ba96c601dc69fc902940805ec0ca8" + , "" + , "" + , "" + , "e528e9abf2dece54d47c7e75e5fe302149f817ea9fb4bee6f4199697d04d5b89d54fbb978a15b5c443c9ec21036d2460b6f73ebad0dc2aba6e624abf07745bc107694bb7547bb0995f70de25d6b29e2d3011bb19d27676c07162c8b5ccde0668961df86803482cb37ed6d5c0bb8d50cf1f50d476aa0458bdaba806f48be9dcb8" + ], + -- COUNT = 1 + [ "79737479ba4e7642a221fcfd1b820b134e9e3540a35bb48ffae29c20f5418ea3" + , "3593259c092bef4129bc2c6c9e19f343" + , "" + , "" + , "" + , "cf5ad5984f9e43917aa9087380dac46e410ddc8a7731859c84e9d0f31bd43655b924159413e2293b17610f211e09f770f172b8fb693a35b85d3b9e5e63b1dc252ac0e115002e9bedfb4b5b6fd43f33b8e0eafb2d072e1a6fee1f159df9b51e6c8da737e60d5032dd30544ec51558c6f080bdbdab1de8a939e961e06b5f1aca37" + ], + -- COUNT = 2 + [ "b340907445b97a8b589264de4a17c0bea11bb53ad72f9f33297f05d2879d898d" + , "65cb27735d83c0708f72684ea58f7ee5" + , "" + , "" + , "" + , "75183aaaf3574bc68003352ad655d0e9ce9dd17552723b47fab0e84ef903694a32987eeddbdc48efd24195dbdac8a46ba2d972f5808f23a869e71343140361f58b243e62722088fe10a98e43372d252b144e00c89c215a76a121734bdc485486f65c0b16b8963524a3a70e6f38f169c12f6cbdd169dd48fe4421a235847a23ff" + ], + -- COUNT = 3 + [ "8e159f60060a7d6a7e6fe7c9f769c30b98acb1240b25e7ee33f1da834c0858e7" + , "c39d35052201bdcce4e127a04f04d644" + , "" + , "" + , "" + , "62910a77213967ea93d6457e255af51fc79d49629af2fccd81840cdfbb4910991f50a477cbd29edd8a47c4fec9d141f50dfde7c4d8fcab473eff3cc2ee9e7cc90871f180777a97841597b0dd7e779eff9784b9cc33689fd7d48c0dcd341515ac8fecf5c55a6327aea8d58f97220b7462373e84e3b7417a57e80ce946d6120db5" + ], + -- COUNT = 4 + [ "74755f196305f7fb6689b2fe6835dc1d81484fc481a6b8087f649a1952f4df6a" + , "c36387a544a5f2b78007651a7b74b749" + , "" + , "" + , "" + , "b2896f3af4375dab67e8062d82c1a005ef4ed119d13a9f18371b1b873774418684805fd659bfd69964f83a5cfe08667ddad672cafd16befffa9faed49865214f703951b443e6dca22edb636f3308380144b9333de4bcb0735710e4d9266786342fc53babe7bdbe3c01a3addb7f23c63ce2834729fabbd419b47beceb4a460236" + ], + -- COUNT = 5 + [ "4b222718f56a3260b3c2625a4cf80950b7d6c1250f170bd5c28b118abdf23b2f" + , "7aed52d0016fcaef0b6492bc40bbe0e9" + , "" + , "" + , "" + , "a6da029b3665cd39fd50a54c553f99fed3626f4902ffe322dc51f0670dfe8742ed48415cf04bbad5ed3b23b18b7892d170a7dcf3ef8052d5717cb0c1a8b3010d9a9ea5de70ae5356249c0e098946030c46d9d3d209864539444374d8fbcae068e1d6548fa59e6562e6b2d1acbda8da0318c23752ebc9be0c1c1c5b3cf66dd967" + ], + -- COUNT = 6 + [ "b512633f27fb182a076917e39888ba3ff35d23c3742eb8f3c635a044163768e0" + , "e2c39b84629a3de5c301db5643af1c21" + , "" + , "" + , "" + , "fb931d0d0194a97b48d5d4c231fdad5c61aedf1c3a55ac24983ecbf38487b1c93396c6b86ff3920cfa8c77e0146de835ea5809676e702dee6a78100da9aa43d8ec0bf5720befa71f82193205ac2ea403e8d7e0e6270b366dc4200be26afd9f63b7e79286a35c688c57cbff55ac747d4c28bb80a2b2097b3b62ea439950d75dff" + ], + -- COUNT = 7 + [ "aae3ffc8605a975befefcea0a7a286642bc3b95fb37bd0eb0585a4cabf8b3d1e" + , "9504c3c0c4310c1c0746a036c91d9034" + , "" + , "" + , "" + , "2819bd3b0d216dad59ddd6c354c4518153a2b04374b07c49e64a8e4d055575dfbc9a8fcde68bd257ff1ba5c6000564b46d6dd7ecd9c5d684fd757df62d85211575d3562d7814008ab5c8bc00e7b5a649eae2318665b55d762de36eba00c2906c0e0ec8706edb493e51ca5eb4b9f015dc932f262f52a86b11c41e9a6d5b3bd431" + ], + -- COUNT = 8 + [ "b9475210b79b87180e746df704b3cbc7bf8424750e416a7fbb5ce3ef25a82cc6" + , "24baf03599c10df6ef44065d715a93f7" + , "" + , "" + , "" + , "ae12d784f796183c50db5a1a283aa35ed9a2b685dacea97c596ff8c294906d1b1305ba1f80254eb062b874a8dfffa3378c809ab2869aa51a4e6a489692284a25038908a347342175c38401193b8afc498077e10522bec5c70882b7f760ea5946870bd9fc72961eedbe8bff4fd58c7cc1589bb4f369ed0d3bf26c5bbc62e0b2b2" + ], + -- COUNT = 9 + [ "27838eb44ceccb4e36210703ebf38f659bc39dd3277cd76b7a9bcd6bc964b628" + , "39cfe0210db2e7b0eb52a387476e7ea1" + , "" + , "" + , "" + , "e5e72a53605d2aaa67832f97536445ab774dd9bff7f13a0d11fd27bf6593bfb52309f2d4f09d147192199ea584503181de87002f4ee085c7dc18bf32ce5315647a3708e6f404d6588c92b2dda599c131aa350d18c747b33dc8eda15cf40e95263d1231e1b4b68f8d829f86054d49cfdb1b8d96ab0465110569c8583a424a099a" + ], + -- COUNT = 10 + [ "d7129e4f47008ad60c9b5d081ff4ca8eb821a6e4deb91608bf4e2647835373a5" + , "a72882773f78c2fc4878295840a53012" + , "" + , "" + , "" + , "0cbf48585c5de9183b7ff76557f8fc9ebcfdfde07e588a8641156f61b7952725bbee954f87e9b937513b16bba0f2e523d095114658e00f0f3772175acfcb3240a01de631c19c5a834c94cc58d04a6837f0d2782fa53d2f9f65178ee9c837222494c799e64c60406069bd319549b889fa00a0032dd7ba5b1cc9edbf58de82bfcd" + ], + -- COUNT = 11 + [ "67fe5e300c513371976c80de4b20d4473889c9f1214bce718bc32d1da3ab7532" + , "e256d88497738a33923aa003a8d7845c" + , "" + , "" + , "" + , "b44660d64ef7bcebc7a1ab71f8407a02285c7592d755ae6766059e894f694373ed9c776c0cfc8594413eefb400ed427e158d687e28da3ecc205e0f7370fb089676bbb0fa591ec8d916c3d5f18a3eb4a417120705f3e2198154cd60648dbfcfc901242e15711cacd501b2c2826abe870ba32da785ed6f1fdc68f203d1ab43a64f" + ], + -- COUNT = 12 + [ "de8142541255c46d66efc6173b0fe3ffaf5936c897a3ce2e9d5835616aafa2cb" + , "d01f9002c407127bc3297a561d89b81d" + , "" + , "" + , "" + , "64d1020929d74716446d8a4e17205d0756b5264867811aa24d0d0da8644db25d5cde474143c57d12482f6bf0f31d10af9d1da4eb6d701bdd605a8db74fb4e77f79aaa9e450afda50b18d19fae68f03db1d7b5f1738d2fdce9ad3ee9461b58ee242daf7a1d72c45c9213eca34e14810a9fca5208d5c56d8066bab1586f1513de7" + ], + -- COUNT = 13 + [ "4a8e0bd90bdb12f7748ad5f147b115d7385bb1b06aee7d8b76136a25d779bcb7" + , "7f3cce4af8c8ce3c45bdf23c6b181a00" + , "" + , "" + , "" + , "320c7ca4bbeb7af977bc054f604b5086a3f237aa5501658112f3e7a33d2231f5536d2c85c1dad9d9b0bf7f619c81be4854661626839c8c10ae7fdc0c0b571be34b58d66da553676167b00e7d8e49f416aacb2926c6eb2c66ec98bffae20864cf92496db15e3b09e530b7b9648be8d3916b3c20a3a779bec7d66da63396849aaf" + ], + -- COUNT = 14 + [ "451ed024bc4b95f1025b14ec3616f5e42e80824541dc795a2f07500f92adc665" + , "2f28e6ee8de5879db1eccd58c994e5f0" + , "" + , "" + , "" + , "3fb637085ab75f4e95655faae95885166a5fbb423bb03dbf0543be063bcd48799c4f05d4e522634d9275fe02e1edd920e26d9accd43709cb0d8f6e50aa54a5f3bdd618be23cf73ef736ed0ef7524b0d14d5bef8c8aec1cf1ed3e1c38a808b35e61a44078127c7cb3a8fd7addfa50fcf3ff3bc6d6bc355d5436fe9b71eb44f7fd" + ] + ] + +{- + [SHA-256] + [PredictionResistance = False] + [EntropyInputLen = 256] + [NonceLen = 128] + [PersonalizationStringLen = 0] + [AdditionalInputLen = 256] + [ReturnedBitsLen = 1024] +-} + +t2 :: [TestVector] +t2 = + [ + -- COUNT = 0 + [ "d3cc4d1acf3dde0c4bd2290d262337042dc632948223d3a2eaab87da44295fbd" + , "0109b0e729f457328aa18569a9224921" + , "" + , "3c311848183c9a212a26f27f8c6647e40375e466a0857cc39c4e47575d53f1f6" + , "fcb9abd19ccfbccef88c9c39bfb3dd7b1c12266c9808992e305bc3cff566e4e4" + , "9c7b758b212cd0fcecd5daa489821712e3cdea4467b560ef5ddc24ab47749a1f1ffdbbb118f4e62fcfca3371b8fbfc5b0646b83e06bfbbab5fac30ea09ea2bc76f1ea568c9be0444b2cc90517b20ca825f2d0eccd88e7175538b85d90ab390183ca6395535d34473af6b5a5b88f5a59ee7561573337ea819da0dcc3573a22974" + ], + -- COUNT = 1 + [ "f97a3cfd91faa046b9e61b9493d436c4931f604b22f1081521b3419151e8ff06" + , "11f3a7d43595357d58120bd1e2dd8aed" + , "" + , "517289afe444a0fe5ed1a41dbbb5eb17150079bdd31e29cf2ff30034d8268e3b" + , "88028d29ef80b4e6f0fe12f91d7449fe75062682e89c571440c0c9b52c42a6e0" + , "c6871cff0824fe55ea7689a52229886730450e5d362da5bf590dcf9acd67fed4cb32107df5d03969a66b1f6494fdf5d63d5b4d0d34ea7399a07d0116126d0d518c7c55ba46e12f62efc8fe28a51c9d428e6d371d7397ab319fc73ded4722e5b4f30004032a6128df5e7497ecf82ca7b0a50e867ef6728a4f509a8c859087039c" + ], + -- COUNT = 2 + [ "0f2f23d64f481cabec7abb01db3aabf125c3173a044b9bf26844300b69dcac8b" + , "9a5ae13232b43aa19cfe8d7958b4b590" + , "" + , "ec4c7a62acab73385f567da10e892ff395a0929f959231a5628188ce0c26e818" + , "6b97b8c6b6bb8935e676c410c17caa8042aa3145f856d0a32b641e4ae5298648" + , "7480a361058bd9afa3db82c9d7586e42269102013f6ec5c269b6d05f17987847748684766b44918fd4b65e1648622fc0e0954178b0279dfc9fa99b66c6f53e51c4860131e9e0644287a4afe4ca8e480417e070db68008a97c3397e4b320b5d1a1d7e1d18a95cfedd7d1e74997052bf649d132deb9ec53aae7dafdab55e6dae93" + ], + -- COUNT = 3 + [ "53c56660c78481be9c63284e005fcc14fbc7fb27732c9bf1366d01a426765a31" + , "dc7a14d0eb5b0b3534e717a0b3c64614" + , "" + , "3aa848706ecb877f5bedf4ffc332d57c22e08747a47e75cff6f0fd1316861c95" + , "9a401afa739b8f752fddacd291e0b854f5eff4a55b515e20cb319852189d3722" + , "5c0eb420e0bf41ce9323e815310e4e8303cd677a8a8b023f31f0d79f0ca15aeb636099a369fd074d69889865eac1b72ab3cbfebdb8cf460b00072802e2ec648b1349a5303be4ccaadd729f1a9ea17482fd026aaeb93f1602bc1404b9853adde40d6c34b844cf148bc088941ecfc1642c8c0b9778e45f3b07e06e21ee2c9e0300" + ], + -- COUNT = 4 + [ "f63c804404902db334c54bb298fc271a21d7acd9f770278e089775710bf4fdd7" + , "3e45009ea9cb2a36ba1aa4bf39178200" + , "" + , "d165a13dc8cc43f3f0952c3f5d3de4136954d983683d4a3e6d2dc4c89bf23423" + , "75106bc86d0336df85097f6af8e80e2da59046a03fa65b06706b8bbc7ffc6785" + , "6363139bba32c22a0f5cd23ca6d437b5669b7d432f786b8af445471bee0b2d24c9d5f2f93717cbe00d1f010cc3b9c515fc9f7336d53d4d26ba5c0d76a90186663c8582eb739c7b6578a3328bf68dc2cec2cd89b3a90201f6993adcc854df0f5c6974d0f5570765a15fe03dbce28942dd2fd16ba2027e68abac83926969349af8" + ], + -- COUNT = 5 + [ "2aaca9147da66c176615726b69e3e851cc3537f5f279fe7344233d8e44cfc99d" + , "4e171f080af9a6081bee9f183ac9e340" + , "" + , "d75a2a6eb66c3833e50f5ec3d2e434cf791448d618026d0c360806d120ded669" + , "b643b74c15b37612e6577ed7ca2a4c67a78d560af9eb50a4108fca742e87b8d6" + , "501dcdc977f4ba856f24eaa4968b374bebb3166b280334cb510232c31ebffde10fa47b7840ef3fe3b77725c2272d3a1d4219baf23e0290c622271edcced58838cf428f0517425d2e19e0d8c89377eecfc378245f283236fafa466c914b99672ceafab369e8889a0c866d8bd639db9fb797254262c6fd44cfa9045ad6340a60ef" + ], + -- COUNT = 6 + [ "a2e4cd48a5cf918d6f55942d95fcb4e8465cdc4f77b7c52b6fae5b16a25ca306" + , "bef036716440db6e6d333d9d760b7ca8" + , "" + , "bfa591c7287f3f931168f95e38869441d1f9a11035ad8ea625bb61b9ea17591c" + , "c00c735463bca215adc372cb892b05e939bf669583341c06d4e31d0e5b363a37" + , "e7d136af69926a5421d4266ee0420fd729f2a4f7c295d3c966bdfa05268180b508b8a2852d1b3a06fd2ab3e13c54005123ef319f42d0c6d3a575e6e7e1496cb28aacadbcf83740fba8f35fcee04bb2ed8a51db3d3362b01094a62fb57e33c99a432f29fce6676cffbbcc05107e794e75e44a02d5e6d9d748c5fbff00a0178d65" + ], + -- COUNT = 7 + [ "95a67771cba69011a79776e713145d309edae56fad5fd6d41d83eaff89df6e5e" + , "be5b5164e31ecc51ba6f7c3c5199eb33" + , "" + , "065f693b229a7c4fd373cd15b3807552dd9bf98c5485cef361949d4e7d774b53" + , "9afb62406f0e812c4f156d58b19a656c904813c1b4a45a0029ae7f50731f8014" + , "f61b61a6e79a41183e8ed6647899d2dc85cdaf5c3abf5c7f3bf37685946dc28f4923dc842f2d4326bd6ce0d50a84cb3ba869d72a36e246910eba6512ba36cd7ed3a5437c9245b00a344308c792b668b458d3c3e16dee2fbec41867da31084d46d8ec168de2148ef64fc5b72069abf5a6ada1ead2b7146bb793ff1c9c3690fa56" + ], + -- COUNT = 8 + [ "a459e1815cbca4514ec8094d5ab2414a557ba6fe10e613c345338d0521e4bf90" + , "62221392e2552e76cd0d36df6e6068eb" + , "" + , "0a3642b02b23b3ef62c701a63401124022f5b896de86dab6e6c7451497aa1dcc" + , "c80514865901371c45ba92d9f95d50bb7c9dd1768cb3dfbc45b968da94965c6e" + , "464e6977b8adaef307c9623e41c357013249c9ffd77f405f3925cebb69f151ce8fbb6a277164002aee7858fc224f6499042aa1e6322deee9a5d133c31d640e12a7487c731ba03ad866a24675badb1d79220c40be689f79c2a0be93cb4dada3e0eac4ab140cb91998b6f11953e68f2319b050c40f71c34de9905ae41b2de1c2f6" + ], + -- COUNT = 9 + [ "252c2cad613e002478162861880979ee4e323025eebb6fb2e0aa9f200e28e0a1" + , "d001bc9a8f2c8c242e4369df0c191989" + , "" + , "9bcfc61cb2bc000034bb3db980eb47c76fb5ecdd40553eff113368d639b947fd" + , "8b0565c767c2610ee0014582e9fbecb96e173005b60e9581503a6dca5637a26e" + , "e96c15fe8a60692b0a7d67171e0195ff6e1c87aab844221e71700d1bbee75feea695f6a740c9760bbe0e812ecf4061d8f0955bc0195e18c4fd1516ebca50ba6a6db86881737dbab8321707675479b87611db6af2c97ea361a5484555ead454defb1a64335de964fc803d40f3a6f057893d2afc25725754f4f00abc51920743dc" + ], + -- COUNT = 10 + [ "8be0ca6adc8b3870c9d69d6021bc1f1d8eb9e649073d35ee6c5aa0b7e56ad8a5" + , "9d1265f7d51fdb65377f1e6edd6ae0e4" + , "" + , "da86167ac997c406bb7979f423986a84ec6614d6caa7afc10aff0699a9b2cf7f" + , "e4baa3c555950b53e2bfdba480cb4c94b59381bac1e33947e0c22e838a9534cf" + , "64384ecc4ea6b458efc227ca697eac5510092265520c0a0d8a0ccf9ed3ca9d58074671188c6a7ad16d0b050cdc072c125d7298d3a31d9f044a9ee40da0089a84fea28cc7f05f1716db952fad29a0e779635cb7a912a959be67be2f0a4170aace2981802e2ff6467e5b46f0ffbff3b42ba5935fd553c82482ac266acf1cd247d7" + ], + -- COUNT = 11 + [ "d43a75b6adf26d60322284cb12ac38327792442aa8f040f60a2f331b33ac4a8f" + , "0682f8b091f811afacaacaec9b04d279" + , "" + , "7fd3b8f512940da7de5d80199d9a7b42670c04a945775a3dba869546cbb9bc65" + , "2575db20bc7aafc2a90a5dabab760db851d754777bc9f05616af1858b24ff3da" + , "0da7a8dc73c163014bf0841913d3067806456bbca6d5de92b85534c6545467313648d71ef17c923d090dc92cff8d4d1a9a2bb63e001dc2e8ab1a597999be3d6cf70ff63fee9985801395fbd4f4990430c4259fcae4fa1fcd73dc3187ccc102d04af7c07532885e5a226fc42809c48f22eecf4f6ab996ae4fcb144786957d9f41" + ], + -- COUNT = 12 + [ "64352f236af5d32067a529a8fd05ba00a338c9de306371a0b00c36e610a48d18" + , "df99ed2c7608c870624b962a5dc68acd" + , "" + , "da416335e7aaf60cf3d06fb438735ce796aad09034f8969c8f8c3f81e32fef24" + , "a28c07c21a2297311adf172c19e83ca0a87731bdffb80548978d2d1cd82cf8a3" + , "132b9f25868729e3853d3c51f99a3b5fae6d4204bea70890daf62e042b776a526c8fb831b80a6d5d3f153237df1fd39b6fd9137963f5516d9cdd4e3f9195c46e9972c15d3edc6606e3368bde1594977fb88d0ca6e6f5f3d057ccadc7d7dab77dfc42658a1e972aa446b20d418286386a52dfc1c714d2ac548713268b0b709729" + ], + -- COUNT = 13 + [ "282f4d2e05a2cd30e9087f5633089389449f04bac11df718c90bb351cd3653a5" + , "90a7daf3c0de9ea286081efc4a684dfb" + , "" + , "2630b4ccc7271cc379cb580b0aaede3d3aa8c1c7ba002cf791f0752c3d739007" + , "c31d69de499f1017be44e3d4fa77ecebc6a9b9934749fcf136f267b29115d2cc" + , "c899094520e0197c37b91dd50778e20a5b950decfb308d39f1db709447ae48f6101d9abe63a783fbb830eec1d359a5f61a2013728966d349213ee96382614aa4135058a967627183810c6622a2158cababe3b8ab99169c89e362108bf5955b4ffc47440f87e4bad0d36bc738e737e072e64d8842e7619f1be0af1141f05afe2d" + ], + -- COUNT = 14 + [ "13c752b9e745ce77bbc7c0dbda982313d3fe66f903e83ebd8dbe4ff0c11380e9" + , "f1a533095d6174164bd7c82532464ae7" + , "" + , "4f53db89b9ba7fc00767bc751fb8f3c103fe0f76acd6d5c7891ab15b2b7cf67c" + , "582c2a7d34679088cca6bd28723c99aac07db46c332dc0153d1673256903b446" + , "6311f4c0c4cd1f86bd48349abb9eb930d4f63df5e5f7217d1d1b91a71d8a6938b0ad2b3e897bd7e3d8703db125fab30e03464fad41e5ddf5bf9aeeb5161b244468cfb26a9d956931a5412c97d64188b0da1bd907819c686f39af82e91cfeef0cbffb5d1e229e383bed26d06412988640706815a6e820796876f416653e464961" + ] + ] + +{- + [SHA-256] + [PredictionResistance = False] + [EntropyInputLen = 256] + [NonceLen = 128] + [PersonalizationStringLen = 256] + [AdditionalInputLen = 0] + [ReturnedBitsLen = 1024] +-} + +t3 :: [TestVector] +t3 = + [ + -- COUNT = 0 + [ "5cacc68165a2e2ee20812f35ec73a79dbf30fd475476ac0c44fc6174cdac2b55" + , "6f885496c1e63af620becd9e71ecb824" + , "e72dd8590d4ed5295515c35ed6199e9d211b8f069b3058caa6670b96ef1208d0" + , "" + , "" + , "f1012cf543f94533df27fedfbf58e5b79a3dc517a9c402bdbfc9a0c0f721f9d53faf4aafdc4b8f7a1b580fcaa52338d4bd95f58966a243cdcd3f446ed4bc546d9f607b190dd69954450d16cd0e2d6437067d8b44d19a6af7a7cfa8794e5fbd728e8fb2f2e8db5dd4ff1aa275f35886098e80ff844886060da8b1e7137846b23b" + ], + -- COUNT = 1 + [ "8df013b4d103523073917ddf6a869793059e9943fc8654549e7ab22f7c29f122" + , "da2625af2ddd4abcce3cf4fa4659d84e" + , "b571e66d7c338bc07b76ad3757bb2f9452bf7e07437ae8581ce7bc7c3ac651a9" + , "" + , "" + , "b91cba4cc84fa25df8610b81b641402768a2097234932e37d590b1154cbd23f97452e310e291c45146147f0da2d81761fe90fba64f94419c0f662b28c1ed94da487bb7e73eec798fbcf981b791d1be4f177a8907aa3c401643a5b62b87b89d66b3a60e40d4a8e4e9d82af6d2700e6f535cdb51f75c321729103741030ccc3a56" + ], + -- COUNT = 2 + [ "565b2b77937ba46536b0f693b3d5e4a8a24563f9ef1f676e8b5b2ef17823832f" + , "4ef3064ec29f5b7f9686d75a23d170e3" + , "3b722433226c9dba745087270ab3af2c909425ba6d39f5ce46f07256068319d9" + , "" + , "" + , "d144ee7f8363d128872f82c15663fe658413cd42651098e0a7c51a970de75287ec943f9061e902280a5a9e183a7817a44222d198fbfab184881431b4adf35d3d1019da5a90b3696b2349c8fba15a56d0f9d010a88e3f9eeedb67a69bcaa71281b41afa11af576b765e66858f0eb2e4ec4081609ec81da81df0a0eb06787340ea" + ], + -- COUNT = 3 + [ "fc3832a91b1dcdcaa944f2d93cbceb85c267c491b7b59d017cde4add79a836b6" + , "d5e76ce9eabafed06e33a913e395c5e0" + , "ffc5f6eefd51da64a0f67b5f0cf60d7ab43fc7836bca650022a0cee57a43c148" + , "" + , "" + , "0e713c6cc9a4dbd4249201d12b7bf5c69c3e18eb504bf3252db2f43675e17d99b6a908400cea304011c2e54166dae1f20260008efe4e06a87e0ce525ca482bca223a902a14adcf2374a739a5dfeaf14cadd72efa4d55d15154c974d9521535bcb70658c5b6c944020afb04a87b223b4b8e5d89821704a9985bb010405ba8f3d4" + ], + -- COUNT = 4 + [ "8009eb2cb49fdf16403bcdfd4a9f952191062acb9cc111eca019f957fb9f4451" + , "355598866952394b1eddd85d59f81c9d" + , "09ff1d4b97d83b223d002e05f754be480d13ba968e5aac306d71cc9fc49cc2dd" + , "" + , "" + , "9550903c2f02cf77c8f9c9a37041d0040ee1e3ef65ba1a1fbbcf44fb7a2172bd6b3aaabe850281c3a1778277bacd09614dfefececac64338ae24a1bf150cbf9d9541173a82ecba08aa19b75abb779eb10efa4257d5252e8afcac414bc3bb5d3006b6f36fb9daea4c8c359ef6cdbeff27c1068571dd3c89dc87eda9190086888d" + ], + -- COUNT = 5 + [ "a6e4c9a8bd6da23b9c2b10a7748fd08c4f782fadbac7ea501c17efdc6f6087bd" + , "acdc47edf1d3b21d0aec7631abb6d7d5" + , "c16ee0908a5886dccf332fbc61de9ec7b7972d2c4c83c477409ce8a15c623294" + , "" + , "" + , "a52f93ccb363e2bdf0903622c3caedb7cffd04b726052b8d455744c71b76dee1b71db9880dc3c21850489cb29e412d7d80849cfa9151a151dcbf32a32b4a54cac01d3200200ed66a3a5e5c131a49655ffbf1a8824ff7f265690dffb4054df46a707b9213924c631c5bce379944c856c4f7846e281ac89c64fad3a49909dfb92b" + ], + -- COUNT = 6 + [ "59d6307460a9bdd392dfc0904973991d585696010a71e52d590a5039b4849fa4" + , "34a0aafb95917cbf8c38fc5548373c05" + , "0407b7c57bc11361747c3d67526c36e228028a5d0b145d66ab9a2fe4b07507a0" + , "" + , "" + , "299aba0661315211b09d2861855d0b4b125ab24649461341af6abd903ed6f025223b3299f2126fcad44c675166d800619cf49540946b12138989417904324b0ddad121327211a297f11259c9c34ce4c70c322a653675f78d385e4e2443f8058d141195e17e0bd1b9d44bf3e48c376e6eb44ef020b11cf03eb141c46ecb43cf3d" + ], + -- COUNT = 7 + [ "9ae3506aadbc8358696ba1ba17e876e1157b7048235921503d36d9211b430342" + , "9abf7d66afee5d2b811cba358bbc527d" + , "0d645f6238e9ceb038e4af9772426ca110c5be052f8673b8b5a65c4e53d2f519" + , "" + , "" + , "5f032c7fec6320fe423b6f38085cbad59d826085afe915247b3d546c4c6b174554dd4877c0d671de9554b505393a44e71f209b70f991ac8aa6e08f983fff2a4c817b0cd26c12b2c929378506489a75b2025b358cb5d0400821e7e252ac6376cd94a40c911a7ed8b6087e3de5fa39fa6b314c3ba1c593b864ce4ff281a97c325b" + ], + -- COUNT = 8 + [ "96ae3b8775b36da2a29b889ad878941f43c7d51295d47440cd0e3c4999193109" + , "1fe022a6fc0237b055d4d6a7036b18d5" + , "1e40e97362d0a823d3964c26b81ab53825c56446c5261689011886f19b08e5c2" + , "" + , "" + , "e707cd14b06ce1e6dbcceaedbf08d88891b03f44ad6a797bd12fdeb557d0151df9346a028dec004844ca46adec3051dafb345895fa9f4604d8a13c8ff66ae093fa63c4d9c0816d55a0066d31e8404c841e87b6b2c7b5ae9d7afb6840c2f7b441bf2d3d8bd3f40349c1c014347c1979213c76103e0bece26ad7720601eff42275" + ], + -- COUNT = 9 + [ "33f5120396336e51ee3b0b619b5f873db05ca57cda86aeae2964f51480d14992" + , "6f1f6e9807ba5393edcf3cb4e4bb6113" + , "3709605af44d90196867c927512aa8ba31837063337b4879408d91a05c8efa9f" + , "" + , "" + , "8b8291126ded9acef12516025c99ccce225d844308b584b872c903c7bc6467599a1cead003dc4c70f6d519f5b51ce0da57f53da90dbe8f666a1a1dde297727fee2d44cebd1301fc1ca75956a3fcae0d374e0df6009b668fd21638d2b733e6902d22d5bfb4af1b455975e08eef0ebe4dc87705801e7776583c8de11672729f723" + ], + -- COUNT = 10 + [ "ad300b799005f290fee7f930eebce158b98fb6cb449987fe433f955456b35300" + , "06aa2514e4bd114edf7ac105cfef2772" + , "87ada711465e4169da2a74c931afb9b5a5b190d07b7af342aa99570401c3ee8a" + , "" + , "" + , "80d7c606ff49415a3a92ba1f2943235c01339c8f9cd0b0511fbfdf3ef23c42ffff008524193faaa4b7f2f2eb0cfa221d9df89bd373fe4e158ec06fad3ecf1eb48b8239b0bb826ee69d773883a3e8edac66254610ff70b6609836860e39ea1f3bfa04596fee1f2baca6cebb244774c6c3eb4af1f02899eba8f4188f91776de16f" + ], + -- COUNT = 11 + [ "130b044e2c15ab89375e54b72e7baae6d4cad734b013a090f4df057e634f6ff0" + , "65fd6ac602cd44107d705dbc066e52b6" + , "f374aba16f34d54aae5e494505b67d3818ef1c08ea24967a76876d4361379aec" + , "" + , "" + , "5d179534fb0dba3526993ed8e27ec9f915183d967336bb24352c67f4ab5d7935d3168e57008da851515efbaecb69904b6d899d3bfa6e9805659aef2942c4903875b8fcbc0d1d24d1c075f0ff667c1fc240d8b410dff582fa71fa30878955ce2ed786ef32ef852706e62439b69921f26e84e0f54f62b938f04905f05fcd7c2204" + ], + -- COUNT = 12 + [ "716430e999964b35459c17921fe5f60e09bd9ab234cb8f4ba4932bec4a60a1d5" + , "9533b711e061b07d505da707cafbca03" + , "372ae616d1a1fc45c5aecad0939c49b9e01c93bfb40c835eebd837af747f079d" + , "" + , "" + , "a80d6a1b2d0ce01fe0d26e70fb73da20d45841cf01bfbd50b90d2751a46114c0e758cb787d281a0a9cf62f5c8ce2ee7ca74fefff330efe74926acca6d6f0646e4e3c1a1e52fce1d57b88beda4a5815896f25f38a652cc240deb582921c8b1d03a1da966dd04c2e7eee274df2cd1837096b9f7a0d89a82434076bc30173229a60" + ], + -- COUNT = 13 + [ "7679f154296e6d580854826539003a82d1c54e2e062c619d00da6c6ac820789b" + , "55d12941b0896462e7d888e5322a99a3" + , "ba4d1ed696f58ef64596c76cee87cc1ca83069a79e7982b9a06f9d62f4209faf" + , "" + , "" + , "10dc7cd2bb68c2c28f76d1b04ae2aa287071e04c3b688e1986b05cc1209f691daa55868ebb05b633c75a40a32b49663185fe5bb8f906008347ef51590530948b87613920014802e5864e0758f012e1eae31f0c4c031ef823aecfb2f8a73aaa946fc507037f9050b277bdeaa023123f9d22da1606e82cb7e56de34bf009eccb46" + ], + -- COUNT = 14 + [ "8ca4a964e1ff68753db86753d09222e09b888b500be46f2a3830afa9172a1d6d" + , "a59394e0af764e2f21cf751f623ffa6c" + , "eb8164b3bf6c1750a8de8528af16cffdf400856d82260acd5958894a98afeed5" + , "" + , "" + , "fc5701b508f0264f4fdb88414768e1afb0a5b445400dcfdeddd0eba67b4fea8c056d79a69fd050759fb3d626b29adb8438326fd583f1ba0475ce7707bd294ab01743d077605866425b1cbd0f6c7bba972b30fbe9fce0a719b044fcc1394354895a9f8304a2b5101909808ddfdf66df6237142b6566588e4e1e8949b90c27fc1f" + ] + ] + +{- + [SHA-256] + [PredictionResistance = False] + [EntropyInputLen = 256] + [NonceLen = 128] + [PersonalizationStringLen = 256] + [AdditionalInputLen = 256] + [ReturnedBitsLen = 1024] +-} + +t4 :: [TestVector] +t4 = + [ + -- COUNT = 0 + [ "5d3286bc53a258a53ba781e2c4dcd79a790e43bbe0e89fb3eed39086be34174b" + , "c5422294b7318952ace7055ab7570abf" + , "2dba094d008e150d51c4135bb2f03dcde9cbf3468a12908a1b025c120c985b9d" + , "793a7ef8f6f0482beac542bb785c10f8b7b406a4de92667ab168ecc2cf7573c6" + , "2238cdb4e23d629fe0c2a83dd8d5144ce1a6229ef41dabe2a99ff722e510b530" + , "d04678198ae7e1aeb435b45291458ffde0891560748b43330eaf866b5a6385e74c6fa5a5a44bdb284d436e98d244018d6acedcdfa2e9f499d8089e4db86ae89a6ab2d19cb705e2f048f97fb597f04106a1fa6a1416ad3d859118e079a0c319eb95686f4cbcce3b5101c7a0b010ef029c4ef6d06cdfac97efb9773891688c37cf" + ], + -- COUNT = 1 + [ "c2a566a9a1817b15c5c3b778177ac87c24e797be0a845f11c2fe399dd37732f2" + , "cb1894eb2b97b3c56e628329516f86ec" + , "13ce4d8dd2db9796f94156c8e8f0769b0aa1c82c1323b61536603bca37c9ee29" + , "413dd83fe56835abd478cb9693d67635901c40239a266462d3133b83e49c820b" + , "d5c4a71f9d6d95a1bedf0bd2247c277d1f84a4e57a4a8825b82a2d097de63ef1" + , "b3a3698d777699a0dd9fa3f0a9fa57832d3cefac5df24437c6d73a0fe41040f1729038aef1e926352ea59de120bfb7b073183a34106efed6278ff8ad844ba0448115dfddf3319a82de6bb11d80bd871a9acd35c73645e1270fb9fe4fa88ec0e465409ea0cba809fe2f45e04943a2e396bbb7dd2f4e0795303524cc9cc5ea54a1" + ], + -- COUNT = 2 + [ "a33288a96f41dd54b945e060c8bd0c094f1e28267cc1dcbba52063c1a9d54c4d" + , "36918c977e1a7276a2bb475591c367b7" + , "6aa528c940962638dc2201738850fd1fe6f5d0eb9f687ff1af39d9c7b36830d9" + , "37ee633a635e43af59abdb1762c7ea45bfe060ec1d9077ecd2a43a658673f3c7" + , "2eb96f2e28fa9f674bb03ade703b8f791ee5356e2ee85c7ed5bda96325256c61" + , "db2f91932767eb846961ce5321c7003431870508e8c6f8d432ca1f9cee5cdc1aed6e0f133d317eb6990c4b3b0a360cdfb5b43a6e712bd46bca04c414868fab22c6a49c4b89c812697c3a7fbfc8ddf10c8aa5ebf13a09fd114eb2a02a07f69786f3ce7fd30231f22779bc8db103b13fa546dbc45a89a86275281172761683d384" + ], + -- COUNT = 3 + [ "5f37b6e47e1776e735adc03d4b999879477ff4a206231924033d94c0114f911b" + , "7d12d62c79c9f6234ae0314156947459" + , "92d4d9fab5f8bf5119f2663a9df7334f50dcde74fb9d7732f7eba56501e60d54" + , "c9aef0d7a9ba7345d08b6d5b5ce5645c7495b8685e6b93846ffcf470f5abd40d" + , "50d9d1f5074f7d9f1a24a9c63aa47b94da5ba78db1b0f18e4d4fe45c6875813c" + , "20d942bbd7d98700faa37e94d53bf74f2d6bd1d8c95c0b88d842c4857797d59e7c8788aeeac29740122f208f703bf35dc32b0035db0648384feb6aa17a3274bc09b2d2b746c5a06fd82f4469fb86131a49482cb7be7d9b4b95042394cfb18b13f333ec0fe5c227bf1d8f33ecb2e42e358b6c3e034cb585331bd1d27f638029b9" + ], + -- COUNT = 4 + [ "2311c5afd64c584484b2729e84db80c0b4063fe9ca7edc83350488d7e67264a0" + , "6a6dfd975a0dc7b72df1f107c4b3b3a6" + , "2abd870ec5fe26ed14dfa57a3309f920131b70580c3639af2645cd1af93db1b1" + , "c6e532a3b25653b6002aed5269cc2118749306e736bde039d4d569d4f967773f" + , "5e7d26c4da769c373092b2b4f72b109fe34bdb7d169ea38f78ebae5df4a15759" + , "cacaeb1b4ac2305d8714eb50cbe1c67c5a2c0bbc7938fdfdcafef7c85fc40becbf777a4cfb6f14c6eee320943a493d2b0a744a6eb3c256ee9a3763037437df9adce3e2260f0c35e958af0edb5a81debd8bdaf2b8bb2b98b9186e5a222a21609ff58df4cbe1d4898d10d6e7c46f31f5cb1041bfd83a5fb27d5c56c961e91403fc" + ], + -- COUNT = 5 + [ "362ece9d330e1172a8f9e50258476d0c79c3ee50346524ba12d970ee3a6ef8c5" + , "cf11bcb4d9d51311ceacfca8705e833f" + , "abb5a8edde02e526449284ecc31bc713383df3ed085f752e3b6a32f305861eed" + , "746302ab1f4a86b17546bea762e929360f2e95c7788a63545a264ef997c8c65e" + , "b907c5b2a8833a48e56e819228ce9a050b41b3309f5ca37bed720311d92b33af" + , "73c7131a558350590053580873ef956ff952f2aa6ff1bea452e013d1bc2afddea2311756dbe756e63ba6258480c48f3f6c1319b5f572f67ca530af09e39413d1d432bea8f89206619618cb0e7c88e9f2033639d0eb0efc20616b64f940da99b88231984c3fb23f19e890576f555fde394dbd4351f17a7ffd5c369379001bda03" + ], + -- COUNT = 6 + [ "cf614bc29946bc0095f415e8bdeda10aab05392f9cc9187a86ea6ec95ee422e1" + , "77fb5ec22dc0432cc13f4693e2e3bd9a" + , "e4ce77914ffbc5fddf1fb51edfafdc196109139b84c741354135ec8d314c7c43" + , "e1e83ee1205acaf6164dc287aec08e5b32789e5be818078db39e53cad589db51" + , "4e20c0226d5e1e7e805679f03f72452b5bea2d0ba41e0c12329bf60eb3016dd1" + , "838fdf1418a746aa52ae4005d90c3fd301f648c5770ffef2a9f3912e37a93850cc4b8bfcce910aead0cb75958823b1a62e283901c5e4a3980e4ea36257458e2e4953555819b8852a26489b1d74821f80c9908469b43f124ff7ea62497c36159a47353098a1b9ec32e54800d6704371cc37f357ad74aacc203e9b6db97f94d0c4" + ], + -- COUNT = 7 + [ "a8da1d3e233f393fd44d204c200202f7d01896e72c5ac652940cfd15b5d4b0bd" + , "0a112b4cb0890af0a495e0f49fcf6874" + , "d2e32799bc822b8d033299bdf63dc35774f7649e935d25be5b10512c430d1bda" + , "920a82d76fcd2cd106ada64bba232b7b2344f3afe6b1d1d20ee8795144571009" + , "eeaac5878275372025f8231febed64db6a11273c3c00d625fc80a95f18ad7d3f" + , "5f6dae489b53d89027b2cc333c700f090152d77b3eaf01d47f56ce6eca9893ef877b4cb560fab0fbdb34e3d1c6cd8480b33c053d2661a10aa531df4961b97d659c7492584236582b3fe701055efa59c328194cd1e07fcffd910d9ee01b7b9e8c8fda7f7ac01a8e203b8b26eb8078a9b9a5021562c44af24089e3ef84c1d5a6bd" + ], + -- COUNT = 8 + [ "a77b1ed4ecaa650374e1052c405f1d88881c25c87d13dbe1334d8c1a847fa76b" + , "05c143e2f145db216fe7be9ed23635d0" + , "b5c750968ff09ed251d4a1c05342ac843db5246b19045728a634fa4f6e752e54" + , "ff5937bcd01a363696bf8e40adc8e4ab3e56dbf7e7d09451c99e538785fe6697" + , "4acb34eea8266badcf8f6557a0eecf3eb4d7a295c876d6175598cb66a388efb8" + , "ec13eadfcc84e77d2a2efa1a2cd8b1355587cb27feb3d19d75b37f0446333ddb8236e751c63b7a6e595ec24a25051a696dbe8c062dd8896d1446db228a2f10e8094ee07e7ee648ed6bebb2f5ec5aae24c9c640665c28355cc11c116795ecc070790f7fdfc4398900311b6695d5da0175091ed1828d2731085bfb4a20bd86cce0" + ], + -- COUNT = 9 + [ "491686c781e83eb4e21d9989e8d718100b0d21a2c56295888baef1a65f219651" + , "499085296d21065feabf3106101c8d6f" + , "d208a72f9ae34f0817669fb04f49239dd31700f3dc9a93db8d75fb79f9b686c1" + , "9ffc61893a293a864008fdd56d3292600d9e2ec8a1ea8f34ac5931e968905a23" + , "4ff3a397dfdae0912032a302a5e7a07dceca8d9013a21545689319b7c024cd07" + , "3c258ebf2203fca3b322ad1b016e21c7f5c148425f81e4fb0a0e462dce9dfa569c37a006527768297a5b68461b08912642a341b88c85597e30e7561206886098c4e2d861f11513f0ffdbbc78d3a2dd60c105abbb33c5e05ae27081b690fb8b3610917aa9bf1a4ad74481b5ff8334f14e5ad6a6a1eb2259476078076fb7e3a992" + ], + -- COUNT = 10 + [ "36a5267eeeb5a1a7d46de0f8f9281f73cd9611f01198fdaa78c5315205e5a177" + , "b66b5337970df36219321badacc624eb" + , "c2a7b164949da102bece44a423197682ff97627d1fe9654266b8527f64e5b386" + , "a977e2d8637b019c74063d163bb25387dc56f4eb40e502cefc5ae6ad26a6abdc" + , "c5c9819557b1e7d8a86fa8c60be42993edc3ef539c13d9a51fb64b0de06e145e" + , "b471711a4fc7ab7247e65d2c2fe49a50169187187b7978cd2fdb0f8318be3ec55fc68ed4577ad9b42cbb57100b5d35ac86c244c4c93a5b28c1a11c2dfe905d608ec7804dec5bb15cf8d79695534d5e13a6a7e18a887ec9cf184da0cbbc6267f3a952a769403bafcdbb559401be0d8b3300ea7258b4026fc892175efd55ba1a67" + ], + -- COUNT = 11 + [ "a76b0366df89e4073a6b6b9c04da1d6817ce26f1c4825cad4097bdf4d7b9445e" + , "773d3cc3290176773847869be528d1a4" + , "1bfd3bcfb9287a5ad055d1b2b8615fa81c94ac24bc1c219a0f8de58789e0404a" + , "edd879fa56f21d93029da875b683ce50f6fdc4c0da41da051d000eed2afefefa" + , "f528ffd29160039260133ed9654589ce60e39e7f667c34f82cda65ddcf5fff14" + , "39d1ff8848e74dd2cdc6b818ad69823878062116fdf1679942f892c7e191be1c4b6ea268ecdff001b22af0d510f30c2c25b90fc34927f46e3f45d36b0e1848b3a5d54c36c7c65ee7287d325dfbb51b56a438feb6650ce13df88bf06b87ac4a35d2a199ea888629fb0d83f82f0ea160dc79ed220d8ef195b9e80c542f60c2d320" + ], + -- COUNT = 12 + [ "46571e1df43e5e141235e2a9ec85bb0faf1dc0566031e14d41a2fbd0315653ec" + , "b60ef6a3347967519aabeaf748e4e991" + , "759fd8593e3688b23c4a003b655311770d670789878570eb3b155a8e6c2d8c45" + , "033128460b449e1accb0e9c54508759ddc2538bc64b51e6277553f0c60a02723" + , "a5e4a717240bdeac18a0c0e231a11dc04a47d7550f342fa9a7a5ff334eb9327d" + , "9d222df1d530ea7f8f2297a0c79d637da570b48042ecddded75956bba0f0e70b271ffa3c9a53bada6ee1b8a4203c22bfde82a5e2eb1b150f54c6483458569422c1a34a8997d42cc09750167a78bf52a0bd158397af9f83caabe689185c099bf0a9a4853dd3cf8b8e89efebb6a27dba873e65e9927741b22968f2875789b44e01" + ], + -- COUNT = 13 + [ "d63980e63bbe4ac08d2ac5646bf085b82c75995e3fdfc23bb9cc734cd85ca7d2" + , "d33ed1dcae13fb634ba08272d6697590" + , "acd0da070072a5340c4f5f4395568e1a36374e074196ae87f3692ee40487e1df" + , "f567677b5e12e26f3544be3da9314c88fc475bf84804a89a51f12b191392c02b" + , "c01cc7873e93c86e2bfb8fc984cfc2eab5cc58eeef018fedb5cba5aedd386156" + , "b133446f633bcb40724bbf9fa187c39a44b9c094a0a0d40e98977e5466dc2c9adf62a5f4551eeb6406a14658de8a0ed7487c3bf6277e811101284a941745ce16176acc875f1435e14161772fa84609e8123c53dd03cbb868030835c0d11d8d6aa04a1b6f908248b028997737f54735ec4ed7a81fc868199ffb61a779d9340334" + ], + -- COUNT = 14 + [ "3d99f9b7ac3a2fbe9cf15d960bf41f5588fc4db1e0d2a5c9c0fe9059f03593fb" + , "411f504bb63a9b3afa7ffa1357bb48be" + , "0bb5ebd55981a25ba69164da49fa92f2871fd3fc65eb30d0f0d0b8d798a4f8f2" + , "288e948a551284eb3cb23e26299955c2fb8f063c132a92683c1615ecaed80f30" + , "d975b22f79e34acf5db25a2a167ef60a10682dd9964e15533d75f7fa9efc5dcb" + , "ee8d707eea9bc7080d58768c8c64a991606bb808600cafab834db8bc884f866941b4a7eb8d0334d876c0f1151bccc7ce8970593dad0c1809075ce6dbca54c4d4667227331eeac97f83ccb76901762f153c5e8562a8ccf12c8a1f2f480ec6f1975ac097a49770219107d4edea54fb5ee23a8403874929d073d7ef0526a647011a" + ] + ] + +{- Reseed test vectors -} + +{- + [SHA-256] + [PredictionResistance = False] + [EntropyInputLen = 256] + [NonceLen = 128] + [PersonalizationStringLen = 0] + [AdditionalInputLen = 0] + [ReturnedBitsLen = 1024] +-} + +r1 :: [TestVector] +r1 = + [ + -- COUNT = 0 + [ "06032cd5eed33f39265f49ecb142c511da9aff2af71203bffaf34a9ca5bd9c0d" + , "0e66f71edc43e42a45ad3c6fc6cdc4df" + , "" + , "01920a4e669ed3a85ae8a33b35a74ad7fb2a6bb4cf395ce00334a9c9a5a5d552" + , "" + , "" + , "" + , "76fc79fe9b50beccc991a11b5635783a83536add03c157fb30645e611c2898bb2b1bc215000209208cd506cb28da2a51bdb03826aaf2bd2335d576d519160842e7158ad0949d1a9ec3e66ea1b1a064b005de914eac2e9d4f2d72a8616a80225422918250ff66a41bd2f864a6a38cc5b6499dc43f7f2bd09e1e0f8f5885935124" + ], + -- COUNT = 1 + [ "aadcf337788bb8ac01976640726bc51635d417777fe6939eded9ccc8a378c76a" + , "9ccc9d80c89ac55a8cfe0f99942f5a4d" + , "" + , "03a57792547e0c98ea1776e4ba80c007346296a56a270a35fd9ea2845c7e81e2" + , "" + , "" + , "" + , "17d09f40a43771f4a2f0db327df637dea972bfff30c98ebc8842dc7a9e3d681c61902f71bffaf5093607fbfba9674a70d048e562ee88f027f630a78522ec6f706bb44ae130e05c8d7eac668bf6980d99b4c0242946452399cb032cc6f9fd96284709bd2fa565b9eb9f2004be6c9ea9ff9128c3f93b60dc30c5fc8587a10de68c" + ], + -- COUNT = 2 + [ "62cda441dd802c7652c00b99cac3652a64fc75388dc9adcf763530ac31df9214" + , "5fdc897a0c1c482204ef07e0805c014b" + , "" + , "bd9bbf717467bf4b5db2aa344dd0d90997c8201b2265f4451270128f5ac05a1a" + , "" + , "" + , "" + , "7e41f9647a5e6750eb8acf13a02f23f3be77611e51992cedb6602c314531aff2a6e4c557da0777d4e85faefcb143f1a92e0dbac8de8b885ced62a124f0b10620f1409ae87e228994b830eca638ccdceedd3fcd07d024b646704f44d5d9c4c3a7b705f37104b45b9cfc2d933ae43c12f53e3e6f798c51be5f640115d45cf919a4" + ], + -- COUNT = 3 + [ "6bdc6ca8eef0e3533abd02580ebbc8a92f382c5b1c8e3eaa12566ecfb90389a3" + , "8f8481cc7735827477e0e4acb7f4a0fa" + , "" + , "72eca6f1560720e6bd1ff0152c12eeff1f959462fd62c72b7dde96abcb7f79fb" + , "" + , "" + , "" + , "d5a2e2f254b5ae65590d4fd1ff5c758e425be4bacdeede7989669f0a22d34274fdfc2bf87135e30abdae2691629c2f6f425bd4e119904d4785ecd9328f15259563e5a71f915ec0c02b66655471067b01016fdf934a47b017e07c21332641400bbe5719050dba22c020b9b2d2cdb933dbc70f76fec4b1d83980fd1a13c4565836" + ], + -- COUNT = 4 + [ "096ef37294d369face1add3eb8b425895e921626495705c5a03ee566b34158ec" + , "6e2e0825534d2989715cc85956e0148d" + , "" + , "1b4f7125f472c253837fa787d5acf0382a3b89c3f41c211d263052402dcc62c5" + , "" + , "" + , "" + , "4541f24f759b5f2ac2b57b51125077cc740b3859a719a9bab1196e6c0ca2bd057af9d3892386a1813fc8875d8d364f15e7fd69d1cc6659470415278164df656295ba9cfcee79f6cbe26ee136e6b45ec224ad379c6079b10a2e0cb5f7f785ef0ab7a7c3fcd9cb6506054d20e2f3ec610cbba9b045a248af56e4f6d3f0c8d96a23" + ], + -- COUNT = 5 + [ "a7dccdd431ae5726b83585b54eae4108f7b7a25c70187c0acbb94c96cc277aa8" + , "94c8f4b8e195a47356a89a50d1389ab5" + , "" + , "51733eee2e922f4055e53939e222e71fae730eb037443db2c7679708abb86a65" + , "" + , "" + , "" + , "99ba2691a622afecc9472418e6a8f9f1cdc1e3583c3bc7a2a650a1ab79dcbccbd656636c573179276e782569420c97438c06be898867f628b1c01eb570263d2c0f09c7aab536f6fba7df6aad19e05c236b645674667c03d1b6a04d7fc11177fe78933b309679f5bf26a4632b9a13e314c4bf4532428d3d95c689002b6dc1fbb1" + ], + -- COUNT = 6 + [ "c286425ecf543a49bcc9196b0db1a80bc54e4948adba6f41712a350a02891fa6" + , "957a659a4ec2e0b7ad185483c220fd61" + , "" + , "08c2129813eea0776fba72788fdf2718759cc3c4207fa20a5fe23ac6e32cc28e" + , "" + , "" + , "" + , "8e1020a4fd84c99e0fc7e3f7ce48de5ed9ec9a5c2ccd624dbe6f30e2f688a31dc55957630357a5d48ca2a456241a28bfb16d8bb000877697a7ce24d9ad4d22b0c15117996f1f270b94f46d7a9bdfa7608fa1dd849177a9b8049e51b6b7a2742623854a1fddb5efc447eed1ea1aed6f02b4b2754ecf71ea0509da2e54f524a7e7" + ], + -- COUNT = 7 + [ "02818bd7c1ec456ace55beeba99f646a6d3aa0ea78356ea726b763ff0dd2d656" + , "c482687d508c9b5c2a75f7ce390014e8" + , "" + , "cf319bfa63980e3cb997fd28771bb5614e3acb1149ba45c133ffbbab17433193" + , "" + , "" + , "" + , "19a231ff26c1865ce75d7a7185c30dd0b333126433d0c8cbf1be0d2b384d4eb3a8aff03540fbfa5f5496521a4e4a64071b44c78bd0b7e68fac9e5695c5c13fd3b9dbe7f7739781a4c8f0b980f1b17d99bce17ceb52b56866ae02456ffef83399c8cf7826f3c45c8a19315890919d20f40fc4e18d07e9c8ccd16c3327b5988f71" + ], + -- COUNT = 8 + [ "77a5c86d99be7bc2502870f4025f9f7563e9174ec67c5f481f21fcf2b41cae4b" + , "ed044ad72ee822506a6d0b1211502967" + , "" + , "778100749f01a4d35c3b4a958aafe296877e0acafd089f50bc7797a42a33ab71" + , "" + , "" + , "" + , "831a4da566f46289904893ef1cc1cd4ad19ee48f3857e2b69e936d10afbdc29822e85d02663d346ef3e09a848b1d9cc04f4c4c6e3b3b0e56a034e2334d34ca08f8097be307ba41d020bc94f8c1937fe85644eeb5592c2b5a2138f7ded9a5b44b200c8b5beb27597c790f94d660eb61e8248391edc3ae2d77656cbe8354275b13" + ], + -- COUNT = 9 + [ "0ea458cff8bfd1dd8b1addcba9c01317d53039e533104e32f96e7d342e6c7b9b" + , "935a4b66fc74c2a48757a99c399e64e3" + , "" + , "6c5f3708e7b714c4ed139b4fa9e8c763af01773484005109a85e33653bb0ce98" + , "" + , "" + , "" + , "373a37af84fddec13645a9768d6a785ae5a2589d64cd9b37980dde2541499210c4f408335de1d585349064f3f53a2b4c5ec6dc2a09591f99ad9fad528ac83474164b45497bf167f81e66fa08463ffea917f6891e48f149fafc20622bb1172f34886feb45c26fd446a4a4e2891b4bc594186896141aaaeeb301b49e7c1a26fec7" + ], + -- COUNT = 10 + [ "bfb68be4ce1756d25bdfad5e0c2f8bec29360901cc4da51d423d1591cc57e1ba" + , "98afe4bd194c143e099680c504cceaab" + , "" + , "b97caf210e82498c3408790d41c320dd4a72007778389b44b7bc3c1c4b8c53f8" + , "" + , "" + , "" + , "409e0aa949fb3b38231bf8732e7959e943a338ea399026b744df15cbfeff8d71b3da023dcce059a88cf0d4b7475f628e4764c8bef13c70cfbbbb6da2a18aabcad919db09d04fc59765edb165147c88dd473a0f3c5ee19237ca955697e001ba654c5ee0bd26761b49333154426bc63286298a8be634fe0d72cfdeef0f3fc48eca" + ], + -- COUNT = 11 + [ "4f6880a64610004463031d67d7924fa446c39138d4d41007e8df3d65691a9367" + , "6b33b2c13600f4b1df6ca3d1960e8dd4" + , "" + , "57b87b8c8f48312b5333d43b367730c0a5ad4725a16778fcb53fe136d136cbfd" + , "" + , "" + , "" + , "73d0f324ed186e2ad06bd1800e262bdbda79ba54e626761bd60f74f43e3bb62958ec1e2f1d940af163e1cadc124e7ebaba2f72e67efd746c7f6d0cad53ef03d859d93cff778a32ee5be172fe7fdbdc232ded360d704a6fa0f70bebe942e56478345492f49dc5c6fc346b88a58947ad250e688e8c626fe1efe7624620e571976e" + ], + -- COUNT = 12 + [ "aae352e111843219cae8f70e7b8f6eb9bb53d246cbec1e4f07d42757143295b4" + , "b84485dccd1bf93210e322eafcbebcd9" + , "" + , "f9237f00d744d8fbff21b9d0043c258e8731817e6a5fb7b4bf5011680e5bc642" + , "" + , "" + , "" + , "cfb28b93522c7d61d8d3ce3f080e435e4c83c7e13a9dab788db8fef0407267a14fbc9324e090e24df5491fedfa81116869983938d4d4d7324a310c3af33a6f7938f602c5e4e63f1771cdaabdab0782b5affb54eb53047c109a9606739dd0065bd21eca33132986554878354f5f9f852e674dd690163b0ff74c7a25e6bae8ce39" + ], + -- COUNT = 13 + [ "589e79e339b7d2a1b879f0b0e1a7d1ad2474eaa8025b070f1ffa877b7124d4ff" + , "0961ed64dbd62065d96e75de6d2ff9d6" + , "" + , "e928388d3af48c2968527a4d2f9c2626fbc3f3f5a5d84e0583ab6f78e7f8b081" + , "" + , "" + , "" + , "fce6ced1ecf474d181ab331f79c3d2cc8a768ec2818de5b3fc7cf418322716d6a6853733561a497c0c25cb288d2c9fcfbca891bafd5a834c85f3603f402acf1a7b1ea92db847ed5c252a862ad4ab5e259715f1fc81da67f5230bf8be50ee8069758095f7d0e559e03f2c6072290e61794458437609e473eb66580cddaad19b71" + ], + -- COUNT = 14 + [ "714277d408ad87fde317f0a94732fce62f1352bdc90936673b4f1daa0925aa26" + , "d16582a99f23010b4248b88d86485419" + , "" + , "bd9fc7cb2fd5063b2c3c0c4f346ad2e3879371a9c805e59b9f2cd2cc2a40894f" + , "" + , "" + , "" + , "62ef7a431288252e0d736c1d4e36cc9ac37107dcd0d0e971a22444a4adae73a41eff0b11c8625e118dbc9226142fd0a6aa10ac9b190919bda44e7248d6c88874612abd77fb3716ea515a2d563237c446e2a282e7c3b0a3aef27d3427cc7d0a7d38714659c3401dbc91d3595159318ebca01ae7d7fd1c89f6ad6b604173b0c744" + ] + ] + +{- + [SHA-256] + [PredictionResistance = False] + [EntropyInputLen = 256] + [NonceLen = 128] + [PersonalizationStringLen = 0] + [AdditionalInputLen = 256] + [ReturnedBitsLen = 1024] +-} + +r2 :: [TestVector] +r2 = + [ + -- COUNT = 0 + [ "05ac9fc4c62a02e3f90840da5616218c6de5743d66b8e0fbf833759c5928b53d" + , "2b89a17904922ed8f017a63044848545" + , "" + , "2791126b8b52ee1fd9392a0a13e0083bed4186dc649b739607ac70ec8dcecf9b" + , "43bac13bae715092cf7eb280a2e10a962faf7233c41412f69bc74a35a584e54c" + , "3f2fed4b68d506ecefa21f3f5bb907beb0f17dbc30f6ffbba5e5861408c53a1e" + , "529030df50f410985fde068df82b935ec23d839cb4b269414c0ede6cffea5b68" + , "02ddff5173da2fcffa10215b030d660d61179e61ecc22609b1151a75f1cbcbb4363c3a89299b4b63aca5e581e73c860491010aa35de3337cc6c09ebec8c91a6287586f3a74d9694b462d2720ea2e11bbd02af33adefb4a16e6b370fa0effd57d607547bdcfbb7831f54de7073ad2a7da987a0016a82fa958779a168674b56524" + ], + -- COUNT = 1 + [ "1bea3296f24e9242b96ed00648ac6255007c91f7c1a5088b2482c28c834942bf" + , "71073136a5cc1eb5b5fa09e1790a0bed" + , "" + , "d714329f3fbea1df9d0b0b0d88dfe3774beb63d011935923d048e521b710dc6f" + , "4ef872fd211a426ea1085ab39eb220cc698fdfeabe49b8835d620ab7885de7a4" + , "d74d1669e89875852d9ccbf11c20fe3c13a621ebcb3f7edeea39a2b3379fdcf5" + , "0c8aa67ca310bd8e58c16aba35880f747266dbf624e88ec8f9ee9be5d08fdeb1" + , "ce95b98f13adcdf7a32aa34709d6e02f658ae498d2ab01ce920f69e7e42c4be1d005acf0ca6b17891dfafc620dd4cd3894f8492a5c846089b9b452483eb0b91f3649ec0b6f98d1aaabc2e42cd39c2b25081b85ab50cb723007a0fd83550f32c210b7c4150b5a6bb3b0c9e3c971a09d43acb48e410a77f824b957092aa8ef98bc" + ], + -- COUNT = 2 + [ "a7ea449b49db48601fc3a3d5d77081fab092b8d420ed1b266f704f94352dd726" + , "d11a159b60af8d20a0e37d27e6c74aa3" + , "" + , "50916ab47e8cb5dc843f9fba80639103711f86be8e3aa94f8a64a3fe0e6e5b35" + , "e2bb6768120555e7b9e0d573537a82f8f32f54560e1050b6abb1588fb3441e66" + , "a50cec9d1ecddb2c163d24019e81c31a2b350ccd3ad8181fd31bb8d1f64fa50e" + , "591dbbd48b51abced67f9c6269cf0133cd3dcbb5cfafcb6ef758569c555a5773" + , "0a464abcc8685158372d544635b953fcb1d3821c30aaa93982f9b788935f00f88115aad61d5cee003b3d1cb50f3e961a501e2dd0fc7e1724778b184a4bdf9f64e110dda7446e5544a30bd49a400ea1a5411800e1edfeea349323618afc5dc5782dc4b71d2da4d6a4785f8dd346feb9c8740ffd26bf644e3e4323ff24c30b9f10" + ], + -- COUNT = 3 + [ "14683ec508a29d7812e0f04a3e9d87897000dc07b4fbcfda58eb7cdabc492e58" + , "b2243e744eb980b3ece25ce76383fd46" + , "" + , "18590e0ef4ee2bdae462f76d9324b3002559f74c370cfccf96a571d6955703a7" + , "9ea3ccca1e8d791d22fcda621fc4d51b882df32d94ea8f20ee449313e6909b78" + , "16366a578b5ea4d0cb547790ef5b4fd45d7cd845bc8a7c45e99419c8737debb4" + , "a68caa29a53f1ba857e484d095805dc319fe6963e4c4daaf355f722eba746b92" + , "c4e7532ee816789c2d3da9ff9f4b37139a8515dbf8f9e1d0bf00c12addd79ebbd76236f75f2aa705a09f7955038ebff0d566911c5ea13214e2c2eeb46d23ad86a33b60f7b9448d63eec3e1d59f48b39552857447dc5d7944667a230e3dbfa30ca322f6eacaf7536a286706a627c5083c32de0658b9073857c30fb1d86eb8ad1b" + ], + -- COUNT = 4 + [ "fa261fb230e2822458532ca2d5c39758750e6819a6fcebef10579ba995096959" + , "564e1c9fbcb12878df2bd49202cbf821" + , "" + , "bf7de29e99e7f0e1b9f96f3b1902fb4049c8c6234d20de8316ebe66d97725457" + , "8b7326621f6afbd44a726de48d03bcc5331f7306026c229ea9523497fbeaa88d" + , "33b00b31623d6160c4c6740363a96481be14b19bc47be95641227284c366922a" + , "2d812c8203575790ad6b6f2ed91a49d57460de779a3e881bef3be12e8766dc91" + , "5574e0b4efc17e8ce136e592beabfe32551072bddd740929e698467b40b3991f028a22c760f7034853cc53007e3793e3c4a600d9e9d94528f8dc09aeba86146cdde2b7f71255ae0efc529b49be2205979dba6525bfe155e8819e8e2aeeaa285704242da90b4c4535101cc47d94b0e388a1b2e63ad0cbe158b9e1bbae9cc0007c" + ], + -- COUNT = 5 + [ "61f1471ced56aa04c57e1b512307d4cb92497d9592d7e9e35356e99d585cab1b" + , "84714e960c403a4fac06b2828cc564d9" + , "" + , "7bf97db3c102edc81596d4757045fe6bdc008f35792fc6290b77d889c09c33a8" + , "5b8bdc41f76d98cfa71ed976ea3994706375c8841adb8b6b3b6418e3132e8832" + , "94c8a8fdf38a6ccb8571c89420d899adab169214bb0dfcd43a04622e289935b2" + , "8a4b46e0a7a55907365f82d4ab9376509bd44728cab8cbafb0da901012ad8dcd" + , "933eb159a6af7455b60e40586c064f05f1970f564281b1ebc4662701ac1f299e4eb908c4afcb2e065191281ab576f684aefedd6904bad04d96bd93c0516c62a496c3073a0cda0676a11cc08866b0cc74f62cb9d3db48673b2c3fbeada69f922b4b795ccba22df12ef7125909381f7d681f6b9caba02fb913c5437b98c040c576" + ], + -- COUNT = 6 + [ "a1d5bb7d70621dee6b668b28c56d5610c2f8ced30284cc3e0e48de331af05062" + , "88a49e3e54c5ea54c98b95de81bcc807" + , "" + , "b4e2426e98f6eed97a6cdf690a89ee109e84c3dca16c883c26fa4ac671638d8d" + , "5bd1e086ed228cfd8b55c1731fea40c3a63d022599ca2da4bb23118f4821ba62" + , "b754b53ac226e8ebe47a3d31496ec822de06fca2e7ef5bf1dec6c83d05368ec3" + , "fa7e76b2805d90b3d89fff545010d84f67aa3a2c9eb2ba232e75f4d53267dac3" + , "df6b2460688fa537df3ddfe5575fca5eb8abad56cbc4e5a618a2b4a7daf6e215c3a497974c502f9d0ec35de3fc2ea5d4f10de9b2aee66dcc7e7ae6357983095959b817f0383e3030771bd2ed97406acf78a1a4a5f30fa0992289c9202e69e3eb1eabe227c11409ff430f6dfca1a923a8b17bc4b87e908007f5e9759c41482b01" + ], + -- COUNT = 7 + [ "68f21d14525d56233c7e263482d344c388a840103a77fb20ac60ce463cabdc79" + , "59fa80ae570f3e0c60ac7e2578cec3cb" + , "" + , "7584b4166530442f06e241dd904f562167e2fdae3247ab853a4a9d4884a5fa46" + , "f6a5482f139045c5389c9246d772c782c4ebf79c3a84b5cf779f458a69a52914" + , "9d37b1ce99f8079993ddf0bd54bab218016685b22655a678ce4300105f3a45b7" + , "4c97c67026ff43c2ee730e7b2ce8cce4794fd0588deb16185fa6792ddd0d46de" + , "e5f8874be0a8345aabf2f829a7c06bb40e60869508c2bdef071d73692c0265f6a5bf9ca6cf47d75cbd9df88b9cb236cdfce37d2fd4913f177dbd41887dae116edfbdad4fd6e4c1a51aad9f9d6afe7fcafced45a4913d742a7ec00fd6170d63a68f986d8c2357765e4d38835d3fea301afab43a50bd9edd2dec6a979732b25292" + ], + -- COUNT = 8 + [ "7988146cbf9598d74cf88dc314af6b25c3f7de96ae9892fb0756318cea01987e" + , "280bc1ae9bfdf8a73c2df07b82a32c9c" + , "" + , "2bbc607085232e5e12ccf7c0c19a5dc80e45eb4b3d4a147fe941fa6c13333474" + , "f3f5c1bb5da59252861753c4980c23f72be1732f899fdea7183b5c024c858a12" + , "44d0cfc4f56ab38fa465a659151b3461b65b2462d1ad6b3463b5cf96ad9dc577" + , "34fb9a3cdacc834ff6241474c4f6e73ed6f5d9ea0337ab2b7468f01ad8a26e93" + , "4caec9e760c4d468e47613fe50de4a366ae20ba76793744a4e14433ea4de79dc188601eb86c803b094641ab2337b99d459d37decc7d27473057be45ba848868ee0fb5f1cf303d2fcd0b3e0c36f65a65f81b3fee8778a1f22302e25dfe34e6d587fa8864e621121880f7cd55f350531c4ce0530099eec2d0059706dcd657708d9" + ], + -- COUNT = 9 + [ "1c974c953fa2a057c9fc9409a6843f6f839aa544bca4fa11e48afd77931d4656" + , "ed7c08285464af7a5dbdc10b944a1270" + , "" + , "78146ad135acb836360d36afc50653dcc36c21662da2a6f6ae05222e75f34000" + , "263c4984c238ded333c86472866353817379502157172cfa51371d82b1efd7b5" + , "79b591529f9a26a0d7c8f8fd64e354b0c134ef1f757e43f9463b3dbb7a3da1ab" + , "7d8f7204b0b5401ddce9e88dcf5facb9a44660a9f5f1c862748e7269c29f7964" + , "72e2ca257b9edaf59b50e05a144f56fb517832fb9ad3489b1e664e3d5412cbf6b2883e891703b2e73aff9ab56da1009fcdef010ab4cdab996795c8f7c47fb1192bb160353997ad39d7d5fd0e2efc9103a7c3f158246afd53fe53ca6782f809698ef5f1f0d85536780a3fd6a8bafa475891c09213088bd1a3dc169257c34a517a" + ], + -- COUNT = 10 + [ "56216d71984a77154569122c777ce57e1d101a6025b28163a25971d39c1c5d0f" + , "5cd148ba7e54f4975ac8e3e0f9b5d06a" + , "" + , "3580f8ca974626c77259c6e37383cb8150b4d0ab0b30e377bed0dc9d1ff1a1bf" + , "15633e3a62b21594d49d3d26c4c3509f96011d4dbb9d48bbbea1b61c453f6abe" + , "6068eaca85c14165b101bb3e8c387c41d3f298918c7f3da2a28786ab0738a6fc" + , "e34f92d2b6aeeeea4ff49bfe7e4b1f462eabb853f0e86fbae0e8b3d51409ce49" + , "587fdb856abc19ede9078797ecb44099e07aadcd83acdcb2b090601d653f4a14c68ab2ebdda63578c5633a825bae4c0c818f89aac58d30fd7b0b5d459a0f3d86fcad78f4bb14dfff08ad81e4ea9f487cb426e91d6e80dfed436ba38fce8d6f21ca2151c92dd5c323b077d6139c66395558f0537026c4a028affa271ef4e7ea23" + ], + -- COUNT = 11 + [ "83eb48bedc1e9294866ab8e5322ef83f6f271f8188e8fdabe5817788bd31570d" + , "d6ed90bc692237f132441ede857a6629" + , "" + , "a4e5e127f992bd5ca79ee56bb8a9bccf74c21814bfaf97ffd052211e802e12e4" + , "84136e403d9ed7f4515c188213abcfaca35715fa55de6d734aec63c4606a68f1" + , "fe9d8ef26e2d2e94b99943148392b2b33a581b4b97a8d7a0ecd41660a61dd10b" + , "594dad642183ce2cdc9494d6bcb358e0e7b767c5a0fa33e456971b8754a9abd5" + , "86715d43ba95fbbca9b7193ea977a820f4b61ba1b7e3b8d161b6c51b09dfd5040d94c04338b14d97ed25af577186b36ae7251a486c8a2d24a35e84a95c89d669d49e307b4a368b72164135ac54d020a970a180dfbed135d2c86f01270846d5301bd73db2c431a8aa10a0a3d03d146e5fafb9a2aa0b4efc80edab06ff3b532236" + ], + -- COUNT = 12 + [ "ba2c94203dab2e6499d8c50dca7b5c34a6b4764834f9816631aa21b9f9c37361" + , "67db133bdefb25e395085bceee5a0afc" + , "" + , "fa8984d16d35302cda35a3a355ab9242ec96fec0652d39282d4a0abf0a80df87" + , "b6fed10255a3fea6772ae1ae6d9f6cbb9bfaa34804e58a5b786f9bc60b348ccd" + , "445e072244edc716d3528f0e0a20ff0cd8f819c0d031736c8da122748f24d6c6" + , "1f856e403c4fa035bac9aa81a20e347c7d8b213aab699d69d9d6186a06ac45c1" + , "79f33fc36b3b47d9ac805bdbbe699909a8d0beb689a8b2723c291bd5bf7f3ce61343d4722a14e4add36312dbb0594910c8828aff1abc159915d498106f9ffb31147478d8c9ef75d1536ba5036506b313f6e85033f8f6fea2a4de817c867a59378c53c70a2f108275daedd415c05b61c4fd5d48c54be9adb9dea6c40a2ec99ee0" + ], + -- COUNT = 13 + [ "0db4c51492db4fe973b4bb1c52a1e873b58fc6bb37a3a4bfc252b03b994495d1" + , "a2a3900f169bba3f78a42526c700de62" + , "" + , "29d5aab356876447e3a20d81c7e3fc6975e2b984180a91493044442999e1ca3a" + , "40b34183b4e72cdff5952b317b3d45943d0fdcfa0527f3563055f7c73ae8f892" + , "dc94220c99ffb595c7c4d6de8de5a6bb4b38847169e24a557ef6d879ad84149d" + , "b2376626fd2f5218b3ed4a5609b43aa24d371cd2176ea017c2b99cf868060021" + , "f0bd6bc4c506d9427a09352d9c1970b146360732841a6323f4cb602c87dedfb5ff7e6964b9144933af3c5c83017ccd6a94bdca467a504564aaa7b452591a16ff6a1e7e94ddc98f9a58016cdcb8caaed6c80671ba48cc81a832d341093dda1d4e5001ec6bf66348b21e3692a13df92538ad572bb2023822072fc95f9590293ffc" + ], + -- COUNT = 14 + [ "593845f0adfeffa7c169f8a610147ae8a08c0072fc0c14c3977d3de0d00b55af" + , "9e0eb2507342ee01c02beadee7d077bd" + , "" + , "aefe591697eab678c52e20013aa424b95cfd217b259757fbe17335563f5b5706" + , "cbb5be0ef9bf0555ee58955c4d971fb9baa6d6070c3f7244a4eb88b48f0793bf" + , "6dd878394abdc0402146ba07005327c55f4d821bfebca08d04e66824e3760ab4" + , "ba86a691d6cbf452b1e2fd1dfb5d31ef9ea5b8be92c4988dc5f560733b371f69" + , "00735cbfafac5df82e5cb28fc619b01e2ba9571dc0023d26f09c37fb37d0e809066165a97e532bf86fa7d148078e865fe1a09e27a6889be1533b459cd9cd229494b5cf4d2abf28c38180278d47281f13820276ec85effb8d45284eb9eef5d179ab4880023ab2bd08ee3f766f990286bf32430c042f5521bbfd0c7ee09e2254d7" + ] + ] + +{- + [SHA-256] + [PredictionResistance = False] + [EntropyInputLen = 256] + [NonceLen = 128] + [PersonalizationStringLen = 256] + [AdditionalInputLen = 0] + [ReturnedBitsLen = 1024] +-} + +r3 :: [TestVector] +r3 = + [ + -- COUNT = 0 + [ "fa0ee1fe39c7c390aa94159d0de97564342b591777f3e5f6a4ba2aea342ec840" + , "dd0820655cb2ffdb0da9e9310a67c9e5" + , "f2e58fe60a3afc59dad37595415ffd318ccf69d67780f6fa0797dc9aa43e144c" + , "e0629b6d7975ddfa96a399648740e60f1f9557dc58b3d7415f9ba9d4dbb501f6" + , "" + , "" + , "" + , "f92d4cf99a535b20222a52a68db04c5af6f5ffc7b66a473a37a256bd8d298f9b4aa4af7e8d181e02367903f93bdb744c6c2f3f3472626b40ce9bd6a70e7b8f93992a16a76fab6b5f162568e08ee6c3e804aefd952ddd3acb791c50f2ad69e9a04028a06a9c01d3a62aca2aaf6efe69ed97a016213a2dd642b4886764072d9cbe" + ], + -- COUNT = 1 + [ "cff72f345115376a57f4db8a5c9f64053e7379171a5a1e81e82aad3448d17d44" + , "d1e971ec795d098b3dae14ffcbeecfd9" + , "6ec0c798c240f22740cad7e27b41f5e42dccaf66def3b7f341c4d827294f83c9" + , "45ec80f0c00cad0ff0b7616d2a930af3f5cf23cd61be7fbf7c65be0031e93e38" + , "" + , "" + , "" + , "17a7901e2550de088f472518d377cc4cc6979f4a64f4975c74344215e4807a1234eefef99f64cb8abc3fb86209f6fc7ddd03e94f83746c5abe5360cdde4f2525ccf7167e6f0befae05b38fd6089a2ab83719874ce8f670480d5f3ed9bf40538a15aaad112db1618a58b10687b68875f00f139a72bdf043f736e4a320c06efd2c" + ], + -- COUNT = 2 + [ "b7099b06fc7a8a74c58219729db6b0f780d7b4fa307bc3d3f9f22bfb763596a3" + , "b8772059a135a6b61da72f375411de26" + , "2ac1bfb24e0b8c6ac2803e89261822b7f72a0320df2b199171b79bcbdb40b719" + , "9aec4f56ec5e96fbd96048b9a63ac8d047aedbbeea7712e241133b1a357ecfc4" + , "" + , "" + , "" + , "0e1f2bfef778f5e5be671ecb4971624ec784ed2732abc4fbb98a8b482fb68737df91fd15acfad2951403ac77c5ca3edffc1e03398ae6cf6ac24a91678db5c7290abc3fa001aa02d50399326f85d2b8942199a1575f6746364740a5910552c639804d7530c0d41339345a58ff0080eccf1711895192a3817a8dc3f00f28cc10cc" + ], + -- COUNT = 3 + [ "7ba02a734c8744b15ef8b4074fe639b32e4431762ab5b7cd4d5df675ea90672b" + , "8a424f32108607c8f1f45d97f500ee12" + , "3ad627433f465187c48141e30c2678106091e7a680229a534b851b8d46feb957" + , "d8f02b59b6a3dd276bc69cba68efcf11ab83ead1397afd9841786bd1bb5da97a" + , "" + , "" + , "" + , "1fb91186ba4b4459d994b4b9f4ca252c7be6294d6cdb5fe56f8ff784d4b190a1c6456e0a41223bbbdf83ed8e7cfbfa765d9d8bc7ea5f4d79ea7eccb4928081a21de4cca36620d6267f55d9a352b76fc0a57375884112c31f65ff28e76d315698c29e6c4c05cb58b0a07ae66143b4abc78b9d25c78b4121e1e45bef1a6c1793e2" + ], + -- COUNT = 4 + [ "9a8865dfe053ae77cb6a9365b88f34eec17ea5cbfb0b1f04d1459e7fa9c4f3cb" + , "180c0a74da3ec464df11fac172d1c632" + , "336372ec82d0d68befad83691966ef6ffc65105388eb2d6eed826c2285037c77" + , "75b95108eff1fabe83613e1c4de575e72a5cdc4bb9311dd006f971a052386692" + , "" + , "" + , "" + , "3c683f6d4f8f5a4018d01633dfee74266aaa68ed6fc649e81b64dfdf5f75e75d5c058d66cf5fd01a4f143a6ff695517a4a43bd3adfd1fb2c28ba9a41063140bedbffdb4d21b1ace1550d59209ec61f1e2dbacb2a9116a79cb1410bf2deca5218080aacd9c68e1d6557721a8913e23f617e30f2e594f61267d5ed81464ee730b2" + ], + -- COUNT = 5 + [ "22c1af2f2a4c885f06988567da9fc90f34f80f6dd5101c281beef497a6a1b2f8" + , "3fafdecf79a4174801f133131629037b" + , "80327dac486111b8a8b2c8e8381fb2d713a67695c2e660b2b0d4af696cc3e1de" + , "f95a0e4bd24f0e2e9e444f511b7632868ead0d5bb3846771264e03f8ab8ed074" + , "" + , "" + , "" + , "77a7fea2f35a188f6d1bfdd49b569d8c45e2dd431d35a18c6f432c724f1e33ae92cb89a9cf91519e50705a53199f5b572dc85c1aef8f28fb52dc7986228f66954d54eda84a86962cf25cf765bd9949876349291b1aae5f88fcf4b376912d205add4f53b2770c657946c0d824281f441509153f48356d9d43f8a927e0693db8fc" + ], + -- COUNT = 6 + [ "d0840e3a8d629d5b883d33e053a341b21c674e67e1999f068c497ecfaabfd6f6" + , "071de7244ecb2fdf7ab27f2d84aa7b7a" + , "90d609527fad96ffe64ab153860346f3d237c8940555ae17b47842d82d3b0943" + , "1dd1a8b59856c49a388f594c5f42cc2e4a56b3ccb8a65e7066e44c12f4344d50" + , "" + , "" + , "" + , "7ab28a9b2d3ae999195553e6550cced4c2daccbe7ec9dcbb0d467fabba185b727fbfd9830242cd098f4db3cf4a85e8bf8e8d5974b62b28550922b32ed5bfc1a522b6605cf93bf8d90bdec1c5b9e59c6fc37a817d437068a87254be1f7c4618ada46fbc3a2efb02e44524e21d91be7534cf05fbfd858304b706d6a91ea1cc6ad5" + ], + -- COUNT = 7 + [ "2e2dd56869104492767a59778652831919e1c8b970f84e824ae4116597a0ab7f" + , "01c42a7e983641de46c82fd09b4f2f76" + , "bcd9e1508fcc22820a8be07180fea5045367333b569e111b011cd57dc1858765" + , "7306507cd3ca7eec667e640d270cfbb033063d97520b6b7e38ff3cea0e79d12b" + , "" + , "" + , "" + , "b915726c7b8c5dc3975f1a334684b973abf6a9495d930088cf5d071548e4fd29a67b55cc561ed6949ad28150a9fb4307c1fa5f783a7ea872e8d7c7e67ff0c2906081ee915737d813c25be5c30b952a36f393e6baa56ab01adc2b4776ad7b5d036a53659877c7a4e5220a897d6c0799af37beeed91173fbe9c613c3b6b9bb28e5" + ], + -- COUNT = 8 + [ "d1aab0f16bd47a5ccd67c22e094daa3735eae21aa57f0bcd9e053d9d0d545cb8" + , "199310dfe1b01265b8c0d2b46d6c7c9f" + , "625b4b8f4de72ea9cb6f70556322dc2a19d6b2b32de623f557e419a084ba60fd" + , "f50cabae4e060f3971096b78e550cda2837a26a693d905db2d992d589b268f44" + , "" + , "" + , "" + , "987e1fdfe004c619cf1e9034576707eccd849400e19c87a1fef5b0179ec51c42a2f8c45d7942d0023a023c89f188b2634362703985695369863322f58619c50a7385a2dc91fc78f94b59f0131dc2b56a0d7c699d427285da1c104b0ad1739da10d8071c23993787045dc21f0070e1e9aa1658fc8e3add73dac7262e80e0aa2ee" + ], + -- COUNT = 9 + [ "449480eaa100aff6f48dc6286a5a81b9728b084864f78a9da98f606a00a6a41f" + , "e53c6c5ac3da9f4726389a03f97bb640" + , "6b8fedc084d8e28d333aef6db3702b6351f0d24e30908cccb63794282655886b" + , "73a6d64e1966ae324388dc12c14544e9dc5ae4fcb331e99d350c456ff16f9aa0" + , "" + , "" + , "" + , "a06912d362da7eb25598857f6d65344c3e23ec3deb80c6e43158845b95eaeca241c0bbbd67ac385e24693444455cc1c2c08c1134d956b8bc93b28be9c2d3322b3e09252979dfb8d39d04c94f81bebda5c73110605a237b561216bda9ee9bdee1cc0c7728bcc8304682334ca944e467a27a85313fa5395a9c790e35defd2edb12" + ], + -- COUNT = 10 + [ "9a6174166e97aa4981ddf580bc01c96754b9f0ba042750aabfda1cffe56e8581" + , "d7512ff6b7db7ce141b2bb01dcd0425e" + , "ed75288f23275f9422444da5d3b53ccb3c4ac8acfb659a1e9b7655c2db52f879" + , "6888b9277e57dc57663d402eba8d03cf56a070dc868e6a128b18040002baf690" + , "" + , "" + , "" + , "03519dfb2ff88cc2b53eecc48ae2a18ddcf91a5d69d5aefcdda8444e6df790a5240e67b2a4de75b4bb8a31f0f8aeb5e785ffb7a1341bb52fe00a05ee66fa2d44ea9956e055f9ffa6647c3bfe851ab364ade71a0d356de710ddafb7622b1da1bc53fd4d3210407289c68d8aeb346bf15806dbe787e781b94f63da3e1f61b5ac60" + ], + -- COUNT = 11 + [ "9c6ae1002ee1b0add0be563ce50f899da936e13efa620d08c2688c192514763a" + , "fde7db5160c73044be73e9d4c1b22d86" + , "8fdaaeffd64e53f7b4374d902d441209964e12b65d29afec258e65db6de167ca" + , "bcc28fd58e397f53f494ad8132df82c5d8c4c22ea0b7139bd81eeba65667bb69" + , "" + , "" + , "" + , "021d938c9b4db780c7d8134aeff1053e5b8843370b8ae9a6749fca7199d809810f1bc8dfa49426470c30c3616f903e35fbacb23420a32f1bee567cc32300f704246ddc0217f236ef52c3ec9e2433ca66f05c25721f7661c43f22c1a125ed5db531bd0836eb435c27eefc7424ce9d845e1d4cc4c503097b4ffca788e674a5cb53" + ], + -- COUNT = 12 + [ "fe96a85b69d46b540918927bb609dc57642eeaefd46bb5da2163a0bc60294b58" + , "22195a410d24db45589448dfe979d3fd" + , "20f698833a4472fd7b78fb9b0c4eb68604f166a2694c4af48dac2b2376790e1e" + , "09cb870879d3f734214f6a4bd2e08c62a2a954bebe559416d8c3551aafe71d6a" + , "" + , "" + , "" + , "d3e96dbe29e1fcb8ed83b19dbfb240e6f41679fbe83853aa71446617e63e5af78cf98b331d15bccb8c673c4e5d5dcec467a1fe26a6cd1696d0c9bc49f78139d051287df7f3ae0dbb4bbf581cb8211931063c3f4612ced53f59d1b4ebb875729139f5d2a7d60642e8f2835eed888b7e3e49c0dffd012cd746abfa3e1c5c2308c6" + ], + -- COUNT = 13 + [ "a4fd693ff0a8af24bcec352d3196549fd0da5ee5d99ca58416ca03ce4c50f38e" + , "8cd67f2bf71d4366ce61396642531ff5" + , "368969c15a4849d7593be8b162113b9298a535c148ff668a9e8b147fb3af4eba" + , "83d2be9a0d74e6a42159ae630acebf4e15271ef7f14f3de14752be0e0e822b11" + , "" + , "" + , "" + , "e9188fc0eaec74b2608e21e3a40be94aaf4ae08eb684de8f8bba2d5fd3b073aa5531c938c0fc628da65725c54b5c68bb91d7d326565e96685e0a4e7b220c50e0caf1628edba5bd755b31894f8cb90afa76e88c5eb9e61b4932444c1397dee3e32241a3fb70a3929e49f6da02eea54812abb3d6b5cee18f03af1e0b4958430ab3" + ], + -- COUNT = 14 + [ "254ff5687a6dad3f1d237dc762f58d24ef2e2c084d0a48d26a3dc81e5490cda3" + , "f2ec392acca491e03ce47b95963a49fc" + , "f806b9b4a56682c61b55cb6a334caf87ffe135adfea6d0c3fc22b39898fbd078" + , "b8494b1c1f1752fb6f80d732a89b08115857f7cc96e7dff05ebb822706889917" + , "" + , "" + , "" + , "0e527e00494d55564f9d9b28e7110f9a61ce36c883b5be2dcb055444164cdddd1a9f2731716f22d6ff476ce413c77abfc0e946871d5481345c2e97b4bfdd12ac03df606fc56bdb99ac7b71a69b5b9160373bbec3e9dde477180af454e7acc6bc58dc0afb4281c0de4354c1bf599054e3800c6d60d892858865b5361f50bfca9b" + ] + ] + +{- + [SHA-256] + [PredictionResistance = False] + [EntropyInputLen = 256] + [NonceLen = 128] + [PersonalizationStringLen = 256] + [AdditionalInputLen = 256] + [ReturnedBitsLen = 1024] +-} + +r4 :: [TestVector] +r4 = + [ + -- COUNT = 0 + [ "cdb0d9117cc6dbc9ef9dcb06a97579841d72dc18b2d46a1cb61e314012bdf416" + , "d0c0d01d156016d0eb6b7e9c7c3c8da8" + , "6f0fb9eab3f9ea7ab0a719bfa879bf0aaed683307fda0c6d73ce018b6e34faaa" + , "8ec6f7d5a8e2e88f43986f70b86e050d07c84b931bcf18e601c5a3eee3064c82" + , "1ab4ca9014fa98a55938316de8ba5a68c629b0741bdd058c4d70c91cda5099b3" + , "16e2d0721b58d839a122852abd3bf2c942a31c84d82fca74211871880d7162ff" + , "53686f042a7b087d5d2eca0d2a96de131f275ed7151189f7ca52deaa78b79fb2" + , "dda04a2ca7b8147af1548f5d086591ca4fd951a345ce52b3cd49d47e84aa31a183e31fbc42a1ff1d95afec7143c8008c97bc2a9c091df0a763848391f68cb4a366ad89857ac725a53b303ddea767be8dc5f605b1b95f6d24c9f06be65a973a089320b3cc42569dcfd4b92b62a993785b0301b3fc452445656fce22664827b88f" + ], + -- COUNT = 1 + [ "3e42348bf76c0559cce9a44704308c85d9c205b676af0ac6ba377a5da12d3244" + , "9af783973c632a490f03dbb4b4852b1e" + , "2e51c7a8ac70adc37fc7e40d59a8e5bf8dfd8f7b027c77e6ec648bd0c41a78de" + , "45718ac567fd2660b91c8f5f1f8f186c58c6284b6968eadc9810b7beeca148a1" + , "63a107246a2070739aa4bed6746439d8c2ce678a54fc887c5aba29c502da7ba9" + , "e4576291b1cde51c5044fdc5375624cebf63333c58c7457ca7490da037a9556e" + , "b5a3fbd57784b15fd875e0b0c5e59ec5f089829fac51620aa998fff003534d6f" + , "c624d26087ffb8f39836c067ba37217f1977c47172d5dcb7d40193a1cfe20158b774558cbee8eb6f9c62d629e1bcf70a1439e46c5709ba4c94a006ba94994796e10660d6cb1e150a243f7ba5d35c8572fd96f43c08490131797e86d3ed8467b692f92f668631b1d32862c3dc43bfba686fe72fdd947db2792463e920522eb4bc" + ], + -- COUNT = 2 + [ "b63fdd83c674699ba473faab9c358434771c5fa0348ca0faf7ebd7cf5891826b" + , "5fd204e2598d9626edab4158a8cfd95f" + , "2a5dfad8494306d9d4648a805c4602216a746ae3493492693a50a86d1ba05c64" + , "adea5ba92f8010bb1a6a4b6fae2caa0b384165adf721253afd635d6021f764af" + , "07c69d8d2b8aa1454c5c48083dd41477fda6bfcf0385638379933a60ed2e0a77" + , "a14e902247a3d6493d3fbc8519518b71a660e5502cf7ecfc796cfaa5b4ee4baa" + , "60e690e4a1eba14aec5187112a383e9991347fab7bac7cb2a40a52579a0d2718" + , "792b47b6ed221623bb187d63e3f039c6983d94efd5771dc9b4c40bee65924513485a6332baeda6a96f9bb431f592d73462b61d9d914a72b56fa9d87597426fb246424ebcd7abd51b2eefec8f5b839c0b3c34015342ace296b5f2218fa194b50aea1c89663460292c92c45f112ddbf6b9406f6e7ccee9c47ed2d90a27be5dd73e" + ], + -- COUNT = 3 + [ "dab85f98eaf0cfba013b97de4d9c264ca6fe120366cb83e8b3113c68b34e39d5" + , "d05108e1028ae67b4ea63bdc6d75eb88" + , "09fed3822f6f5e5b9e575d31dc215de1607b0dfc927412618c2d8f79166dbaba" + , "1794885a64470744198b7d0bc24472ffe8daf3c7eb219df6ddf180e484fe0aa5" + , "8d74d01b582f70b92f53b43468084e1586d9b36465d333d5faaf6911e62fe40e" + , "ef7f6b6eb479ab05b3f9ab6dd72eac8b1e86d887f1bcae363cae386d0275a06f" + , "7442b2a792a6a29559bb8a515d56916ee18200580aa02e1237dd358619382d8f" + , "49d2cbfa0897b7d961c293c1e572fb26f28e7b956e746f6eda90454c1370a29e25303ceadc7837514dc638553b487ef9487c977c10625409178ad6506d103c487a66655d08659d92a4d5994d1c8ddb28fe60f2e49577d6e80cae1478068c98268f45e6293c9326c7f726ec89601351c0a26fd3a6549f8a41c6f58692c86594c0" + ], + -- COUNT = 4 + [ "0f0aa84ef12e10ae2b279e799c683441862457b9bc25581c2cd3d5b58a5b3246" + , "f74f4230c2427a52f01f39e825d250ac" + , "d02b2f53da48b923c2921e0f75bd7e6139d7030aead5aeebe46c20b9ca47a38a" + , "5222b26e79f7c3b7066d581185b1a1f6376796f3d67f59d025dd2a7b1886d258" + , "d11512457bf3b92d1b1c0923989911f58f74e136b1436f00bad440dd1d6f1209" + , "54d9ea7d40b7255ef3d0ab16ea9fdf29b9a281920962b5c72d97b0e371b9d816" + , "601cef261da8864f1e30196c827143e4c363d3fa865b808e9450b13e251d47fa" + , "e9847cefea3b88062ea63f92dc9e96767ce9202a6e049c98dc1dcbc6d707687bd0e98ed2cc215780c454936292e44a7c6856d664581220b8c8ca1d413a2b81120380bfd0da5ff2bf737b602727709523745c2ced8daef6f47d1e93ef9bc141a135674cba23045e1f99aa78f8cead12eeffff20de2008878b1f806a2652db565a" + ], + -- COUNT = 5 + [ "6a868ce39a3adcd189bd704348ba732936628f083de8208640dbd42731447d4e" + , "efdde4e22b376e5e7385e79024350699" + , "f7285cd5647ff0e2c71a9b54b57f04392641a4bde4a4024fa11c859fecaad713" + , "0174f7f456ac06c1d789facc071701f8b60e9accebced73a634a6ad0e1a697d4" + , "5463bb2241d10c970b68c3abc356c0fe5ef87439fc6457c5ee94be0a3fb89834" + , "3ab62cdbc638c1b2b50533d28f31b1758c3b8435fe24bb6d4740005a73e54ce6" + , "2dbf4c9123e97177969139f5d06466c272f60d067fefadf326ccc47971115469" + , "8afce49dccc4ff64c65a83d8c0638bd8e3b7c13c52c3c59d110a8198753e96da512c7e03aeed30918706f3ad3b819e6571cfa87369c179fb9c9bbc88110baa490032a9d41f9931434e80c40ae0051400b7498810d769fb42dddbc7aa19bdf79603172efe9c0f5d1a65372b463a31178cbae581fa287f39c4fbf8434051b7419f" + ], + -- COUNT = 6 + [ "bb6b339eae26072487084ec9e4b53f2f1d4267d205042e74c77fb9ca0591ba50" + , "c0e7bf6eb07feccbc494af4098e59d30" + , "34aeec7ed0cae83701b6477709c8654a1114212401dc91cbe7de39d71f0c06e1" + , "f47fc60afbeb807236f7974d837335bc0b22288ef09ddfcb684e16b4c36a050b" + , "e8071ccd84ac4527e5c6e85b0709ed867776f25ae0e04180dcb7105ecd3e3490" + , "fbac45b5952200ad7c4232500f2417a1c14723bdd1cc078821bc2fe138b86597" + , "c4292d7dbef3ba7c18bf46bcf26776add22ab8ee206d6c722665dec6576b1bc0" + , "228aa2a314fcbfe63089ce953ac457093deaa39dd9ce2a4ece56a6028a476a98129be516d6979eff5587c032cdf4739d7ac712970f600fa781a8e542e399661183e34e4b90c59ec5dc5cad86f91083529d41c77b8f36c5a8e28ba1a548223a02eaed8426f6fe9f349ebec11bc743e767482e3472ec2799c1f530ebdc6c03bc4b" + ], + -- COUNT = 7 + [ "be658e56f80436039e2a9c0a62952dd7d70842244b5ab10f3b8a87d36104e629" + , "33c9627455dfde91865aee93e5071147" + , "d3a6eb29b180b791984deb056d72c0608a2c9044237aecf100ccb03700064c5e" + , "bef24dc9a5aa23003d3825f9b2b00e7dab571ea6ad86415dbd30c0bbdce7b972" + , "047c29e4d1584fa70cb66e2aa148a2aa29837c5eee64dcac60fdba356cdf90bb" + , "41c4792161b1b00d410cb79cd56bd311a714fb78dc3471c25bdd7479f2e9a952" + , "cd4936d7bc3ea0e7201bcbefbc908215a97680ca6ce8672360aea600b6564308" + , "2c25557f6db07db057f56ad5b6dc0427d1a0e825c48c19a526f9a65087c6d1ead7c78363a61616c84f1022653af65173a3f9ec3275f2b0a0d0bc750194673c0eaa6c623cd88abb0c8979baee4cd85bfce2e4a20bfebf2c3be61676563767dfe229e0b7be67ad6fcd116dd0b460708b1b0e5c3d60f3dd8138030404d197375d75" + ], + -- COUNT = 8 + [ "ae537f31a28ca14500e759716bc207983bfeab60b25079fa30b77b8d41244cb9" + , "fca9e27d8ab84cf9b9ce491ec5d8cb67" + , "8c9cb2b19aa3abe83c8fe7da96e9c11648252653a29dcd5bf0ac334ac587f032" + , "1eb52777be480f05115ae6370f30159a94d50ffcc64454678ab1d1ac6f166fa7" + , "9cdf6f1a2bc07acd4b0f43b5f2b892a1153e2669f237d257923636094fb40b54" + , "692d512722de6ba720fd23c8994ac63179b5f7e611addf9cfacd60e06e144a6a" + , "bbeea7b2bea821f339f494947c0b4bae8056119db69a3cbef21914953729cdef" + , "c0c4fb7080c0fbe425c1b756fb3a090cb0d08c7027d1bb82ed3b07613e2a757f83a78d42f9d8653954b489f800a5e058ebc4f5a1747526541d8448cb72e2232db20569dc96342c36672c4be625b363b4587f44557e58cedb4597cb57d006fda27e027818ae89e15b4c6382b9e7a4453290ea43163b4f9cae38b1023de6a47f7b" + ], + -- COUNT = 9 + [ "2f8994c949e08862db0204008f55d3561f3e0362df13b9d9a70fda39938f2d33" + , "1bf3e94ea858160b832fe85d301256f5" + , "b46671cf7fa142e7012ed261e1fe86714711c246c7d1c0330fa692141e86d5d1" + , "5ecdb1e8fe12260b9bfe12d6e6f161474fa2311e12e39b0beb0fcd92a6737b73" + , "3ce9a29f0207d079e6dc81fb830356e555f96a23ea71424972ea9308965786d3" + , "db950000c0776cc0e049929ce021020adc42d29cd9b5d8f7117fbe6bde3e594f" + , "fc18ee6dd3dac2306774f0ac36cd789e33462d72a8c75df9057123db33e5f7bc" + , "8546362cc8af9b78dd6e8eb2c37db96e70708852bfd9380abedc7f324575a167bea18f632f3e19d099cfbf310773f9719eec036d2e09f393a023add8ebdc4fb87af43b2fe6c7eaa4d39f8022ce247aa45fdc84d1b92cacce6eae8252a03ec2ec5330c01f56d113fd2ec3d0240af0afcf13ddde205bb5e7c2d912dcb4aee5dcf3" + ], + -- COUNT = 10 + [ "0c85e31487de1d7ba4a7b998ac56dc42c6dc0eae7bf5c8aaf1e4e78875f5fb47" + , "de878f728f73f83dc2a2f550b96c8b97" + , "9aac37bce1a6a81dc7934e23747991e3cf48c55ffe5a57781c41768a35220a01" + , "2d5ca8af1a70cfdccd015ee3bf0665dd1941fc6a7317b9d0d06658f5744cfbd9" + , "db881e6d0dc3b62793d7da5fe5a18e33be9b93f4a63a00a878dfbecf0d383bd2" + , "f743ce1b72f3de4c901369eed581c626ed3081ca707e6634fdaff46721ce0878" + , "cd52da3ec8a839c537dacdea8506a3eeee879de388ff5e513322d6d1bb3ff694" + , "a5bdd57cb8fde6298e7c5e563afcca60dd472eca484bd8c3cc17f3307be09b601744dd3ab9e8a44107c5868824575f850c0f399b280cf198006f83ede8c0b537e9be227fa140b65995ad9dfa1f2303d560c3b7f59bedd93c1282ea263924469411c2653f87fd814c74cb91c148430481d64bad0fec3cbb3dd1f39aa55c36f81b" + ], + -- COUNT = 11 + [ "93161b2dc08cb0fd50171141c865a841ca935cfdd2b5907d6ff8ab0348c4ceb0" + , "5cb9f6e5912b90c3349a50ab881b35a1" + , "0dceb4a36326c4df1685df43fddeecb5d0c76f00eb44826694f27e610290f6e1" + , "d8e9be44b5f293482548d4787762ebfb03c73c40e45385e8b98907cd66f493dd" + , "105a8f85d6959f3e043ef508cfea21d52123f03b7aea8034c4eec761eaba1fee" + , "bf781f7e489d9b4b5aa5ee6d1796468af672a8d25f311edf3c4b4dbf433d703f" + , "c81d6bcf1e5bf37e39dda1735c6f193df115b1a854a12e7cafe060afe4589335" + , "4306628124d0100fade7eaaf5edf227d50771f9e5f2e1e983800eef9a39fde0b0c280e63c8728d836b5b93ea794a32c1c04cfc54bd5300e3febb5fe2e1023eded8d7cd180279a598f76823e8d5a7dffcc93a09deec5d1f80838e938fba4de9f47e94b99382ae55f116df9c3b3ddf7e50516e203645852a415796f03a86418107" + ], + -- COUNT = 12 + [ "1ae12a5e4e9a4a5bfa79da30a9e6c62ffc639572ef1254194d129a16eb53c716" + , "5399b3481fdf24d373222267790a0fec" + , "8280cfdcd7a575816e0199e115da0ea77cae9d30b49c891a6c225e9037ba67e2" + , "681554ff702658122e91ba017450cfdfc8e3f4911153f7bcc428403e9c7b9d68" + , "226732b7a457cf0ac0ef09fd4f81296573b49a68de5e7ac3070e148c95e8e323" + , "45942b5e9a1a128e85e12c34596374ddc85fd7502e5633c7390fc6e6f1e5ef56" + , "6fc59929b41e77072886aff45f737b449b105ed7eacbd74c7cbfedf533dbeaa1" + , "b7547332e1509663fcfea2128f7f3a3df484cd8df034b00199157d35d61e35f1a9d481c7d2e81305616d70fc371ee459b0b2267d627e928590edcac3231898b24ef378aa9c3d381619f665379be76c7c1bd535505c563db3725f034786e35bdd90429305fd71d7bf680e8cdd6d4c348d97078f5cf5e89dee2dc410fad4f2a30f" + ], + -- COUNT = 13 + [ "29e20d724dfa459960df21c6ec76b1e6cabd23a9e9456d6c591d7e4529da0ef8" + , "95df1f837eba47a1687aa5c4ddcf8aaf" + , "3713b601e164b1a51dda1ca9242ff477514648e90d311a06e10ce5aa15da5d7f" + , "2a2a312626ca3e20034fc4f28033c7d573f66ef61ab2ea0c7bf0411a9d247264" + , "ec68be33ac8ff3dd127e051604898c0f9a501271859376653a0516336180993d" + , "9935499661d699a00c622a875441b4df5204958fe95892c8ce67f7dfb2be3e4a" + , "256a4ba9e8f439d5487fa5eb45efcf1bc1120491724db3abe328d951f2739fc9" + , "73114cb3624d687d4cd49a6e769dfc7a3f8901dc41f6ad1df4ce480536fa82e52ae958d0528640d92b8bb981b755058e32c4733682e5c4c0df41f3505a1643a0dd49cfdeaf7a18adffca88256c6d2cceb838af6c92a64bc21cb7a760a0391291bfe3575e014fc156323f8eb5e86518c669dad8d29ad5fd4ef6e296f4a0764c26" + ], + -- COUNT = 14 + [ "1353f3543eb1134980e061fc4382394975dbc74f1f1ea5ecc02780a813ac5ee6" + , "cf584db2447afbe2c8fa0c15575ee391" + , "345b0cc016f2765a8c33fc24f1dcfa182cbe29d7eacbcdc9bcda988521458fc2" + , "ba60219332a67b95d90ec9de6b8453d4c8af991ae9277461ff3af1b92fc985d3" + , "6964b9b9842aec9c7ec2aad926d701f30eec76fe699265ae2a7765d716958069" + , "6a03c28a9365c558c33d3fdc7e5ebf0b4d32caac70df71403fd70ced09757528" + , "a58546c72a0b4d47c9bd6c19e7cf4ab73b2d7ba36c6c6dc08606f608795ebd29" + , "5b029ef68b6799868b04dc28dbea26bc2fa9fcc8c2b2795aafeed0127b7297fa19a4ef2ba60c42ff8259d5a759f92bd90fdfb27145e82d798bb3ab7fd60bfaefb7aefb116ca2a4fa8b01d96a03c47c8d987fdd33c460e560b138891278313bb619d0c3c6f9d7c5a37e88fce83e94943705c6ff68e00484e74ad4097b0c9e5f10" + ] + ] diff --git a/test/Haskoin/Crypto/SignatureSpec.hs b/test/Haskoin/Crypto/SignatureSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Crypto/SignatureSpec.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE OverloadedStrings #-} +module Haskoin.Crypto.SignatureSpec (spec) where + +import Data.Bits (testBit) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS (index, length) +import Data.Serialize as S +import Data.Text (Text) +import Haskoin.Crypto (SecKey, Sig, decodeStrictSig, + derivePubKey, exportSig, + importCompactSig, isCanonicalHalfOrder, + sha256, signHash, verifyHashSig) +import Haskoin.Test (arbitrarySignature) +import Haskoin.Util (decodeHex, eitherToMaybe, lst3) +import Test.Hspec (Spec, describe, it) +import Test.Hspec.QuickCheck (prop) +import Test.HUnit (Assertion, assertBool) +import Test.QuickCheck (forAll) + +spec :: Spec +spec = do + describe "signatures" $ do + prop "verify signature" $ + forAll arbitrarySignature $ \(msg, key, sig) -> + verifyHashSig msg sig (derivePubKey key) + prop "s component less than half order" $ + forAll arbitrarySignature $ isCanonicalHalfOrder . lst3 + prop "encoded signature is canonical" $ + forAll arbitrarySignature $ testIsCanonical . lst3 + prop "encode signature and decode strictly" $ + forAll arbitrarySignature $ + (\s -> decodeStrictSig (exportSig s) == Just s) . lst3 + prop "encodes and decodes signature" $ + forAll arbitrarySignature $ + (\s -> decodeStrictSig (exportSig s) == Just s) . lst3 + describe "trezor rfc6979 test vectors" $ do + it "rfc6979 test vector 1" (testSigning $ head detVec) + it "rfc6979 test vector 2" (testSigning $ detVec !! 1) + it "rfc6979 test vector 3" (testSigning $ detVec !! 2) + it "rfc6979 test vector 4" (testSigning $ detVec !! 3) + it "rfc6979 test vector 5" (testSigning $ detVec !! 4) + it "rfc6979 test vector 6" (testSigning $ detVec !! 5) + it "rfc6979 test vector 7" (testSigning $ detVec !! 6) + it "rfc6979 test vector 8" (testSigning $ detVec !! 7) + it "rfc6979 test vector 9" (testSigning $ detVec !! 8) + it "rfc6979 test vector 10" (testSigning $ detVec !! 9) + it "rfc6979 test vector 11" (testSigning $ detVec !! 10) + it "rfc6979 test vector 12" (testSigning $ detVec !! 11) + +-- No longer validating that generated signature is exactly equal to provided +-- one. Fedora includes libsecp256k1 from Bitcoin ABC that computes +-- deterministic signatures using a slightly different nonce generation +-- algorithm. +testSigning :: (SecKey, ByteString, Text) -> Assertion +testSigning (prv, msg, str) = do + assertBool "my sig valid" $ verifyHashSig msg' g (derivePubKey prv) + assertBool "valid sig" $ verifyHashSig msg' g' (derivePubKey prv) + where + Just g' = importCompactSig =<< eitherToMaybe . decode =<< decodeHex str + g = signHash prv msg' + msg' = sha256 msg + + +{- ECDSA Canonical -} + +-- github.com/bitcoin/bitcoin/blob/master/src/script.cpp +-- from function IsCanonicalSignature +testIsCanonical :: Sig -> Bool +testIsCanonical sig = not $ + -- Non-canonical signature: too short + (len < 8) || + -- Non-canonical signature: too long + (len > 72) || + -- Non-canonical signature: wrong type + (BS.index s 0 /= 0x30) || + -- Non-canonical signature: wrong length marker + (BS.index s 1 /= len - 2) || + -- Non-canonical signature: S length misplaced + (5 + rlen >= len) || + -- Non-canonical signature: R+S length mismatch + (rlen + slen + 6 /= len) || + -- Non-canonical signature: R value type mismatch + (BS.index s 2 /= 0x02) || + -- Non-canonical signature: R length is zero + (rlen == 0) || + -- Non-canonical signature: R value negative + testBit (BS.index s 4) 7 || + -- Non-canonical signature: R value excessively padded + ( rlen > 1 + && BS.index s 4 == 0 + && not (testBit (BS.index s 5) 7) + ) || + -- Non-canonical signature: S value type mismatch + (BS.index s (fromIntegral rlen + 4) /= 0x02) || + -- Non-canonical signature: S length is zero + (slen == 0) || + -- Non-canonical signature: S value negative + testBit (BS.index s (fromIntegral rlen+6)) 7 || + -- Non-canonical signature: S value excessively padded + ( slen > 1 + && BS.index s (fromIntegral rlen + 6) == 0 + && not (testBit (BS.index s (fromIntegral rlen + 7)) 7) + ) + where + s = exportSig sig + len = fromIntegral $ BS.length s + rlen = BS.index s 3 + slen = BS.index s (fromIntegral rlen + 5) + + +{- Trezor RFC 6979 Test Vectors -} +-- github.com/trezor/python-ecdsa/blob/master/ecdsa/test_pyecdsa.py + +detVec :: [(SecKey, ByteString, Text)] +detVec = + [ + ( "0000000000000000000000000000000000000000000000000000000000000001" + , "Satoshi Nakamoto" + , "934b1ea10a4b3c1757e2b0c017d0b6143ce3c9a7e6a4a49860d7a6ab210ee3d82442ce9d2b916064108014783e923ec36b49743e2ffa1c4496f01a512aafd9e5" + ) + , ( "0000000000000000000000000000000000000000000000000000000000000001" + , "All those moments will be lost in time, like tears in rain. Time to die..." + , "8600dbd41e348fe5c9465ab92d23e3db8b98b873beecd930736488696438cb6b547fe64427496db33bf66019dacbf0039c04199abb0122918601db38a72cfc21" + ) + , ( "fffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364140" + , "Satoshi Nakamoto" + , "fd567d121db66e382991534ada77a6bd3106f0a1098c231e47993447cd6af2d06b39cd0eb1bc8603e159ef5c20a5c8ad685a45b06ce9bebed3f153d10d93bed5" + ) + , ( "f8b8af8ce3c7cca5e300d33939540c10d45ce001b8f252bfbc57ba0342904181" + , "Alan Turing" + , "7063ae83e7f62bbb171798131b4a0564b956930092b33b07b395615d9ec7e15c58dfcc1e00a35e1572f366ffe34ba0fc47db1e7189759b9fb233c5b05ab388ea" + ) + , ( "e91671c46231f833a6406ccbea0e3e392c76c167bac1cb013f6f1013980455c2" + , "There is a computer disease that anybody who works with computers knows about. It's a very serious disease and it interferes completely with the work. The trouble with computers is that you 'play' with them!" + , "b552edd27580141f3b2a5463048cb7cd3e047b97c9f98076c32dbdf85a68718b279fa72dd19bfae05577e06c7c0c1900c371fcd5893f7e1d56a37d30174671f6" + ) + , ( "0000000000000000000000000000000000000000000000000000000000000001" + , "Everything should be made as simple as possible, but not simpler." + , "33a69cd2065432a30f3d1ce4eb0d59b8ab58c74f27c41a7fdb5696ad4e6108c96f807982866f785d3f6418d24163ddae117b7db4d5fdf0071de069fa54342262" + ) + , ( "fffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364140" + , "Equations are more important to me, because politics is for the present, but an equation is something for eternity." + , "54c4a33c6423d689378f160a7ff8b61330444abb58fb470f96ea16d99d4a2fed07082304410efa6b2943111b6a4e0aaa7b7db55a07e9861d1fb3cb1f421044a5" + ) + , ( "fffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364140" + , "Not only is the Universe stranger than we think, it is stranger than we can think." + , "ff466a9f1b7b273e2f4c3ffe032eb2e814121ed18ef84665d0f515360dab3dd06fc95f5132e5ecfdc8e5e6e616cc77151455d46ed48f5589b7db7771a332b283" + ) + , ( "0000000000000000000000000000000000000000000000000000000000000001" + , "How wonderful that we have met with a paradox. Now we have some hope of making progress." + , "c0dafec8251f1d5010289d210232220b03202cba34ec11fec58b3e93a85b91d375afdc06b7d6322a590955bf264e7aaa155847f614d80078a90292fe205064d3" + ) + , ( "69ec59eaa1f4f2e36b639716b7c30ca86d9a5375c7b38d8918bd9c0ebc80ba64" + , "Computer science is no more about computers than astronomy is about telescopes." + , "7186363571d65e084e7f02b0b77c3ec44fb1b257dee26274c38c928986fea45d0de0b38e06807e46bda1f1e293f4f6323e854c86d58abdd00c46c16441085df6" + ) + , ( "00000000000000000000000000007246174ab1e92e9149c6e446fe194d072637" + , "...if you aren't, at any given time, scandalized by code you wrote five or even three years ago, you're not learning anywhere near enough" + , "fbfe5076a15860ba8ed00e75e9bd22e05d230f02a936b653eb55b61c99dda4870e68880ebb0050fe4312b1b1eb0899e1b82da89baa5b895f612619edf34cbd37" + ) + , ( "000000000000000000000000000000000000000000056916d0f9b31dc9b637f3" + , "The question of whether computers can think is like the question of whether submarines can swim." + , "cde1302d83f8dd835d89aef803c74a119f561fbaef3eb9129e45f30de86abbf906ce643f5049ee1f27890467b77a6a8e11ec4661cc38cd8badf90115fbd03cef" + ) + ] diff --git a/test/Haskoin/CryptoSpec.hs b/test/Haskoin/CryptoSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/CryptoSpec.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE OverloadedStrings #-} +module Haskoin.CryptoSpec (spec) where + +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as C (pack) +import Data.Maybe (fromMaybe, isJust, isNothing) +import Data.Text (Text) +import Haskoin.Address +import Haskoin.Constants +import Haskoin.Crypto +import Haskoin.Keys +import Haskoin.Util +import Test.Hspec +import Test.HUnit (Assertion, assertBool) + +-- Unit tests copied from bitcoind implementation +-- https://github.com/bitcoin/bitcoin/blob/master/src/test/key_tests.cpp + +strSecret1 :: Text +strSecret1 = "5HxWvvfubhXpYYpS3tJkw6fq9jE9j18THftkZjHHfmFiWtmAbrj" + +strSecret2 :: Text +strSecret2 = "5KC4ejrDjv152FGwP386VD1i2NYc5KkfSMyv1nGy1VGDxGHqVY3" + +strSecret1C :: Text +strSecret1C = "Kwr371tjA9u2rFSMZjTNun2PXXP3WPZu2afRHTcta6KxEUdm1vEw" + +strSecret2C :: Text +strSecret2C = "L3Hq7a8FEQwJkW1M2GNKDW28546Vp5miewcCzSqUD9kCAXrJdS3g" + +addr1 :: Text +addr1 = "1QFqqMUD55ZV3PJEJZtaKCsQmjLT6JkjvJ" + +addr2 :: Text +addr2 = "1F5y5E5FMc5YzdJtB9hLaUe43GDxEKXENJ" + +addr1C :: Text +addr1C = "1NoJrossxPBKfCHuJXT4HadJrXRE9Fxiqs" + +addr2C :: Text +addr2C = "1CRj2HyM1CXWzHAXLQtiGLyggNT9WQqsDs" + +strAddressBad :: Text +strAddressBad = "1HV9Lc3sNHZxwj4Zk6fB38tEmBryq2cBiF" + +sigMsg :: [ByteString] +sigMsg = + [ mconcat ["Very secret message ", C.pack (show (i :: Int)), ": 11"] + | i <- [0..15] + ] + +sec1 :: SecKeyI +sec1 = + fromMaybe (error "Could not decode WIF secret 1") (fromWif btc strSecret1) + +sec2 :: SecKeyI +sec2 = + fromMaybe (error "Could not decode WIF secret 2") (fromWif btc strSecret2) + +sec1C :: SecKeyI +sec1C = + fromMaybe + (error "Could not decode WIF compressed secret 1") + (fromWif btc strSecret1C) + +sec2C :: SecKeyI +sec2C = + fromMaybe + (error "Could not decode WIF compressed secret 2") + (fromWif btc strSecret2C) + +pub1 :: PubKeyI +pub1 = derivePubKeyI sec1 + +pub2 :: PubKeyI +pub2 = derivePubKeyI sec2 + +pub1C :: PubKeyI +pub1C = derivePubKeyI sec1C + +pub2C :: PubKeyI +pub2C = derivePubKeyI sec2C + +spec :: Spec +spec = + describe "bitcoind /src/test/key_tests.cpp" $ do + it "decode valid wif" checkPrivkey + it "decode invalid wif" checkInvalidKey + it "decode minikey format" checkMiniKey + it "check private key compression" checkPrvKeyCompressed + it "check public key compression" checkKeyCompressed + it "check matching address" checkMatchingAddress + it "check various signatures" sigCheck + +sigCheck :: Assertion +sigCheck = forM_ sigMsg $ checkSignatures . doubleSHA256 + +{- bitcoind /src/test/key_tests.cpp -} + +checkPrivkey :: Assertion +checkPrivkey = do + assertBool "Key 1" $ isJust $ fromWif btc strSecret1 + assertBool "Key 2" $ isJust $ fromWif btc strSecret2 + assertBool "Key 1C" $ isJust $ fromWif btc strSecret1C + assertBool "Key 2C" $ isJust $ fromWif btc strSecret2C + +checkInvalidKey :: Assertion +checkInvalidKey = + assertBool "Bad key" $ isNothing $ fromWif btc strAddressBad + +checkMiniKey :: Assertion +checkMiniKey = + assertBool "Bad mini key" $ + isJust res && fromMiniKey "S6c56bnXQiBjk9mqSYE7ykVQ7NzrRy" == res + where + res = do + bs <- + decodeHex + "4C7A9640C72DC2099F23715D0C8A0D8A35F8906E3CAB61DD3F78B67BF887C9AB" + wrapSecKey False <$> secKey bs + +checkPrvKeyCompressed :: Assertion +checkPrvKeyCompressed = do + assertBool "Key 1" $ not $ secKeyCompressed sec1 + assertBool "Key 2" $ not $ secKeyCompressed sec2 + assertBool "Key 1C" $ secKeyCompressed sec1C + assertBool "Key 2C" $ secKeyCompressed sec2C + +checkKeyCompressed :: Assertion +checkKeyCompressed = do + assertBool "Key 1" $ not $ pubKeyCompressed pub1 + assertBool "Key 2" $ not $ pubKeyCompressed pub2 + assertBool "Key 1C" $ pubKeyCompressed pub1C + assertBool "Key 2C" $ pubKeyCompressed pub2C + +checkMatchingAddress :: Assertion +checkMatchingAddress = do + assertBool "Key 1" $ Just addr1 == addrToString btc (pubKeyAddr pub1) + assertBool "Key 2" $ Just addr2 == addrToString btc (pubKeyAddr pub2) + assertBool "Key 1C" $ Just addr1C == addrToString btc (pubKeyAddr pub1C) + assertBool "Key 2C" $ Just addr2C == addrToString btc (pubKeyAddr pub2C) + +checkSignatures :: Hash256 -> Assertion +checkSignatures h = do + let sign1 = signHash (secKeyData sec1) h + sign2 = signHash (secKeyData sec2) h + sign1C = signHash (secKeyData sec1C) h + sign2C = signHash (secKeyData sec2C) h + assertBool "Key 1, Sign1" $ verifyHashSig h sign1 (pubKeyPoint pub1) + assertBool "Key 1, Sign2" $ not $ verifyHashSig h sign2 (pubKeyPoint pub1) + assertBool "Key 1, Sign1C" $ verifyHashSig h sign1C (pubKeyPoint pub1) + assertBool "Key 1, Sign2C" $ not $ verifyHashSig h sign2C (pubKeyPoint pub1) + assertBool "Key 2, Sign1" $ not $ verifyHashSig h sign1 (pubKeyPoint pub2) + assertBool "Key 2, Sign2" $ verifyHashSig h sign2 (pubKeyPoint pub2) + assertBool "Key 2, Sign1C" $ not $ verifyHashSig h sign1C (pubKeyPoint pub2) + assertBool "Key 2, Sign2C" $ verifyHashSig h sign2C (pubKeyPoint pub2) + assertBool "Key 1C, Sign1" $ verifyHashSig h sign1 (pubKeyPoint pub1C) + assertBool "Key 1C, Sign2" $ not $ verifyHashSig h sign2 (pubKeyPoint pub1C) + assertBool "Key 1C, Sign1C" $ verifyHashSig h sign1C (pubKeyPoint pub1C) + assertBool "Key 1C, Sign2C" $ not $ verifyHashSig h sign2C (pubKeyPoint pub1C) + assertBool "Key 2C, Sign1" $ not $ verifyHashSig h sign1 (pubKeyPoint pub2C) + assertBool "Key 2C, Sign2" $ verifyHashSig h sign2 (pubKeyPoint pub2C) + assertBool "Key 2C, Sign1C" $ not $ verifyHashSig h sign1C (pubKeyPoint pub2C) + assertBool "Key 2C, Sign2C" $ verifyHashSig h sign2C (pubKeyPoint pub2C) diff --git a/test/Haskoin/Keys/ExtendedSpec.hs b/test/Haskoin/Keys/ExtendedSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Keys/ExtendedSpec.hs @@ -0,0 +1,521 @@ +{-# LANGUAGE OverloadedStrings #-} +module Haskoin.Keys.ExtendedSpec (spec) where + +import Data.Aeson as A +import Data.Aeson.Types as A +import Data.Bits ((.&.)) +import qualified Data.ByteString.Lazy.Char8 as B8 +import Data.Either (isLeft) +import Data.Map.Strict (singleton) +import Data.Maybe (fromJust, isJust, isNothing) +import Data.Serialize as S +import Data.String (fromString) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Word (Word32) +import Haskoin.Address +import Haskoin.Constants +import Haskoin.Keys +import Haskoin.Test +import Haskoin.Util +import Test.Hspec +import Test.HUnit (Assertion, assertBool, assertEqual) +import Test.QuickCheck hiding ((.&.)) + +spec :: Spec +spec = do + describe "bip32 derivation vector 1" $ do + it "chain m" $ runXKeyVec (head xKeyVec) + it "chain m/0'" $ runXKeyVec (xKeyVec !! 1) + it "chain m/0'/1" $ runXKeyVec (xKeyVec !! 2) + it "chain m/0'/1/2'" $ runXKeyVec (xKeyVec !! 3) + it "chain m/0'/1/2'/2" $ runXKeyVec (xKeyVec !! 4) + it "chain m/0'/1/2'/2/1000000000" $ runXKeyVec (xKeyVec !! 5) + describe "bip32 subkey derivation vector 2" $ do + it "chain m" $ runXKeyVec (head xKeyVec2) + it "chain m/0" $ runXKeyVec (xKeyVec2 !! 1) + it "chain m/0/2147483647'" $ runXKeyVec (xKeyVec2 !! 2) + it "chain m/0/2147483647'/1" $ runXKeyVec (xKeyVec2 !! 3) + it "chain m/0/2147483647'/1/2147483646'" $ runXKeyVec (xKeyVec2 !! 4) + it "Chain m/0/2147483647'/1/2147483646'/2" $ runXKeyVec (xKeyVec2 !! 5) + describe "bip32 subkey derivation using string path" $ do + it "either derivations" testApplyPath + it "either derivations" testBadApplyPath + it "dublic derivations" testDerivePubPath + it "private derivations" testDerivePrvPath + it "path parsing" testParsePath + it "from json" testFromJsonPath + it "to json" testToJsonPath + describe "extended keys" $ do + let net = btc + it "computes pubkey of a subkey is subkey of the pubkey" $ + property $ forAll arbitraryXPrvKey pubKeyOfSubKeyIsSubKeyOfPubKey + it "exports and imports extended private key" $ + property $ + forAll arbitraryXPrvKey $ \k -> + xPrvImport net (xPrvExport net k) == Just k + it "exports and imports extended public key" $ + property $ + forAll arbitraryXPubKey $ \(_, k) -> + xPubImport net (xPubExport net k) == Just k + it "show and read derivation path" $ + property $ forAll arbitraryDerivPath $ \p -> read (show p) == p + it "show and read hard derivation path" $ + property $ forAll arbitraryHardPath $ \p -> read (show p) == p + it "show and read soft derivation path" $ + property $ forAll arbitrarySoftPath $ \p -> read (show p) == p + it "from string derivation path" $ + property $ + forAll arbitraryDerivPath $ \p -> fromString (cs $ pathToStr p) == p + it "from string hard derivation path" $ + property $ + forAll arbitraryHardPath $ \p -> fromString (cs $ pathToStr p) == p + it "from string soft derivation path" $ + property $ + forAll arbitrarySoftPath $ \p -> fromString (cs $ pathToStr p) == p + it "from and to lists of derivation paths" $ + property $ + forAll arbitraryDerivPath $ \p -> listToPath (pathToList p) == p + it "from and to lists of hard derivation paths" $ + property $ + forAll arbitraryHardPath $ \p -> + toHard (listToPath $ pathToList p) == Just p + it "from and to lists of soft derivation paths" $ + property $ + forAll arbitrarySoftPath $ \p -> + toSoft (listToPath $ pathToList p) == Just p + it "read and show parsed path" $ + property $ forAll arbitraryParsedPath $ \p -> read (show p) == p + it "encodes and decodes extended private key" $ + forAll + arbitraryXPrvKey + (testCustom (xPrvFromJSON net) (xPrvToJSON net)) + it "encodes and decodes extended public key" $ + forAll + arbitraryXPubKey + (testCustom (xPubFromJSON net) (xPubToJSON net) . snd) + it "encodes and decodes derivation path" $ + forAll arbitraryDerivPath testID + it "encodes and decodes parsed derivation path" $ + forAll arbitraryParsedPath testID + it "encodes and decodes extended private key" $ + property $ + forAll arbitraryXPrvKey $ + testPutGet (getXPrvKey net) (putXPrvKey net) + it "shows and reads extended private key" $ + property $ + forAll arbitraryXPrvKey $ \k -> read (show k) `shouldBe` k + it "shows and reads extended private key" $ + property $ + forAll arbitraryXPubKey $ \(prv, pub) -> + read (show (prv, pub)) `shouldBe` (prv, pub) + +testFromJsonPath :: Assertion +testFromJsonPath = + sequence_ $ do + path <- jsonPathVectors + return $ + assertEqual + path + (Just [fromString path :: DerivPath]) + (A.decode $ B8.pack $ "[\"" ++ path ++ "\"]") + +testToJsonPath :: Assertion +testToJsonPath = + sequence_ $ do + path <- jsonPathVectors + return $ + assertEqual + path + (B8.pack $ "[\"" ++ path ++ "\"]") + (A.encode [fromString path :: ParsedPath]) + +jsonPathVectors :: [String] +jsonPathVectors = + [ "m" + , "m/0" + , "m/0'" + , "M/0'" + , "m/2147483647" + , "M/2147483647" + , "m/1/2/3/4/5/6/7/8" + , "M/1/2/3/4/5/6/7/8" + , "m/1'/2'/3/4" + , "M/1'/2'/3/4" + ] + +testParsePath :: Assertion +testParsePath = + sequence_ $ do + (path, t) <- parsePathVectors + return $ assertBool path (t $ parsePath path) + +parsePathVectors :: [(String, Maybe ParsedPath -> Bool)] +parsePathVectors = + [ ("m", isJust) + , ("m/0'", isJust) + , ("M/0'", isJust) + , ("m/2147483648", isNothing) + , ("m/2147483647", isJust) + , ("M/2147483648", isNothing) + , ("M/2147483647", isJust) + , ("M/-1", isNothing) + , ("M/-2147483648", isNothing) + , ("m/1/2/3/4/5/6/7/8", isJust) + , ("M/1/2/3/4/5/6/7/8", isJust) + , ("m/1'/2'/3/4", isJust) + , ("M/1'/2'/3/4", isJust) + , ("m/1/2'/3/4'", isJust) + , ("M/1/2'/3/4'", isJust) + , ("meh", isNothing) + , ("infinity", isNothing) + , ("NaN", isNothing) + ] + +testApplyPath :: Assertion +testApplyPath = + sequence_ $ do + (key, path, final) <- applyPathVectors + return $ + assertEqual path final $ applyPath (fromJust $ parsePath path) key + +testBadApplyPath :: Assertion +testBadApplyPath = + sequence_ $ do + (key, path) <- badApplyPathVectors + return $ + assertBool path $ isLeft $ applyPath (fromJust $ parsePath path) key + +testDerivePubPath :: Assertion +testDerivePubPath = + sequence_ $ do + (key, path, final) <- derivePubPathVectors + return $ + assertEqual path final $ + derivePubPath (fromString path :: SoftPath) key + +testDerivePrvPath :: Assertion +testDerivePrvPath = + sequence_ $ do + (key, path, final) <- derivePrvPathVectors + return $ + assertEqual path final $ + derivePath (fromString path :: DerivPath) key + +derivePubPathVectors :: [(XPubKey, String, XPubKey)] +derivePubPathVectors = + [ ( xpub, "M", xpub ) + , ( xpub, "M/8", pubSubKey xpub 8 ) + , ( xpub, "M/8/30/1", foldl pubSubKey xpub [8,30,1] ) + ] + where + xprv = fromJust $ xPrvImport btc + "xprv9s21ZrQH143K46iDVRSyFfGfMgQjzC4BV3ZUfNbG7PHQrJjE53ofAn5gYkp6KQ\ + \WzGmb8oageSRxBY8s4rjr9VXPVp2HQDbwPt4H31Gg4LpB" + xpub = deriveXPubKey xprv + +derivePrvPathVectors :: [(XPrvKey, String, XPrvKey)] +derivePrvPathVectors = + [ ( xprv, "m", xprv ) + , ( xprv, "M", xprv ) + , ( xprv, "m/8'", hardSubKey xprv 8 ) + , ( xprv, "M/8'", hardSubKey xprv 8 ) + , ( xprv, "m/8'/30/1" + , foldl prvSubKey (hardSubKey xprv 8) [30,1] + ) + , ( xprv, "M/8'/30/1" + , foldl prvSubKey (hardSubKey xprv 8) [30,1] + ) + , ( xprv, "m/3/20" + , foldl prvSubKey xprv [3,20] + ) + , ( xprv, "M/3/20" + , foldl prvSubKey xprv [3,20] + ) + ] + where + xprv = fromJust $ xPrvImport btc + "xprv9s21ZrQH143K46iDVRSyFfGfMgQjzC4BV3ZUfNbG7PHQrJjE53ofAn5gYkp6KQ\ + \WzGmb8oageSRxBY8s4rjr9VXPVp2HQDbwPt4H31Gg4LpB" + +applyPathVectors :: [(XKey, String, Either String XKey)] +applyPathVectors = + [ (XPrv xprv btc, "m", Right (XPrv xprv btc)) + , (XPrv xprv btc, "M", Right (XPub xpub btc)) + , (XPrv xprv btc, "m/8'", Right (XPrv (hardSubKey xprv 8) btc)) + , ( XPrv xprv btc + , "M/8'" + , Right (XPub (deriveXPubKey (hardSubKey xprv 8)) btc)) + , ( XPrv xprv btc + , "m/8'/30/1" + , Right (XPrv (foldl prvSubKey (hardSubKey xprv 8) [30, 1]) btc)) + , ( XPrv xprv btc + , "M/8'/30/1" + , Right + (XPub + (deriveXPubKey (foldl prvSubKey (hardSubKey xprv 8) [30, 1])) + btc)) + , (XPrv xprv btc, "m/3/20", Right (XPrv (foldl prvSubKey xprv [3, 20]) btc)) + , ( XPrv xprv btc + , "M/3/20" + , Right (XPub (deriveXPubKey (foldl prvSubKey xprv [3, 20])) btc)) + , ( XPub xpub btc + , "M/3/20" + , Right (XPub (deriveXPubKey (foldl prvSubKey xprv [3, 20])) btc)) + ] + where + xprv = + fromJust $ + xPrvImport + btc + "xprv9s21ZrQH143K46iDVRSyFfGfMgQjzC4BV3ZUfNbG7PHQrJjE53ofAn5gYkp6KQ\ + \WzGmb8oageSRxBY8s4rjr9VXPVp2HQDbwPt4H31Gg4LpB" + xpub = deriveXPubKey xprv + +badApplyPathVectors :: [(XKey, String)] +badApplyPathVectors = + [ (XPub xpub btc, "m/8'") + , (XPub xpub btc, "M/8'") + , (XPub xpub btc, "M/1/2/3'/4/5") + ] + where + xprv = + fromJust $ + xPrvImport + btc + "xprv9s21ZrQH143K46iDVRSyFfGfMgQjzC4BV3ZUfNbG7PHQrJjE53ofAn5gYkp6KQ\ + \WzGmb8oageSRxBY8s4rjr9VXPVp2HQDbwPt4H31Gg4LpB" + xpub = deriveXPubKey xprv + + +runXKeyVec :: ([Text], XPrvKey) -> Assertion +runXKeyVec (v, m) = do + assertBool "xPrvID" $ encodeHex (S.encode $ xPrvID m) == head v + assertBool "xPrvFP" $ encodeHex (S.encode $ xPrvFP m) == v !! 1 + assertBool "xPrvAddr" $ + addrToString btc (xPubAddr $ deriveXPubKey m) == Just (v !! 2) + assertBool "prvKey" $ encodeHex (getSecKey $ xPrvKey m) == v !! 3 + assertBool "xPrvWIF" $ xPrvWif btc m == v !! 4 + assertBool "pubKey" $ + encodeHex (exportPubKey True $ xPubKey $ deriveXPubKey m) == v !! 5 + assertBool "chain code" $ encodeHex (S.encode $ xPrvChain m) == v !! 6 + assertBool "Hex PubKey" $ + encodeHex (runPut $ putXPubKey btc $ deriveXPubKey m) == v !! 7 + assertBool "Hex PrvKey" $ encodeHex (runPut (putXPrvKey btc m)) == v !! 8 + assertBool "Base58 PubKey" $ xPubExport btc (deriveXPubKey m) == v !! 9 + assertBool "Base58 PrvKey" $ xPrvExport btc m == v !! 10 + +-- BIP 0032 Test Vectors +-- https://en.bitcoin.it/wiki/BIP_0032_TestVectors + +xKeyVec :: [([Text], XPrvKey)] +xKeyVec = zip xKeyResVec $ foldl f [m] der + where f acc d = acc ++ [d $ last acc] + m = makeXPrvKey $ fromJust $ decodeHex m0 + der = [ flip hardSubKey 0 + , flip prvSubKey 1 + , flip hardSubKey 2 + , flip prvSubKey 2 + , flip prvSubKey 1000000000 + ] + +xKeyVec2 :: [([Text], XPrvKey)] +xKeyVec2 = zip xKeyResVec2 $ foldl f [m] der + where f acc d = acc ++ [d $ last acc] + m = makeXPrvKey $ fromJust $ decodeHex m1 + der = [ flip prvSubKey 0 + , flip hardSubKey 2147483647 + , flip prvSubKey 1 + , flip hardSubKey 2147483646 + , flip prvSubKey 2 + ] + +m0 :: Text +m0 = "000102030405060708090a0b0c0d0e0f" + +xKeyResVec :: [[Text]] +xKeyResVec = + [ + -- m + [ "3442193e1bb70916e914552172cd4e2dbc9df811" + , "3442193e" + , "15mKKb2eos1hWa6tisdPwwDC1a5J1y9nma" + , "e8f32e723decf4051aefac8e2c93c9c5b214313817cdb01a1494b917c8436b35" + , "L52XzL2cMkHxqxBXRyEpnPQZGUs3uKiL3R11XbAdHigRzDozKZeW" + , "0339a36013301597daef41fbe593a02cc513d0b55527ec2df1050e2e8ff49c85c2" + , "873dff81c02f525623fd1fe5167eac3a55a049de3d314bb42ee227ffed37d508" + , "0488b21e000000000000000000873dff81c02f525623fd1fe5167eac3a55a049de3d314bb42ee227ffed37d5080339a36013301597daef41fbe593a02cc513d0b55527ec2df1050e2e8ff49c85c2" + , "0488ade4000000000000000000873dff81c02f525623fd1fe5167eac3a55a049de3d314bb42ee227ffed37d50800e8f32e723decf4051aefac8e2c93c9c5b214313817cdb01a1494b917c8436b35" + , "xpub661MyMwAqRbcFtXgS5sYJABqqG9YLmC4Q1Rdap9gSE8NqtwybGhePY2gZ29ESFjqJoCu1Rupje8YtGqsefD265TMg7usUDFdp6W1EGMcet8" + , "xprv9s21ZrQH143K3QTDL4LXw2F7HEK3wJUD2nW2nRk4stbPy6cq3jPPqjiChkVvvNKmPGJxWUtg6LnF5kejMRNNU3TGtRBeJgk33yuGBxrMPHi" + ] + -- m/0' + , [ "5c1bd648ed23aa5fd50ba52b2457c11e9e80a6a7" + , "5c1bd648" + , "19Q2WoS5hSS6T8GjhK8KZLMgmWaq4neXrh" + , "edb2e14f9ee77d26dd93b4ecede8d16ed408ce149b6cd80b0715a2d911a0afea" + , "L5BmPijJjrKbiUfG4zbiFKNqkvuJ8usooJmzuD7Z8dkRoTThYnAT" + , "035a784662a4a20a65bf6aab9ae98a6c068a81c52e4b032c0fb5400c706cfccc56" + , "47fdacbd0f1097043b78c63c20c34ef4ed9a111d980047ad16282c7ae6236141" + , "0488b21e013442193e8000000047fdacbd0f1097043b78c63c20c34ef4ed9a111d980047ad16282c7ae6236141035a784662a4a20a65bf6aab9ae98a6c068a81c52e4b032c0fb5400c706cfccc56" + , "0488ade4013442193e8000000047fdacbd0f1097043b78c63c20c34ef4ed9a111d980047ad16282c7ae623614100edb2e14f9ee77d26dd93b4ecede8d16ed408ce149b6cd80b0715a2d911a0afea" + , "xpub68Gmy5EdvgibQVfPdqkBBCHxA5htiqg55crXYuXoQRKfDBFA1WEjWgP6LHhwBZeNK1VTsfTFUHCdrfp1bgwQ9xv5ski8PX9rL2dZXvgGDnw" + , "xprv9uHRZZhk6KAJC1avXpDAp4MDc3sQKNxDiPvvkX8Br5ngLNv1TxvUxt4cV1rGL5hj6KCesnDYUhd7oWgT11eZG7XnxHrnYeSvkzY7d2bhkJ7" + ] + -- m/0'/1 + , [ "bef5a2f9a56a94aab12459f72ad9cf8cf19c7bbe" + , "bef5a2f9" + , "1JQheacLPdM5ySCkrZkV66G2ApAXe1mqLj" + , "3c6cb8d0f6a264c91ea8b5030fadaa8e538b020f0a387421a12de9319dc93368" + , "KyFAjQ5rgrKvhXvNMtFB5PCSKUYD1yyPEe3xr3T34TZSUHycXtMM" + , "03501e454bf00751f24b1b489aa925215d66af2234e3891c3b21a52bedb3cd711c" + , "2a7857631386ba23dacac34180dd1983734e444fdbf774041578e9b6adb37c19" + , "0488b21e025c1bd648000000012a7857631386ba23dacac34180dd1983734e444fdbf774041578e9b6adb37c1903501e454bf00751f24b1b489aa925215d66af2234e3891c3b21a52bedb3cd711c" + , "0488ade4025c1bd648000000012a7857631386ba23dacac34180dd1983734e444fdbf774041578e9b6adb37c19003c6cb8d0f6a264c91ea8b5030fadaa8e538b020f0a387421a12de9319dc93368" + , "xpub6ASuArnXKPbfEwhqN6e3mwBcDTgzisQN1wXN9BJcM47sSikHjJf3UFHKkNAWbWMiGj7Wf5uMash7SyYq527Hqck2AxYysAA7xmALppuCkwQ" + , "xprv9wTYmMFdV23N2TdNG573QoEsfRrWKQgWeibmLntzniatZvR9BmLnvSxqu53Kw1UmYPxLgboyZQaXwTCg8MSY3H2EU4pWcQDnRnrVA1xe8fs" + ] + -- m/0'/1/2' + , [ "ee7ab90cde56a8c0e2bb086ac49748b8db9dce72" + , "ee7ab90c" + , "1NjxqbA9aZWnh17q1UW3rB4EPu79wDXj7x" + , "cbce0d719ecf7431d88e6a89fa1483e02e35092af60c042b1df2ff59fa424dca" + , "L43t3od1Gh7Lj55Bzjj1xDAgJDcL7YFo2nEcNaMGiyRZS1CidBVU" + , "0357bfe1e341d01c69fe5654309956cbea516822fba8a601743a012a7896ee8dc2" + , "04466b9cc8e161e966409ca52986c584f07e9dc81f735db683c3ff6ec7b1503f" + , "0488b21e03bef5a2f98000000204466b9cc8e161e966409ca52986c584f07e9dc81f735db683c3ff6ec7b1503f0357bfe1e341d01c69fe5654309956cbea516822fba8a601743a012a7896ee8dc2" + , "0488ade403bef5a2f98000000204466b9cc8e161e966409ca52986c584f07e9dc81f735db683c3ff6ec7b1503f00cbce0d719ecf7431d88e6a89fa1483e02e35092af60c042b1df2ff59fa424dca" + , "xpub6D4BDPcP2GT577Vvch3R8wDkScZWzQzMMUm3PWbmWvVJrZwQY4VUNgqFJPMM3No2dFDFGTsxxpG5uJh7n7epu4trkrX7x7DogT5Uv6fcLW5" + , "xprv9z4pot5VBttmtdRTWfWQmoH1taj2axGVzFqSb8C9xaxKymcFzXBDptWmT7FwuEzG3ryjH4ktypQSAewRiNMjANTtpgP4mLTj34bhnZX7UiM" + ] + -- m/0'/1/2'/2 + , [ "d880d7d893848509a62d8fb74e32148dac68412f" + , "d880d7d8" + , "1LjmJcdPnDHhNTUgrWyhLGnRDKxQjoxAgt" + , "0f479245fb19a38a1954c5c7c0ebab2f9bdfd96a17563ef28a6a4b1a2a764ef4" + , "KwjQsVuMjbCP2Zmr3VaFaStav7NvevwjvvkqrWd5Qmh1XVnCteBR" + , "02e8445082a72f29b75ca48748a914df60622a609cacfce8ed0e35804560741d29" + , "cfb71883f01676f587d023cc53a35bc7f88f724b1f8c2892ac1275ac822a3edd" + , "0488b21e04ee7ab90c00000002cfb71883f01676f587d023cc53a35bc7f88f724b1f8c2892ac1275ac822a3edd02e8445082a72f29b75ca48748a914df60622a609cacfce8ed0e35804560741d29" + , "0488ade404ee7ab90c00000002cfb71883f01676f587d023cc53a35bc7f88f724b1f8c2892ac1275ac822a3edd000f479245fb19a38a1954c5c7c0ebab2f9bdfd96a17563ef28a6a4b1a2a764ef4" + , "xpub6FHa3pjLCk84BayeJxFW2SP4XRrFd1JYnxeLeU8EqN3vDfZmbqBqaGJAyiLjTAwm6ZLRQUMv1ZACTj37sR62cfN7fe5JnJ7dh8zL4fiyLHV" + , "xprvA2JDeKCSNNZky6uBCviVfJSKyQ1mDYahRjijr5idH2WwLsEd4Hsb2Tyh8RfQMuPh7f7RtyzTtdrbdqqsunu5Mm3wDvUAKRHSC34sJ7in334" + ] + -- m/0'/1/2'/2/1000000000 + , [ "d69aa102255fed74378278c7812701ea641fdf32" + , "d69aa102" + , "1LZiqrop2HGR4qrH1ULZPyBpU6AUP49Uam" + , "471b76e389e528d6de6d816857e012c5455051cad6660850e58372a6c3e6e7c8" + , "Kybw8izYevo5xMh1TK7aUr7jHFCxXS1zv8p3oqFz3o2zFbhRXHYs" + , "022a471424da5e657499d1ff51cb43c47481a03b1e77f951fe64cec9f5a48f7011" + , "c783e67b921d2beb8f6b389cc646d7263b4145701dadd2161548a8b078e65e9e" + , "0488b21e05d880d7d83b9aca00c783e67b921d2beb8f6b389cc646d7263b4145701dadd2161548a8b078e65e9e022a471424da5e657499d1ff51cb43c47481a03b1e77f951fe64cec9f5a48f7011" + , "0488ade405d880d7d83b9aca00c783e67b921d2beb8f6b389cc646d7263b4145701dadd2161548a8b078e65e9e00471b76e389e528d6de6d816857e012c5455051cad6660850e58372a6c3e6e7c8" + , "xpub6H1LXWLaKsWFhvm6RVpEL9P4KfRZSW7abD2ttkWP3SSQvnyA8FSVqNTEcYFgJS2UaFcxupHiYkro49S8yGasTvXEYBVPamhGW6cFJodrTHy" + , "xprvA41z7zogVVwxVSgdKUHDy1SKmdb533PjDz7J6N6mV6uS3ze1ai8FHa8kmHScGpWmj4WggLyQjgPie1rFSruoUihUZREPSL39UNdE3BBDu76" + ] + ] + +m1 :: Text +m1 = "fffcf9f6f3f0edeae7e4e1dedbd8d5d2cfccc9c6c3c0bdbab7b4b1aeaba8a5a29f9c999693908d8a8784817e7b7875726f6c696663605d5a5754514e4b484542" + +xKeyResVec2 :: [[Text]] +xKeyResVec2 = + [ + -- m + [ "bd16bee53961a47d6ad888e29545434a89bdfe95" + , "bd16bee5" + , "1JEoxevbLLG8cVqeoGKQiAwoWbNYSUyYjg" + , "4b03d6fc340455b363f51020ad3ecca4f0850280cf436c70c727923f6db46c3e" + , "KyjXhyHF9wTphBkfpxjL8hkDXDUSbE3tKANT94kXSyh6vn6nKaoy" + , "03cbcaa9c98c877a26977d00825c956a238e8dddfbd322cce4f74b0b5bd6ace4a7" + , "60499f801b896d83179a4374aeb7822aaeaceaa0db1f85ee3e904c4defbd9689" + , "0488b21e00000000000000000060499f801b896d83179a4374aeb7822aaeaceaa0db1f85ee3e904c4defbd968903cbcaa9c98c877a26977d00825c956a238e8dddfbd322cce4f74b0b5bd6ace4a7" + , "0488ade400000000000000000060499f801b896d83179a4374aeb7822aaeaceaa0db1f85ee3e904c4defbd9689004b03d6fc340455b363f51020ad3ecca4f0850280cf436c70c727923f6db46c3e" + , "xpub661MyMwAqRbcFW31YEwpkMuc5THy2PSt5bDMsktWQcFF8syAmRUapSCGu8ED9W6oDMSgv6Zz8idoc4a6mr8BDzTJY47LJhkJ8UB7WEGuduB" + , "xprv9s21ZrQH143K31xYSDQpPDxsXRTUcvj2iNHm5NUtrGiGG5e2DtALGdso3pGz6ssrdK4PFmM8NSpSBHNqPqm55Qn3LqFtT2emdEXVYsCzC2U" + ] + -- m/0 + , [ "5a61ff8eb7aaca3010db97ebda76121610b78096" + , "5a61ff8e" + , "19EuDJdgfRkwCmRzbzVBHZWQG9QNWhftbZ" + , "abe74a98f6c7eabee0428f53798f0ab8aa1bd37873999041703c742f15ac7e1e" + , "L2ysLrR6KMSAtx7uPqmYpoTeiRzydXBattRXjXz5GDFPrdfPzKbj" + , "02fc9e5af0ac8d9b3cecfe2a888e2117ba3d089d8585886c9c826b6b22a98d12ea" + , "f0909affaa7ee7abe5dd4e100598d4dc53cd709d5a5c2cac40e7412f232f7c9c" + , "0488b21e01bd16bee500000000f0909affaa7ee7abe5dd4e100598d4dc53cd709d5a5c2cac40e7412f232f7c9c02fc9e5af0ac8d9b3cecfe2a888e2117ba3d089d8585886c9c826b6b22a98d12ea" + , "0488ade401bd16bee500000000f0909affaa7ee7abe5dd4e100598d4dc53cd709d5a5c2cac40e7412f232f7c9c00abe74a98f6c7eabee0428f53798f0ab8aa1bd37873999041703c742f15ac7e1e" + , "xpub69H7F5d8KSRgmmdJg2KhpAK8SR3DjMwAdkxj3ZuxV27CprR9LgpeyGmXUbC6wb7ERfvrnKZjXoUmmDznezpbZb7ap6r1D3tgFxHmwMkQTPH" + , "xprv9vHkqa6EV4sPZHYqZznhT2NPtPCjKuDKGY38FBWLvgaDx45zo9WQRUT3dKYnjwih2yJD9mkrocEZXo1ex8G81dwSM1fwqWpWkeS3v86pgKt" + ] + -- m/0/2147483647' + , [ "d8ab493736da02f11ed682f88339e720fb0379d1" + , "d8ab4937" + , "1Lke9bXGhn5VPrBuXgN12uGUphrttUErmk" + , "877c779ad9687164e9c2f4f0f4ff0340814392330693ce95a58fe18fd52e6e93" + , "L1m5VpbXmMp57P3knskwhoMTLdhAAaXiHvnGLMribbfwzVRpz2Sr" + , "03c01e7425647bdefa82b12d9bad5e3e6865bee0502694b94ca58b666abc0a5c3b" + , "be17a268474a6bb9c61e1d720cf6215e2a88c5406c4aee7b38547f585c9a37d9" + , "0488b21e025a61ff8effffffffbe17a268474a6bb9c61e1d720cf6215e2a88c5406c4aee7b38547f585c9a37d903c01e7425647bdefa82b12d9bad5e3e6865bee0502694b94ca58b666abc0a5c3b" + , "0488ade4025a61ff8effffffffbe17a268474a6bb9c61e1d720cf6215e2a88c5406c4aee7b38547f585c9a37d900877c779ad9687164e9c2f4f0f4ff0340814392330693ce95a58fe18fd52e6e93" + , "xpub6ASAVgeehLbnwdqV6UKMHVzgqAG8Gr6riv3Fxxpj8ksbH9ebxaEyBLZ85ySDhKiLDBrQSARLq1uNRts8RuJiHjaDMBU4Zn9h8LZNnBC5y4a" + , "xprv9wSp6B7kry3Vj9m1zSnLvN3xH8RdsPP1Mh7fAaR7aRLcQMKTR2vidYEeEg2mUCTAwCd6vnxVrcjfy2kRgVsFawNzmjuHc2YmYRmagcEPdU9" + ] + -- m/0/2147483647'/1 + , [ "78412e3a2296a40de124307b6485bd19833e2e34" + , "78412e3a" + , "1BxrAr2pHpeBheusmd6fHDP2tSLAUa3qsW" + , "704addf544a06e5ee4bea37098463c23613da32020d604506da8c0518e1da4b7" + , "KzyzXnznxSv249b4KuNkBwowaN3akiNeEHy5FWoPCJpStZbEKXN2" + , "03a7d1d856deb74c508e05031f9895dab54626251b3806e16b4bd12e781a7df5b9" + , "f366f48f1ea9f2d1d3fe958c95ca84ea18e4c4ddb9366c336c927eb246fb38cb" + , "0488b21e03d8ab493700000001f366f48f1ea9f2d1d3fe958c95ca84ea18e4c4ddb9366c336c927eb246fb38cb03a7d1d856deb74c508e05031f9895dab54626251b3806e16b4bd12e781a7df5b9" + , "0488ade403d8ab493700000001f366f48f1ea9f2d1d3fe958c95ca84ea18e4c4ddb9366c336c927eb246fb38cb00704addf544a06e5ee4bea37098463c23613da32020d604506da8c0518e1da4b7" + , "xpub6DF8uhdarytz3FWdA8TvFSvvAh8dP3283MY7p2V4SeE2wyWmG5mg5EwVvmdMVCQcoNJxGoWaU9DCWh89LojfZ537wTfunKau47EL2dhHKon" + , "xprv9zFnWC6h2cLgpmSA46vutJzBcfJ8yaJGg8cX1e5StJh45BBciYTRXSd25UEPVuesF9yog62tGAQtHjXajPPdbRCHuWS6T8XA2ECKADdw4Ef" + ] + -- m/0/2147483647'/1/2147483646' + , [ "31a507b815593dfc51ffc7245ae7e5aee304246e" + , "31a507b8" + , "15XVotxCAV7sRx1PSCkQNsGw3W9jT9A94R" + , "f1c7c871a54a804afe328b4c83a1c33b8e5ff48f5087273f04efa83b247d6a2d" + , "L5KhaMvPYRW1ZoFmRjUtxxPypQ94m6BcDrPhqArhggdaTbbAFJEF" + , "02d2b36900396c9282fa14628566582f206a5dd0bcc8d5e892611806cafb0301f0" + , "637807030d55d01f9a0cb3a7839515d796bd07706386a6eddf06cc29a65a0e29" + , "0488b21e0478412e3afffffffe637807030d55d01f9a0cb3a7839515d796bd07706386a6eddf06cc29a65a0e2902d2b36900396c9282fa14628566582f206a5dd0bcc8d5e892611806cafb0301f0" + , "0488ade40478412e3afffffffe637807030d55d01f9a0cb3a7839515d796bd07706386a6eddf06cc29a65a0e2900f1c7c871a54a804afe328b4c83a1c33b8e5ff48f5087273f04efa83b247d6a2d" + , "xpub6ERApfZwUNrhLCkDtcHTcxd75RbzS1ed54G1LkBUHQVHQKqhMkhgbmJbZRkrgZw4koxb5JaHWkY4ALHY2grBGRjaDMzQLcgJvLJuZZvRcEL" + , "xprvA1RpRA33e1JQ7ifknakTFpgNXPmW2YvmhqLQYMmrj4xJXXWYpDPS3xz7iAxn8L39njGVyuoseXzU6rcxFLJ8HFsTjSyQbLYnMpCqE2VbFWc" + ] + -- m/0/2147483647'/1/2147483646'/2 + , [ "26132fdbe7bf89cbc64cf8dafa3f9f88b8666220" + , "26132fdb" + , "14UKfRV9ZPUp6ZC9PLhqbRtxdihW9em3xt" + , "bb7d39bdb83ecf58f2fd82b6d918341cbef428661ef01ab97c28a4842125ac23" + , "L3WAYNAZPxx1fr7KCz7GN9nD5qMBnNiqEJNJMU1z9MMaannAt4aK" + , "024d902e1a2fc7a8755ab5b694c575fce742c48d9ff192e63df5193e4c7afe1f9c" + , "9452b549be8cea3ecb7a84bec10dcfd94afe4d129ebfd3b3cb58eedf394ed271" + , "0488b21e0531a507b8000000029452b549be8cea3ecb7a84bec10dcfd94afe4d129ebfd3b3cb58eedf394ed271024d902e1a2fc7a8755ab5b694c575fce742c48d9ff192e63df5193e4c7afe1f9c" + , "0488ade40531a507b8000000029452b549be8cea3ecb7a84bec10dcfd94afe4d129ebfd3b3cb58eedf394ed27100bb7d39bdb83ecf58f2fd82b6d918341cbef428661ef01ab97c28a4842125ac23" + , "xpub6FnCn6nSzZAw5Tw7cgR9bi15UV96gLZhjDstkXXxvCLsUXBGXPdSnLFbdpq8p9HmGsApME5hQTZ3emM2rnY5agb9rXpVGyy3bdW6EEgAtqt" + , "xprvA2nrNbFZABcdryreWet9Ea4LvTJcGsqrMzxHx98MMrotbir7yrKCEXw7nadnHM8Dq38EGfSh6dqA9QWTyefMLEcBYJUuekgW4BYPJcr9E7j" + ] + ] + +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 + + +testID :: (FromJSON a, ToJSON a, Eq a) => a -> Bool +testID x = + (A.decode . A.encode) (singleton ("object" :: String) x) == + Just (singleton ("object" :: String) x) + +testCustom :: Eq a => (Value -> Parser a) -> (a -> Value) -> a -> Bool +testCustom f g x = parseMaybe f (g x) == Just x + +testPutGet :: Eq a => Get a -> Putter a -> a -> Bool +testPutGet g p a = runGet g (runPut (p a)) == Right a diff --git a/test/Haskoin/Keys/MnemonicSpec.hs b/test/Haskoin/Keys/MnemonicSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Keys/MnemonicSpec.hs @@ -0,0 +1,494 @@ +{-# LANGUAGE OverloadedStrings #-} +module Haskoin.Keys.MnemonicSpec (spec) where + +import Control.Monad (zipWithM_) +import Data.Bits (shiftR, (.&.)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C +import Data.Either (fromRight) +import Data.List (isPrefixOf) +import Data.Maybe (fromJust) +import Data.Serialize (Serialize, encode) +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Word (Word32, Word64) +import Haskoin.Crypto +import Haskoin.Keys +import Haskoin.Test +import Haskoin.Util +import Test.Hspec +import Test.HUnit +import Test.QuickCheck hiding ((.&.)) + +spec :: Spec +spec = + describe "mnemonic" $ do + it "entropy to mnemonic sentence" toMnemonicTest + it "mnemonic sentence to entropy" fromMnemonicTest + it "mnemonic sentence to seed" mnemonicToSeedTest + it "mnemonic sentence with invalid checksum" fromMnemonicInvalidTest + it "empty mnemonic sentence is invalid" $ sequence_ [emptyMnemonicTest] + it "generate 12 words" $ property toMnemonic128 + it "generate 18 words" $ property toMnemonic160 + it "generate 24 words" $ property toMnemonic256 + it "generate 48 words" $ property toMnemonic512 + it "generate any number of words" $ property toMnemonicVar + it "encode and decode 128-bit entropy" $ property fromToMnemonic128 + it "encode and decode 160-bit entropy" $ property fromToMnemonic160 + it "encode and decode 256-bit entropy" $ property fromToMnemonic256 + it "encode and decode 512-bit entropy" $ property fromToMnemonic512 + it "encode and decode n-bit entropy" $ property fromToMnemonicVar + it "convert 128-bit mnemonic to seed" $ property mnemonicToSeed128 + it "convert 160-bit mnemonic to seed" $ property mnemonicToSeed160 + it "convert 256-bit mnemonic to seed" $ property mnemonicToSeed256 + it "convert 512-bit mnemonic to seed" $ property mnemonicToSeed512 + it "convert n-bit mnemonic to seed" $ property mnemonicToSeedVar + it "get bits" $ property getBitsByteCount + it "get end bits" $ property getBitsEndBits + +toMnemonicTest :: Assertion +toMnemonicTest = zipWithM_ f ents mss + where + f e m = assertEqual "" m . h $ e + h = + fromRight (error "Could not decode mnemonic sentence") . + toMnemonic . fromJust . decodeHex + +fromMnemonicTest :: Assertion +fromMnemonicTest = zipWithM_ f ents mss + where + f e = assertEqual "" e . h + h = + encodeHex . + fromRight (error "Could not decode mnemonic sentence") . fromMnemonic + +mnemonicToSeedTest :: Assertion +mnemonicToSeedTest = zipWithM_ f mss seeds + where + f m s = assertEqual "" s . h $ m + h = + encodeHex . + fromRight (error "Could not decode mnemonic seed") . + mnemonicToSeed "TREZOR" + +fromMnemonicInvalidTest :: Assertion +fromMnemonicInvalidTest = mapM_ f invalidMss + where + f = assertBool "" . h + h m = case fromMnemonic m of + Right _ -> False + Left err -> "fromMnemonic: checksum failed:" `isPrefixOf` err + +emptyMnemonicTest :: Assertion +emptyMnemonicTest = + assertBool "" $ + case fromMnemonic "" of + Right _ -> False + Left err -> "fromMnemonic: empty mnemonic" `isPrefixOf` err + +ents :: [Text] +ents = + [ "00000000000000000000000000000000" + , "7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f" + , "80808080808080808080808080808080" + , "ffffffffffffffffffffffffffffffff" + , "000000000000000000000000000000000000000000000000" + , "7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f" + , "808080808080808080808080808080808080808080808080" + , "ffffffffffffffffffffffffffffffffffffffffffffffff" + , "0000000000000000000000000000000000000000000000000000000000000000" + , "7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f" + , "8080808080808080808080808080808080808080808080808080808080808080" + , "ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" + , "77c2b00716cec7213839159e404db50d" + , "b63a9c59a6e641f288ebc103017f1da9f8290b3da6bdef7b" + , "3e141609b97933b66a060dcddc71fad1d91677db872031e85f4c015c5e7e8982" + , "0460ef47585604c5660618db2e6a7e7f" + , "72f60ebac5dd8add8d2a25a797102c3ce21bc029c200076f" + , "2c85efc7f24ee4573d2b81a6ec66cee209b2dcbd09d8eddc51e0215b0b68e416" + , "eaebabb2383351fd31d703840b32e9e2" + , "7ac45cfe7722ee6c7ba84fbc2d5bd61b45cb2fe5eb65aa78" + , "4fa1a8bc3e6d80ee1316050e862c1812031493212b7ec3f3bb1b08f168cabeef" + , "18ab19a9f54a9274f03e5209a2ac8a91" + , "18a2e1d81b8ecfb2a333adcb0c17a5b9eb76cc5d05db91a4" + , "15da872c95a13dd738fbf50e427583ad61f18fd99f628c417a61cf8343c90419" + ] + +mss :: [Mnemonic] +mss = + [ "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ + \ abandon abandon about" + , "legal winner thank year wave sausage worth useful legal winner thank\ + \ yellow" + , "letter advice cage absurd amount doctor acoustic avoid letter advice\ + \ cage above" + , "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo wrong" + , "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ + \ abandon abandon abandon abandon abandon abandon abandon abandon agent" + , "legal winner thank year wave sausage worth useful legal winner thank\ + \ year wave sausage worth useful legal will" + , "letter advice cage absurd amount doctor acoustic avoid letter advice\ + \ cage absurd amount doctor acoustic avoid letter always" + , "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo\ + \ when" + , "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ + \ abandon abandon abandon abandon abandon abandon abandon abandon abandon\ + \ abandon abandon abandon abandon abandon art" + , "legal winner thank year wave sausage worth useful legal winner thank\ + \ year wave sausage worth useful legal winner thank year wave sausage\ + \ worth title" + , "letter advice cage absurd amount doctor acoustic avoid letter advice\ + \ cage absurd amount doctor acoustic avoid letter advice cage absurd\ + \ amount doctor acoustic bless" + , "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo\ + \ zoo zoo zoo zoo zoo vote" + , "jelly better achieve collect unaware mountain thought cargo oxygen act\ + \ hood bridge" + , "renew stay biology evidence goat welcome casual join adapt armor shuffle\ + \ fault little machine walk stumble urge swap" + , "dignity pass list indicate nasty swamp pool script soccer toe leaf photo\ + \ multiply desk host tomato cradle drill spread actor shine dismiss\ + \ champion exotic" + , "afford alter spike radar gate glance object seek swamp infant panel\ + \ yellow" + , "indicate race push merry suffer human cruise dwarf pole review arch keep\ + \ canvas theme poem divorce alter left" + , "clutch control vehicle tonight unusual clog visa ice plunge glimpse\ + \ recipe series open hour vintage deposit universe tip job dress radar\ + \ refuse motion taste" + , "turtle front uncle idea crush write shrug there lottery flower risk\ + \ shell" + , "kiss carry display unusual confirm curtain upgrade antique rotate hello\ + \ void custom frequent obey nut hole price segment" + , "exile ask congress lamp submit jacket era scheme attend cousin alcohol\ + \ catch course end lucky hurt sentence oven short ball bird grab wing top" + , "board flee heavy tunnel powder denial science ski answer betray cargo\ + \ cat" + , "board blade invite damage undo sun mimic interest slam gaze truly\ + \ inherit resist great inject rocket museum chief" + , "beyond stage sleep clip because twist token leaf atom beauty genius food\ + \ business side grid unable middle armed observe pair crouch tonight away\ + \ coconut" + ] + +seeds :: [Text] +seeds = + [ "c55257c360c07c72029aebc1b53c05ed0362ada38ead3e3e9efa3708e53495531f09a69\ + \87599d18264c1e1c92f2cf141630c7a3c4ab7c81b2f001698e7463b04" + , "2e8905819b8723fe2c1d161860e5ee1830318dbf49a83bd451cfb8440c28bd6fa457fe1\ + \296106559a3c80937a1c1069be3a3a5bd381ee6260e8d9739fce1f607" + , "d71de856f81a8acc65e6fc851a38d4d7ec216fd0796d0a6827a3ad6ed5511a30fa280f1\ + \2eb2e47ed2ac03b5c462a0358d18d69fe4f985ec81778c1b370b652a8" + , "ac27495480225222079d7be181583751e86f571027b0497b5b5d11218e0a8a133325729\ + \17f0f8e5a589620c6f15b11c61dee327651a14c34e18231052e48c069" + , "035895f2f481b1b0f01fcf8c289c794660b289981a78f8106447707fdd9666ca06da5a9\ + \a565181599b79f53b844d8a71dd9f439c52a3d7b3e8a79c906ac845fa" + , "f2b94508732bcbacbcc020faefecfc89feafa6649a5491b8c952cede496c214a0c7b3c3\ + \92d168748f2d4a612bada0753b52a1c7ac53c1e93abd5c6320b9e95dd" + , "107d7c02a5aa6f38c58083ff74f04c607c2d2c0ecc55501dadd72d025b751bc27fe913f\ + \fb796f841c49b1d33b610cf0e91d3aa239027f5e99fe4ce9e5088cd65" + , "0cd6e5d827bb62eb8fc1e262254223817fd068a74b5b449cc2f667c3f1f985a76379b43\ + \348d952e2265b4cd129090758b3e3c2c49103b5051aac2eaeb890a528" + , "bda85446c68413707090a52022edd26a1c9462295029f2e60cd7c4f2bbd3097170af7a4\ + \d73245cafa9c3cca8d561a7c3de6f5d4a10be8ed2a5e608d68f92fcc8" + , "bc09fca1804f7e69da93c2f2028eb238c227f2e9dda30cd63699232578480a4021b146a\ + \d717fbb7e451ce9eb835f43620bf5c514db0f8add49f5d121449d3e87" + , "c0c519bd0e91a2ed54357d9d1ebef6f5af218a153624cf4f2da911a0ed8f7a09e2ef61a\ + \f0aca007096df430022f7a2b6fb91661a9589097069720d015e4e982f" + , "dd48c104698c30cfe2b6142103248622fb7bb0ff692eebb00089b32d22484e1613912f0\ + \a5b694407be899ffd31ed3992c456cdf60f5d4564b8ba3f05a69890ad" + , "b5b6d0127db1a9d2226af0c3346031d77af31e918dba64287a1b44b8ebf63cdd52676f6\ + \72a290aae502472cf2d602c051f3e6f18055e84e4c43897fc4e51a6ff" + , "9248d83e06f4cd98debf5b6f010542760df925ce46cf38a1bdb4e4de7d21f5c39366941\ + \c69e1bdbf2966e0f6e6dbece898a0e2f0a4c2b3e640953dfe8b7bbdc5" + , "ff7f3184df8696d8bef94b6c03114dbee0ef89ff938712301d27ed8336ca89ef9635da2\ + \0af07d4175f2bf5f3de130f39c9d9e8dd0472489c19b1a020a940da67" + , "65f93a9f36b6c85cbe634ffc1f99f2b82cbb10b31edc7f087b4f6cb9e976e9faf76ff41\ + \f8f27c99afdf38f7a303ba1136ee48a4c1e7fcd3dba7aa876113a36e4" + , "3bbf9daa0dfad8229786ace5ddb4e00fa98a044ae4c4975ffd5e094dba9e0bb289349db\ + \e2091761f30f382d4e35c4a670ee8ab50758d2c55881be69e327117ba" + , "fe908f96f46668b2d5b37d82f558c77ed0d69dd0e7e043a5b0511c48c2f1064694a956f\ + \86360c93dd04052a8899497ce9e985ebe0c8c52b955e6ae86d4ff4449" + , "bdfb76a0759f301b0b899a1e3985227e53b3f51e67e3f2a65363caedf3e32fde42a66c4\ + \04f18d7b05818c95ef3ca1e5146646856c461c073169467511680876c" + , "ed56ff6c833c07982eb7119a8f48fd363c4a9b1601cd2de736b01045c5eb8ab4f57b079\ + \403485d1c4924f0790dc10a971763337cb9f9c62226f64fff26397c79" + , "095ee6f817b4c2cb30a5a797360a81a40ab0f9a4e25ecd672a3f58a0b5ba0687c096a6b\ + \14d2c0deb3bdefce4f61d01ae07417d502429352e27695163f7447a8c" + , "6eff1bb21562918509c73cb990260db07c0ce34ff0e3cc4a8cb3276129fbcb300bddfe0\ + \05831350efd633909f476c45c88253276d9fd0df6ef48609e8bb7dca8" + , "f84521c777a13b61564234bf8f8b62b3afce27fc4062b51bb5e62bdfecb23864ee6ecf0\ + \7c1d5a97c0834307c5c852d8ceb88e7c97923c0a3b496bedd4e5f88a9" + , "b15509eaa2d09d3efd3e006ef42151b30367dc6e3aa5e44caba3fe4d3e352e65101fbdb\ + \86a96776b91946ff06f8eac594dc6ee1d3e82a42dfe1b40fef6bcc3fd" + ] + +invalidMss :: [Mnemonic] +invalidMss = + [ "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ + \ abandon abandon abandon" + , "legal winner thank year wave sausage worth useful legal winner thank\ + \ thank" + , "letter advice cage absurd amount doctor acoustic avoid letter advice\ + \ cage sausage" + , "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo" + , "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ + \ abandon abandon abandon abandon abandon abandon abandon abandon abandon" + , "legal winner thank year wave sausage worth useful legal winner thank\ + \ year wave sausage worth useful legal letter" + , "letter advice cage absurd amount doctor acoustic avoid letter advice\ + \ cage absurd amount doctor acoustic avoid letter abandon" + , "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo\ + \ zoo" + , "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ + \ abandon abandon abandon abandon abandon abandon abandon abandon abandon\ + \ abandon abandon abandon abandon abandon abandon" + , "legal winner thank year wave sausage worth useful legal winner thank\ + \ year wave sausage worth useful legal winner thank year wave sausage\ + \ worth letter" + , "letter advice cage absurd amount doctor acoustic avoid letter advice\ + \ cage absurd amount doctor acoustic avoid letter advice cage absurd\ + \ amount doctor acoustic letter" + , "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo\ + \ zoo zoo zoo zoo zoo zoo" + , "jelly better achieve collect unaware mountain thought cargo oxygen act\ + \ hood zoo" + , "renew stay biology evidence goat welcome casual join adapt armor shuffle\ + \ fault little machine walk stumble urge zoo" + , "dignity pass list indicate nasty swamp pool script soccer toe leaf photo\ + \ multiply desk host tomato cradle drill spread actor shine dismiss\ + \ champion zoo" + , "afford alter spike radar gate glance object seek swamp infant panel\ + \ zoo" + , "indicate race push merry suffer human cruise dwarf pole review arch keep\ + \ canvas theme poem divorce alter zoo" + , "clutch control vehicle tonight unusual clog visa ice plunge glimpse\ + \ recipe series open hour vintage deposit universe tip job dress radar\ + \ refuse motion zoo" + , "turtle front uncle idea crush write shrug there lottery flower risk\ + \ zoo" + , "kiss carry display unusual confirm curtain upgrade antique rotate hello\ + \ void custom frequent obey nut hole price zoo" + , "exile ask congress lamp submit jacket era scheme attend cousin alcohol\ + \ catch course end lucky hurt sentence oven short ball bird grab wing zoo" + , "board flee heavy tunnel powder denial science ski answer betray cargo\ + \ zoo" + , "board blade invite damage undo sun mimic interest slam gaze truly\ + \ inherit resist great inject rocket museum zoo" + , "beyond stage sleep clip because twist token leaf atom beauty genius food\ + \ business side grid unable middle armed observe pair crouch tonight away\ + \ zoo" + ] + +binWordsToBS :: Serialize a => [a] -> BS.ByteString +binWordsToBS = foldr f BS.empty + where + f b a = a `BS.append` encode b + +{- Encode mnemonic -} + +toMnemonic128 :: (Word64, Word64) -> Bool +toMnemonic128 (a, b) = l == 12 + where + bs = encode a `BS.append` encode b + l = + length . + T.words . fromRight (error "Could not decode mnemonic senttence") $ + toMnemonic bs + +toMnemonic160 :: (Word32, Word64, Word64) -> Bool +toMnemonic160 (a, b, c) = l == 15 + where + bs = BS.concat [encode a, encode b, encode c] + l = + length . + T.words . fromRight (error "Could not decode mnemonic sentence") $ + toMnemonic bs + +toMnemonic256 :: (Word64, Word64, Word64, Word64) -> Bool +toMnemonic256 (a, b, c, d) = l == 24 + where + bs = BS.concat [encode a, encode b, encode c, encode d] + l = + length . + T.words . fromRight (error "Could not decode mnemonic sentence") $ + toMnemonic bs + +toMnemonic512 :: + ((Word64, Word64, Word64, Word64), (Word64, Word64, Word64, Word64)) -> Bool +toMnemonic512 ((a, b, c, d), (e, f, g, h)) = l == 48 + where + bs = + BS.concat + [ encode a + , encode b + , encode c + , encode d + , encode e + , encode f + , encode g + , encode h + ] + l = + length . + T.words . fromRight (error "Could not decode mnemonic sentence") $ + toMnemonic bs + +toMnemonicVar :: [Word32] -> Property +toMnemonicVar ls = not (null ls) && length ls <= 8 ==> l == wc + where + bs = binWordsToBS ls + bl = BS.length bs + cb = bl `div` 4 + wc = (cb + bl * 8) `div` 11 + l = + length . T.words . + fromRight (error "Could not decode mnemonic sentence") $ + toMnemonic bs + +{- Encode/Decode -} + +fromToMnemonic128 :: (Word64, Word64) -> Bool +fromToMnemonic128 (a, b) = bs == bs' + where + bs = encode a `BS.append` encode b + bs' = + fromRight + (error "Could not decode mnemonic entropy") + (fromMnemonic =<< toMnemonic bs) + +fromToMnemonic160 :: (Word32, Word64, Word64) -> Bool +fromToMnemonic160 (a, b, c) = bs == bs' + where + bs = BS.concat [encode a, encode b, encode c] + bs' = + fromRight + (error "Could not decode mnemonic entropy") + (fromMnemonic =<< toMnemonic bs) + +fromToMnemonic256 :: (Word64, Word64, Word64, Word64) -> Bool +fromToMnemonic256 (a, b, c, d) = bs == bs' + where + bs = BS.concat [encode a, encode b, encode c, encode d] + bs' = + fromRight + (error "Could not decode mnemonic entropy") + (fromMnemonic =<< toMnemonic bs) + +fromToMnemonic512 :: + ((Word64, Word64, Word64, Word64), (Word64, Word64, Word64, Word64)) -> Bool +fromToMnemonic512 ((a, b, c, d), (e, f, g, h)) = bs == bs' + where + bs = + BS.concat + [ encode a + , encode b + , encode c + , encode d + , encode e + , encode f + , encode g + , encode h + ] + bs' = + fromRight + (error "Could not decode mnemonic entropy") + (fromMnemonic =<< toMnemonic bs) + +fromToMnemonicVar :: [Word32] -> Property +fromToMnemonicVar ls = not (null ls) && length ls <= 8 ==> bs == bs' + where + bs = binWordsToBS ls + bs' = + fromRight + (error "Could not decode mnemonic entropy") + (fromMnemonic =<< toMnemonic bs) + +{- Mnemonic to seed -} + +mnemonicToSeed128 :: (Word64, Word64) -> Bool +mnemonicToSeed128 (a, b) = l == 64 + where + bs = encode a `BS.append` encode b + seed = + fromRight + (error "Could not decode mnemonic seed") + (mnemonicToSeed "" =<< toMnemonic bs) + l = BS.length seed + +mnemonicToSeed160 :: (Word32, Word64, Word64) -> Bool +mnemonicToSeed160 (a, b, c) = l == 64 + where + bs = BS.concat [encode a, encode b, encode c] + seed = + fromRight + (error "Could not decode mnemonic seed") + (mnemonicToSeed "" =<< toMnemonic bs) + l = BS.length seed + +mnemonicToSeed256 :: (Word64, Word64, Word64, Word64) -> Bool +mnemonicToSeed256 (a, b, c, d) = l == 64 + where + bs = BS.concat [encode a, encode b, encode c, encode d] + seed = + fromRight + (error "Could not decode mnemonic seed") + (mnemonicToSeed "" =<< toMnemonic bs) + l = BS.length seed + +mnemonicToSeed512 :: + ((Word64, Word64, Word64, Word64), (Word64, Word64, Word64, Word64)) -> Bool +mnemonicToSeed512 ((a, b, c, d), (e, f, g, h)) = l == 64 + where + bs = + BS.concat + [ encode a + , encode b + , encode c + , encode d + , encode e + , encode f + , encode g + , encode h + ] + seed = + fromRight + (error "Could not decode mnemonic seed") + (mnemonicToSeed "" =<< toMnemonic bs) + l = BS.length seed + +mnemonicToSeedVar :: [Word32] -> Property +mnemonicToSeedVar ls = not (null ls) && length ls <= 16 ==> l == 64 + where + bs = binWordsToBS ls + seed = + fromRight + (error "Could not decode mnemonic seed") + (mnemonicToSeed "" =<< toMnemonic bs) + l = BS.length seed + +{- Get bits from ByteString -} + +data ByteCountGen = ByteCountGen BS.ByteString Int deriving Show + +instance Arbitrary ByteCountGen where + arbitrary = do + bs <- arbitraryBS + i <- choose (0, BS.length bs * 8) + return $ ByteCountGen bs i + +getBitsByteCount :: ByteCountGen -> Bool +getBitsByteCount (ByteCountGen bs i) = BS.length bits == l + where + (q, r) = i `quotRem` 8 + bits = getBits i bs + l = if r == 0 then q else q + 1 + +getBitsEndBits :: ByteCountGen -> Bool +getBitsEndBits (ByteCountGen bs i) = + (r == 0) || (BS.last bits .&. (0xff `shiftR` r) == 0x00) + where + r = i `mod` 8 + bits = getBits i bs diff --git a/test/Haskoin/KeysSpec.hs b/test/Haskoin/KeysSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/KeysSpec.hs @@ -0,0 +1,72 @@ +module Haskoin.KeysSpec (spec) where + +import Data.Aeson as A +import qualified Data.ByteString as BS +import Data.Map.Strict (singleton) +import Data.Serialize as S +import Data.String (fromString) +import Data.String.Conversions (cs) +import Haskoin.Address +import Haskoin.Constants +import Haskoin.Crypto +import Haskoin.Keys +import Haskoin.Test +import Haskoin.Util +import Test.Hspec +import Test.QuickCheck + +spec :: Spec +spec = + describe "keys" $ do + let net = btc + it "is public key canonical" $ + property $ forAll arbitraryKeyPair (isCanonicalPubKey . snd) + it "encode and decode wif private keys" $ + property $ + forAll arbitraryKeyPair $ \(pk, _) -> + fromWif net (toWif net pk) == Just pk + it "encode and decode serialized private key" $ + property $ forAll arbitrary binaryPrvKey + it "read and show public key" $ + property $ forAll arbitraryKeyPair $ \(_, k) -> read (show k) == k + it "read and show private key" $ + property $ forAll arbitrarySecKeyI $ \k -> read (show k) == k + it "from string public key" $ + property $ + forAll arbitraryKeyPair $ \(_, k) -> + fromString (cs . encodeHex $ S.encode k) == k + it "encode and decode json public key" $ + property $ forAll arbitraryKeyPair (testID . snd) + it "encodes and decodes serialized public key" $ + property $ forAll arbitraryKeyPair $ cerealID . snd + + +-- github.com/bitcoin/bitcoin/blob/master/src/script.cpp +-- from function IsCanonicalPubKey +isCanonicalPubKey :: PubKeyI -> Bool +isCanonicalPubKey p = not $ + -- Non-canonical public key: too short + (BS.length bs < 33) || + -- Non-canonical public key: invalid length for uncompressed key + (BS.index bs 0 == 4 && BS.length bs /= 65) || + -- Non-canonical public key: invalid length for compressed key + (BS.index bs 0 `elem` [2,3] && BS.length bs /= 33) || + -- Non-canonical public key: compressed nor uncompressed + (BS.index bs 0 `notElem` [2,3,4]) + where + bs = S.encode p + +{- Key formats -} + +binaryPrvKey :: SecKey -> Bool +binaryPrvKey k = + Right k == runGet secKeyGet (runPut (secKeyPut k)) && + Just k == secKey (getSecKey k) + +testID :: (FromJSON a, ToJSON a, Eq a) => a -> Bool +testID x = + (A.decode . A.encode) (singleton ("object" :: String) x) == + Just (singleton ("object" :: String) x) + +cerealID :: (Serialize a, Eq a) => a -> Bool +cerealID x = S.decode (S.encode x) == Right x diff --git a/test/Haskoin/NetworkSpec.hs b/test/Haskoin/NetworkSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/NetworkSpec.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE OverloadedStrings #-} +module Haskoin.NetworkSpec (spec) where + +import Data.Maybe (fromJust) +import Data.Serialize as S +import Data.Text (Text) +import Data.Word (Word32) +import Haskoin.Address +import Haskoin.Constants +import Haskoin.Keys +import Haskoin.Network +import Haskoin.Test +import Haskoin.Transaction +import Haskoin.Util +import Test.Hspec +import Test.HUnit (Assertion, assertBool, assertEqual) +import Test.QuickCheck + +spec :: Spec +spec = do + let net = btc + describe "bloom filters" $ do + it "bloom filter vector 1" bloomFilter1 + it "bloom filter vector 2" bloomFilter2 + it "bloom filter vector 3" bloomFilter3 + describe "relevant bloom filter update" $ do + it "Relevant Update" relevantOutputUpdated + it "Irrelevant Update" irrelevantOutputNotUpdated + describe "serialization of protocol types" $ do + it "encodes and decodes varint" $ + property $ forAll arbitraryVarInt cerealID + it "encodes and decodes varstring" $ + property $ forAll arbitraryVarString cerealID + it "encodes and decodes network address" $ + property $ forAll arbitraryNetworkAddress cerealID + it "encodes and decodes invtype" $ + property $ forAll arbitraryInvType cerealID + it "encodes and decodes invvector" $ + property $ forAll arbitraryInvVector cerealID + it "encodes and decodes inv" $ property $ forAll arbitraryInv1 cerealID + it "encodes and decodes version" $ + property $ forAll arbitraryVersion cerealID + it "encodes and decodes addr" $ property $ forAll arbitraryAddr1 cerealID + it "encodes and decodes alert" $ property $ forAll arbitraryAlert cerealID + it "encodes and decodes reject" $ + property $ forAll arbitraryReject cerealID + it "encodes and decodes getdata" $ + property $ forAll arbitraryGetData cerealID + it "encodes and decodes notfound" $ + property $ forAll arbitraryNotFound cerealID + it "encodes and decodes ping" $ property $ forAll arbitraryPing cerealID + it "encodes and decodes pong" $ property $ forAll arbitraryPong cerealID + it "encodes and decodes message command" $ + property $ forAll arbitraryMessageCommand cerealID + it "encodes and decodes message header" $ + property $ forAll arbitraryMessageHeader cerealID + it "encodes and decodes message" $ + property $ + forAll (arbitraryMessage net) $ + testPutGet (getMessage net) (putMessage net) + describe "serialization of bloom types" $ do + it "encodes and decodes bloom flags" $ + property $ forAll arbitraryBloomFlags cerealID + it "encodes and decodes bloom filter" $ + property $ forAll arbitraryBloomFilter $ cerealID . lst3 + it "encodes and decodes filterload" $ + property $ forAll arbitraryFilterLoad cerealID + it "encodes and decodes filteradd" $ + property $ forAll arbitraryFilterAdd cerealID + +bloomFilter :: Word32 -> Text -> Assertion +bloomFilter n x = do + assertBool "Bloom filter doesn't contain vector 1" $ bloomContains f1 v1 + assertBool "Bloom filter contains something it should not" $ + not $ bloomContains f1 v2 + assertBool "Bloom filter doesn't contain vector 3" $ bloomContains f3 v3 + assertBool "Bloom filter doesn't contain vector 4" $ bloomContains f4 v4 + assertBool "Bloom filter serialization is incorrect" $ + S.encode f4 == bs + where + f0 = bloomCreate 3 0.01 n BloomUpdateAll + f1 = bloomInsert f0 v1 + f3 = bloomInsert f1 v3 + f4 = bloomInsert f3 v4 + v1 = fromJust $ decodeHex "99108ad8ed9bb6274d3980bab5a85c048f0950c8" + v2 = fromJust $ decodeHex "19108ad8ed9bb6274d3980bab5a85c048f0950c8" + v3 = fromJust $ decodeHex "b5a2c786d9ef4658287ced5914b37a1b4aa32eee" + 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" $ + S.encode f2 == bs + where + f0 = bloomCreate 2 0.001 0 BloomUpdateAll + f1 = bloomInsert f0 $ S.encode p + f2 = bloomInsert f1 $ S.encode $ getAddrHash160 $ pubKeyAddr p + k = fromJust $ fromWif btc "5Kg1gnAjaLfKiwhhPpGS3QfRg2m6awQvaj98JCZBZQ5SuS2F15C" + p = derivePubKeyI k + bs = fromJust $ decodeHex "038fc16b080000000000000001" + +cerealID :: (Serialize a, Eq a) => a -> Bool +cerealID x = S.decode (S.encode x) == Right x + +testPutGet :: Eq a => Get a -> Putter a -> a -> Bool +testPutGet g p a = runGet g (runPut (p a)) == Right a + +relevantOutputUpdated :: Assertion +relevantOutputUpdated = assertBool "Bloom filter output updated" $ + any (bloomContains bf2) spendTxInput + where + bf0 = bloomCreate 10 0.000001 0 BloomUpdateAll + relevantOutputHash = fromJust $ decodeHex"03f47604ea2736334151081e13265b4fe38e6fa8" + bf1 = bloomInsert bf0 relevantOutputHash + bf2 = fromJust $ bloomRelevantUpdate bf1 relevantTx + spendTxInput = (encode .prevOutput) <$> txIn spendRelevantTx + +irrelevantOutputNotUpdated :: Assertion +irrelevantOutputNotUpdated = assertEqual "Bloom filter not updated" Nothing bf2 + where + bf0 = bloomCreate 10 0.000001 0 BloomUpdateAll + relevantOutputHash = fromJust $ decodeHex"03f47604ea2736334151081e13265b4fe38e6fa8" + bf1 = bloomInsert bf0 relevantOutputHash + bf2 = bloomRelevantUpdate bf1 unrelatedTx + spendTxInput = (encode .prevOutput) <$> txIn spendRelevantTx + +-- Random transaction (57dc904f32ad4daab7b321dd469e8791ad09df784cdd273a73985150a4f225e9) +relevantTx :: Tx +relevantTx = Tx + { txVersion = 1 + , txIn = [ TxIn + { prevOutput = OutPoint "35fe9017b7e3af592920b56fa06ac02faf0c52cdb19dcb416129ac71c95d060e" 1 + , scriptInput = fromJust $ decodeHex "473044022032fc8eef299b7e94b9a986a6aa2dcb9733ab804bef80df995e443b9c1f8c604202203335df7a2e2b4789451cdb4b2b05a786a81c51519eb6a567fd6fe8cd7b2d33fe014104272502dc63a512dad1473cb82a71be9baf4f4303abd1ff6028fc8a78e1f3aec1218907119dec14f07354850758ff0948e88a904fa411c4df7d5444414ec64ad6" + , txInSequence = 4294967295 + } ] + , txOut = + [ TxOut { outValue = 100000000, scriptOutput = fromJust $ decodeHex "76a91403f47604ea2736334151081e13265b4fe38e6fa888ac" } + , TxOut { outValue = 107980000, scriptOutput = fromJust $ decodeHex "76a91481cc186a2f4a69f633ed4bf10ef4a78be13effdd88ac" } + ] + , txWitness = [] + , txLockTime = 0 + } + +-- Transaction that spends above (fd6e3b693b844aa431fad46765c1aa019a6b13aebfa9dae916b3ffa43283a300) +spendRelevantTx :: Tx +spendRelevantTx = Tx + { txVersion = 1 + , txIn = [ TxIn + { prevOutput = OutPoint "57dc904f32ad4daab7b321dd469e8791ad09df784cdd273a73985150a4f225e9" 0 + , scriptInput = fromJust $ decodeHex "483045022100ecc334821e4e94cc2fdc841d5ad147d5bb942b993ba81460cc446e0410afa811022015fcbc542b734dbb61a05ec06012095096de5839c50808fe56f2b315e877c20d012103fb64e5792fa586172339b776b7017d3d529358cb73be6406a1fc994228d14f88" + , txInSequence = 4294967295 + }, TxIn + { prevOutput = OutPoint "cfee6a8d6e68e8fd16df6fff010afffcd19d7e075aa7b707dd1bae6adc420042" 0 + , scriptInput = fromJust $ decodeHex "47304402200e6bb95fa606f254d17089d83c4ceeb19c5d1699b4faddcd4f1f1568286e6b650220087fb8439f31e1b30e47710d095422405f601d6151f2f93e125e1a08a6e29ad4012103b49252e8fc6d5b49c8d14ee71fab45591df4a126a6c453c724f3d356e38f0cee" + , txInSequence = 4294967295 + } ] + , txOut = + [ TxOut { outValue = 3851100, scriptOutput = fromJust $ decodeHex "76a914a297cae82a9a3b932bf023ae274fe2585295c9ca88ac" } + , TxOut { outValue = 111000000, scriptOutput = fromJust $ decodeHex "76a9148f952c38600a61385974acc30a64f74407f9801488ac" } + ] + , txWitness = [] + , txLockTime = 0 + } + +-- This random transaction is unrelated to the others +unrelatedTx :: Tx +unrelatedTx = Tx + { txVersion = 1 + , txIn = [ TxIn + { prevOutput = OutPoint "3ec3a71431c68e5d978a5fb4a0a1081d8bee8384d8aa4c06b1fbaf9413e2214f" 20 + , scriptInput = fromJust $ decodeHex "483045022100ec9c202c9d3140b973aca9d7f21a82138aa4cfa43fddc5419098ac5e26a6f152022010848fd688f290ae010fb5cb493410caa03145fc12445900ec1ad2bde33aecd9012102c7445e72d723f99a0064526c28269d07f47c8fd81531a94a8d3bf5ebd5e23ef1" + , txInSequence = 4294967295 + }] + , txOut = + [ TxOut { outValue = 12600000, scriptOutput = fromJust $ decodeHex "76a9148fef3b7051de8cc44e966159e7ea37f4520187e888ac" } + ] + , txWitness = [] + , txLockTime = 0 + } diff --git a/test/Haskoin/ScriptSpec.hs b/test/Haskoin/ScriptSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/ScriptSpec.hs @@ -0,0 +1,406 @@ +{-# LANGUAGE OverloadedStrings #-} +module Haskoin.ScriptSpec (spec) where + +import Control.Monad +import Data.Aeson as A +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Data.Either +import Data.List +import Data.Map.Strict (singleton) +import Data.Maybe +import Data.Monoid ((<>)) +import Data.Serialize as S +import Data.String +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Word +import Haskoin.Address +import Haskoin.Constants +import Haskoin.Keys +import Haskoin.Script +import Haskoin.Test +import Haskoin.Transaction +import Haskoin.Util +import Test.Hspec +import Test.HUnit as HUnit +import Test.QuickCheck +import Text.Read + +spec :: Spec +spec = do + let net = btc + describe "btc scripts" $ props btc + describe "bch scripts" $ props bch + describe "multi signatures" $ + zipWithM_ (curry mapMulSigVector) mulSigVectors [0 ..] + describe "signature decoding" $ + zipWithM_ (curry (sigDecodeMap net)) scriptSigSignatures [0 ..] + describe "json serialization" $ do + it "encodes and decodes script output" $ + forAll (arbitraryScriptOutput net) testID + it "encodes and decodes outpoint" $ forAll arbitraryOutPoint testID + it "encodes and decodes sighash" $ forAll arbitrarySigHash testID + it "encodes and decodes siginput" $ + forAll (arbitrarySigInput net) (testID . fst) + describe "script serialization" $ do + it "encodes and decodes script op" $ + property $ forAll arbitraryScriptOp cerealID + it "encodes and decodes script" $ + property $ forAll arbitraryScript cerealID + +props :: Network -> Spec +props net = do + standardSpec net + strictSigSpec net + scriptSpec net + txSigHashForkIdSpec net + forkIdScriptSpec net + sigHashSpec net + txSigHashSpec net + +cerealID :: (Serialize a, Eq a) => a -> Bool +cerealID x = S.decode (S.encode x) == Right x + +standardSpec :: Network -> Spec +standardSpec net = do + it "has intToScriptOp . scriptOpToInt identity" $ + property $ + forAll arbitraryIntScriptOp $ \i -> + intToScriptOp <$> scriptOpToInt i `shouldBe` Right i + it "has decodeOutput . encodeOutput identity" $ + property $ + forAll (arbitraryScriptOutput net) $ \so -> + decodeOutput (encodeOutput so) `shouldBe` Right so + it "has decodeInput . encodeOutput identity" $ + property $ + forAll (arbitraryScriptInput net) $ \si -> + decodeInput net (encodeInput si) `shouldBe` Right si + it "can sort multisig scripts" $ + forAll arbitraryMSOutput $ \out -> + map S.encode (getOutputMulSigKeys (sortMulSig out)) `shouldSatisfy` \xs -> + xs == sort xs + it "can decode inputs with empty signatures" $ do + decodeInput net (Script [OP_0]) `shouldBe` + Right (RegularInput (SpendPK TxSignatureEmpty)) + decodeInput net (Script [opPushData ""]) `shouldBe` + Right (RegularInput (SpendPK TxSignatureEmpty)) + let pk = + derivePubKeyI $ + wrapSecKey True $ fromJust $ secKey $ B.replicate 32 1 + decodeInput net (Script [OP_0, opPushData $ S.encode pk]) `shouldBe` + Right (RegularInput (SpendPKHash TxSignatureEmpty pk)) + decodeInput net (Script [OP_0, OP_0]) `shouldBe` + Right (RegularInput (SpendMulSig [TxSignatureEmpty])) + decodeInput net (Script [OP_0, OP_0, OP_0, OP_0]) `shouldBe` + Right (RegularInput (SpendMulSig $ replicate 3 TxSignatureEmpty)) + +scriptSpec :: Network -> Spec +scriptSpec net = + when (getNetworkName net == "btc") $ + it "can verify standard scripts from script_tests.json file" $ do + xs <- readTestFile "script_tests" :: IO [A.Value] + let vectorsA = + mapMaybe (A.decode . A.encode) xs :: [( String + , String + , String + , String + , String)] + vectorsB = + mapMaybe (A.decode . A.encode) xs :: [( [Word64] + , String + , String + , String + , String + , String)] + vectors = + map (\(a, b, c, d, e) -> ([0], a, b, c, d, e)) vectorsA <> + vectorsB + length vectors `shouldBe` 86 + forM_ vectors $ \([val], siStr, soStr, flags, res, desc) + -- We can disable specific tests by adding a DISABLED flag in the data + -> + unless ("DISABLED" `isInfixOf` flags) $ do + let _strict = + "DERSIG" `isInfixOf` flags || + "STRICTENC" `isInfixOf` flags || + "NULLDUMMY" `isInfixOf` flags + scriptSig = parseScript siStr + scriptPubKey = parseScript soStr + decodedOutput = decodeOutputBS scriptPubKey + ver = either (const False) $ \so -> + verifyStdInput + net + (spendTx scriptPubKey 0 scriptSig) + 0 + so + (val * 100000000) + case res of + "OK" -> assertBool desc $ ver decodedOutput + _ -> assertBool desc (not $ ver decodedOutput) + +forkIdScriptSpec :: Network -> Spec +forkIdScriptSpec net = + when (isJust (getSigHashForkId net)) $ + it "can verify scripts from forkid_script_tests.json file" $ do + xs <- readTestFile "forkid_script_tests" :: 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 = + Tx 1 [txI] [txO] [] 0 + where + txO = TxOut {outValue = val, scriptOutput = scriptPubKey} + txI = + TxIn + { prevOutput = nullOutPoint + , scriptInput = S.encode $ Script [OP_0, OP_0] + , txInSequence = maxBound + } + +spendTx :: ByteString -> Word64 -> ByteString -> Tx +spendTx scriptPubKey val scriptSig = + Tx 1 [txI] [txO] [] 0 + where + txO = TxOut {outValue = val, scriptOutput = B.empty} + txI = + TxIn + { prevOutput = OutPoint (txHash $ creditTx scriptPubKey val) 0 + , scriptInput = scriptSig + , txInSequence = maxBound + } + +parseScript :: String -> ByteString +parseScript str = + B.concat $ fromMaybe err $ mapM f $ words str + where + f = decodeHex . cs . dropHex . replaceToken + dropHex ('0':'x':xs) = xs + 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 $ S.encode (opcode :: ScriptOp)) + _ -> str + +strictSigSpec :: Network -> Spec +strictSigSpec net = + when (getNetworkName net == "btc") $ do + it "can decode strict signatures" $ do + xs <- readTestFile "sig_strict" + let vectors = mapMaybe decodeHex xs + length vectors `shouldBe` 3 + forM_ vectors $ \sig -> + decodeTxSig net sig `shouldSatisfy` isRight + it "can detect non-strict signatures" $ do + xs <- readTestFile "sig_nonstrict" + let vectors = mapMaybe decodeHex xs + length vectors `shouldBe` 17 + forM_ vectors $ \sig -> + decodeTxSig net sig `shouldSatisfy` isLeft + +txSigHashSpec :: Network -> Spec +txSigHashSpec net = + when (getNetworkName net == "btc") $ + it "can produce valid sighashes from sighash.json test vectors" $ do + xs <- readTestFile "sighash" :: IO [A.Value] + let vectors = + mapMaybe (A.decode . A.encode) xs :: [( String + , String + , Int + , Integer + , String)] + length vectors `shouldBe` 500 + forM_ vectors $ \(txStr, scpStr, i, shI, resStr) -> do + let tx = fromString txStr + s = + fromMaybe (error $ "Could not decode script: " <> cs scpStr) $ + eitherToMaybe . S.decode =<< decodeHex (cs scpStr) + sh = fromIntegral shI + res = + eitherToMaybe . S.decode . B.reverse =<< + decodeHex (cs resStr) + Just (txSigHash net tx s 0 i sh) `shouldBe` res + +txSigHashForkIdSpec :: Network -> Spec +txSigHashForkIdSpec net = + when (getNetworkName net == "btc") $ + it "can produce valid sighashes from forkid_sighash.json test vectors" $ do + xs <- readTestFile "forkid_sighash" :: 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 . S.decode =<< decodeHex (cs scpStr) + sh = fromIntegral shI + res = eitherToMaybe . S.decode =<< decodeHex (cs resStr) + Just (txSigHashForkId net tx s val i sh) `shouldBe` res + +sigHashSpec :: Network -> Spec +sigHashSpec net = do + it "can read . show" $ + property $ forAll arbitrarySigHash $ \sh -> read (show sh) `shouldBe` sh + it "can correctly show" $ do + show (0x00 :: SigHash) `shouldBe` "SigHash " <> show (0x00 :: Word32) + show (0x01 :: SigHash) `shouldBe` "SigHash " <> show (0x01 :: Word32) + show (0xff :: SigHash) `shouldBe` "SigHash " <> show (0xff :: Word32) + show (0xabac3344 :: SigHash) `shouldBe` "SigHash " <> + show (0xabac3344 :: Word32) + it "can add a forkid" $ do + 0x00 `sigHashAddForkId` 0x00 `shouldBe` 0x00 + 0xff `sigHashAddForkId` 0x00ffffff `shouldBe` 0xffffffff + 0xffff `sigHashAddForkId` 0x00aaaaaa `shouldBe` 0xaaaaaaff + 0xffff `sigHashAddForkId` 0xaaaaaaaa `shouldBe` 0xaaaaaaff + 0xffff `sigHashAddForkId` 0x00004444 `shouldBe` 0x004444ff + 0xff01 `sigHashAddForkId` 0x44440000 `shouldBe` 0x44000001 + 0xff03 `sigHashAddForkId` 0x00550000 `shouldBe` 0x55000003 + it "can extract a forkid" $ do + sigHashGetForkId 0x00000000 `shouldBe` 0x00000000 + sigHashGetForkId 0x80000000 `shouldBe` 0x00800000 + sigHashGetForkId 0xffffffff `shouldBe` 0x00ffffff + sigHashGetForkId 0xabac3403 `shouldBe` 0x00abac34 + it "can build some vectors" $ do + sigHashAll `shouldBe` 0x01 + sigHashNone `shouldBe` 0x02 + sigHashSingle `shouldBe` 0x03 + setForkIdFlag sigHashAll `shouldBe` 0x41 + setAnyoneCanPayFlag sigHashAll `shouldBe` 0x81 + setAnyoneCanPayFlag (setForkIdFlag sigHashAll) `shouldBe` 0xc1 + it "can test flags" $ do + hasForkIdFlag sigHashAll `shouldBe` False + hasForkIdFlag (setForkIdFlag sigHashAll) `shouldBe` True + hasAnyoneCanPayFlag sigHashAll `shouldBe` False + hasAnyoneCanPayFlag (setAnyoneCanPayFlag sigHashAll) `shouldBe` True + isSigHashAll sigHashNone `shouldBe` False + isSigHashAll sigHashAll `shouldBe` True + isSigHashNone sigHashSingle `shouldBe` False + isSigHashNone sigHashNone `shouldBe` True + isSigHashSingle sigHashAll `shouldBe` False + isSigHashSingle sigHashSingle `shouldBe` True + isSigHashUnknown sigHashAll `shouldBe` False + isSigHashUnknown sigHashNone `shouldBe` False + isSigHashUnknown sigHashSingle `shouldBe` False + isSigHashUnknown 0x00 `shouldBe` True + isSigHashUnknown 0x04 `shouldBe` True + it "can decodeTxSig . encode a TxSignature" $ + property $ + forAll (arbitraryTxSignature net) $ \(_, _, ts) -> + decodeTxSig net (encodeTxSig ts) `shouldBe` Right ts + it "can produce the sighash one" $ + property $ + forAll (arbitraryTx net) $ forAll arbitraryScript . testSigHashOne net + +testSigHashOne :: Network -> Tx -> Script -> Word64 -> Bool -> Property +testSigHashOne net tx s val acp = + not (null $ txIn tx) ==> + if length (txIn tx) > length (txOut tx) + then res `shouldBe` one + else res `shouldNotBe` one + where + res = txSigHash net tx s val (length (txIn tx) - 1) (f sigHashSingle) + one = "0100000000000000000000000000000000000000000000000000000000000000" + f = + if acp + then setAnyoneCanPayFlag + else id + +{-- Test Utilities --} + +readTestFile :: A.FromJSON a => FilePath -> IO a +readTestFile fp = do + bs <- L.readFile $ "data/" <> fp <> ".json" + maybe (error $ "Could not read test file " <> fp) return $ A.decode bs + +{- Parse tests from bitcoin-qt repository -} + +mapMulSigVector :: ((Text, Text), Int) -> Spec +mapMulSigVector (v, i) = + it name $ runMulSigVector v + where + name = "check multisig vector " <> show i + +runMulSigVector :: (Text, Text) -> Assertion +runMulSigVector (a, ops) = assertBool "multisig vector" $ Just a == b + where + s = do + s' <- decodeHex ops + eitherToMaybe $ S.decode s' + b = do + o <- s + d <- eitherToMaybe $ decodeOutput o + addrToString 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 + eitherSig = decodeTxSig net bs + in assertBool + (unwords + [ "Decode failed:" + , fromLeft (error "Decode did not fail") eitherSig + ]) $ + isRight eitherSig + +mulSigVectors :: [(Text, Text)] +mulSigVectors = + [ ( "3QJmV3qfvL9SuYo34YihAf3sRCW3qSinyC" + , "52410491bba2510912a5bd37da1fb5b1673010e43d2c6d812c514e91bfa9f2eb129e1c183329db55bd868e209aac2fbc02cb33d98fe74bf23f0c235d6126b1d8334f864104865c40293a680cb9c020e7b1e106d8c1916d3cef99aa431a56d253e69256dac09ef122b1a986818a7cb624532f062c1d1f8722084861c5c3291ccffef4ec687441048d2455d2403e08708fc1f556002f1b6cd83f992d085097f9974ab08a28838f07896fbab08f39495e15fa6fad6edbfb1e754e35fa1c7844c41f322a1863d4621353ae" + ) + ] + +scriptSigSignatures :: [Text] +scriptSigSignatures = + -- Signature in input of txid 1983a69265920c24f89aac81942b1a59f7eb30821a8b3fb258f88882b6336053 + [ "304402205ca6249f43538908151fe67b26d020306c0e59fa206cf9f3ccf641f33357119d02206c82f244d04ac0a48024fb9cc246b66e58598acf206139bdb7b75a2941a2b1e401" + -- Signature in input of txid + -- fb0a1d8d34fa5537e461ac384bac761125e1bfa7fec286fa72511240fa66864d. + -- Strange DER sizes, but in Blockchain. Now invalid as Haskoin can only + -- decode strict signatures. + -- "3048022200002b83d59c1d23c08efd82ee0662fec23309c3adbcbd1f0b8695378db4b14e736602220000334a96676e58b1bb01784cb7c556dd8ce1c220171904da22e18fe1e7d1510db501" + ] + + +testID :: (FromJSON a, ToJSON a, Eq a) => a -> Bool +testID x = + (A.decode . A.encode) (singleton ("object" :: String) x) == + Just (singleton ("object" :: String) x) diff --git a/test/Haskoin/Test.hs b/test/Haskoin/Test.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Test.hs @@ -0,0 +1,23 @@ +{-| +Module : Haskoin.Test +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX + +Arbitrary instances for testing. +-} +module Haskoin.Test + ( module X + ) where + +import Haskoin.Test.Address as X +import Haskoin.Test.Block as X +import Haskoin.Test.Crypto as X +import Haskoin.Test.Keys as X +import Haskoin.Test.Message as X +import Haskoin.Test.Network as X +import Haskoin.Test.Script as X +import Haskoin.Test.Transaction as X +import Haskoin.Test.Util as X diff --git a/test/Haskoin/Test/Address.hs b/test/Haskoin/Test/Address.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Test/Address.hs @@ -0,0 +1,25 @@ +{-| +Module : Haskoin.Test.Address +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX +-} +module Haskoin.Test.Address where + +import Haskoin.Address +import Haskoin.Test.Crypto +import Test.QuickCheck + +-- | Arbitrary pay-to-public-key-hash or pay-to-script-hash address. +arbitraryAddress :: Gen Address +arbitraryAddress = oneof [arbitraryPubKeyAddress, arbitraryScriptAddress] + +-- | Arbitrary pay-to-public-key-hash address. +arbitraryPubKeyAddress :: Gen Address +arbitraryPubKeyAddress = p2pkhAddr <$> arbitraryHash160 + +-- | Arbitrary pay-to-script-hash address. +arbitraryScriptAddress :: Gen Address +arbitraryScriptAddress = p2shAddr <$> arbitraryHash160 diff --git a/test/Haskoin/Test/Block.hs b/test/Haskoin/Test/Block.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Test/Block.hs @@ -0,0 +1,69 @@ +{-| +Module : Haskoin.Test.Block +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX +-} +module Haskoin.Test.Block where + +import Haskoin.Block.Common +import Haskoin.Block.Merkle +import Haskoin.Constants +import Haskoin.Test.Crypto +import Haskoin.Test.Network +import Haskoin.Test.Transaction +import Test.QuickCheck + +-- | Block full or arbitrary transactions. +arbitraryBlock :: Network -> Gen Block +arbitraryBlock net = do + h <- arbitraryBlockHeader + c <- choose (0,10) + txs <- vectorOf c (arbitraryTx net) + return $ Block h txs + +-- | Block header with random hash. +arbitraryBlockHeader :: Gen BlockHeader +arbitraryBlockHeader = + BlockHeader <$> arbitrary + <*> arbitraryBlockHash + <*> arbitraryHash256 + <*> arbitrary + <*> arbitrary + <*> arbitrary + +-- | Arbitrary block hash. +arbitraryBlockHash :: Gen BlockHash +arbitraryBlockHash = BlockHash <$> arbitraryHash256 + +-- | Arbitrary 'GetBlocks' object with at least one block hash. +arbitraryGetBlocks :: Gen GetBlocks +arbitraryGetBlocks = + GetBlocks <$> arbitrary + <*> listOf1 arbitraryBlockHash + <*> arbitraryBlockHash + +-- | Arbitrary 'GetHeaders' object with at least one block header. +arbitraryGetHeaders :: Gen GetHeaders +arbitraryGetHeaders = + GetHeaders <$> arbitrary + <*> 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 + bh <- arbitraryBlockHeader + ntx <- arbitrary + hashes <- listOf1 arbitraryHash256 + c <- choose (1,10) + flags <- vectorOf (c*8) arbitrary + return $ MerkleBlock bh ntx hashes flags + diff --git a/test/Haskoin/Test/Crypto.hs b/test/Haskoin/Test/Crypto.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Test/Crypto.hs @@ -0,0 +1,33 @@ +{-| +Module : Haskoin.Test.Crypto +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX +-} +module Haskoin.Test.Crypto where + +import Haskoin.Crypto.Hash +import Haskoin.Test.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 = + checkSum32 <$> arbitraryBSn 4 diff --git a/test/Haskoin/Test/Keys.hs b/test/Haskoin/Test/Keys.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Test/Keys.hs @@ -0,0 +1,85 @@ +{-| +Module : Haskoin.Test.Keys +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX +-} +module Haskoin.Test.Keys where + +import Data.Bits (clearBit) +import Data.List (foldl') +import Data.Word (Word32) +import Haskoin.Crypto +import Haskoin.Keys.Common +import Haskoin.Keys.Extended +import Haskoin.Test.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) + +-- | Arbitrary extended private key. +arbitraryXPrvKey :: Gen XPrvKey +arbitraryXPrvKey = + XPrvKey <$> arbitrary + <*> arbitrary + <*> 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 = + oneof [ Bip32SoftIndex <$> genIndex + , 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. +arbitraryParsedPath :: Gen ParsedPath +arbitraryParsedPath = + oneof [ ParsedPrv <$> arbitraryDerivPath + , ParsedPub <$> arbitraryDerivPath + , ParsedEmpty <$> arbitraryDerivPath + ] + +-- | Arbitrary message hash, private key, nonce and corresponding signature. The +-- signature is generated with a random message, random private key and a random +-- nonce. +arbitrarySignature :: Gen (Hash256, SecKey, Sig) +arbitrarySignature = do + m <- arbitraryHash256 + key <- arbitrary + let sig = signHash key m + return (m, key, sig) diff --git a/test/Haskoin/Test/Message.hs b/test/Haskoin/Test/Message.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Test/Message.hs @@ -0,0 +1,52 @@ +{-| +Module : Haskoin.Test.Message +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX +-} +module Haskoin.Test.Message where + +import Haskoin.Constants +import Haskoin.Network.Message +import Haskoin.Test.Block +import Haskoin.Test.Crypto +import Haskoin.Test.Network +import Haskoin.Test.Transaction +import Test.QuickCheck + +-- | Arbitrary 'MessageHeader'. +arbitraryMessageHeader :: Gen MessageHeader +arbitraryMessageHeader = + MessageHeader <$> arbitrary + <*> arbitraryMessageCommand + <*> arbitrary + <*> arbitraryCheckSum32 + +-- | Arbitrary 'Message'. +arbitraryMessage :: Network -> Gen Message +arbitraryMessage net = + oneof + [ MVersion <$> arbitraryVersion + , return MVerAck + , MAddr <$> arbitraryAddr1 + , MInv <$> arbitraryInv1 + , MGetData <$> arbitraryGetData + , MNotFound <$> arbitraryNotFound + , MGetBlocks <$> arbitraryGetBlocks + , MGetHeaders <$> arbitraryGetHeaders + , MTx <$> arbitraryTx net + , MBlock <$> arbitraryBlock net + , MMerkleBlock <$> arbitraryMerkleBlock + , MHeaders <$> arbitraryHeaders + , return MGetAddr + , MFilterLoad <$> arbitraryFilterLoad + , MFilterAdd <$> arbitraryFilterAdd + , return MFilterClear + , MPing <$> arbitraryPing + , MPong <$> arbitraryPong + , MAlert <$> arbitraryAlert + , MReject <$> arbitraryReject + , return MSendHeaders + ] diff --git a/test/Haskoin/Test/Network.hs b/test/Haskoin/Test/Network.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Test/Network.hs @@ -0,0 +1,178 @@ +{-| +Module : Haskoin.Test.Network +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX +-} +module Haskoin.Test.Network where + +import qualified Data.ByteString as BS (empty, pack) +import qualified Data.ByteString.Char8 as C8 +import Data.Word (Word16, Word32) +import Haskoin.Network +import Haskoin.Test.Crypto +import Haskoin.Test.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 + s <- arbitrary + a <- arbitrary + p <- arbitrary + d <- oneof + [ do + b <- arbitrary + c <- arbitrary + d <- arbitrary + return $ SockAddrInet6 (fromIntegral p) 0 (a,b,c,d) 0 + , return $ SockAddrInet (fromIntegral (p :: Word16)) a + ] + let n = sockToHostAddress d + return $ NetworkAddress s n + +-- | Arbitrary 'NetworkAddressTime'. +arbitraryNetworkAddressTime :: Gen (Word32, NetworkAddress) +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 + <*> arbitrary + <*> arbitrary + <*> arbitraryNetworkAddress + <*> arbitraryNetworkAddress + <*> arbitrary + <*> arbitraryVarString + <*> arbitrary + <*> arbitrary + +-- | Arbitrary non-empty 'Addr'. +arbitraryAddr1 :: Gen Addr +arbitraryAddr1 = Addr <$> listOf1 arbitraryNetworkAddressTime + +-- | Arbitrary 'Alert' with random payload and signature. Signature is not +-- valid. +arbitraryAlert :: Gen Alert +arbitraryAlert = Alert <$> arbitraryVarString <*> arbitraryVarString + +-- | Arbitrary 'Reject'. +arbitraryReject :: Gen Reject +arbitraryReject = do + m <- arbitraryMessageCommand + c <- arbitraryRejectCode + s <- arbitraryVarString + d <- oneof [ return BS.empty + , BS.pack <$> vectorOf 32 arbitrary + ] + return $ Reject m c s d + +-- | Arbitrary 'RejectCode'. +arbitraryRejectCode :: Gen RejectCode +arbitraryRejectCode = + elements + [ RejectMalformed + , RejectInvalid + , RejectInvalid + , RejectDuplicate + , RejectNonStandard + , RejectDust + , RejectInsufficientFee + , 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 = + elements + [ BloomUpdateNone + , BloomUpdateAll + , BloomUpdateP2PubKeyOnly + ] + +-- | Arbitrary bloom filter with its corresponding number of elements +-- and false positive rate. +arbitraryBloomFilter :: Gen (Int, Double, BloomFilter) +arbitraryBloomFilter = do + n <- choose (0,100000) + fp <- choose (1e-8,1) + tweak <- arbitrary + fl <- arbitraryBloomFlags + return (n, fp, bloomCreate n fp tweak fl) + +-- | 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 + ASCIIString str <- arbitrary + elements + [ MCVersion + , MCVerAck + , MCAddr + , MCInv + , MCGetData + , MCNotFound + , MCGetBlocks + , MCGetHeaders + , MCTx + , MCBlock + , MCMerkleBlock + , MCHeaders + , MCGetAddr + , MCFilterLoad + , MCFilterAdd + , MCFilterClear + , MCPing + , MCPong + , MCAlert + , MCOther (C8.take 12 (C8.pack (filter (/= '\NUL') str))) + ] diff --git a/test/Haskoin/Test/Script.hs b/test/Haskoin/Test/Script.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Test/Script.hs @@ -0,0 +1,374 @@ +{-# LANGUAGE LambdaCase #-} +{-| +Module : Haskoin.Test.Script +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX +-} +module Haskoin.Test.Script where + +import Crypto.Secp256k1 +import Data.Maybe +import Data.Word +import Haskoin.Address +import Haskoin.Constants +import Haskoin.Keys.Common +import Haskoin.Script +import Haskoin.Test.Address +import Haskoin.Test.Crypto +import Haskoin.Test.Keys +import Haskoin.Test.Util +import Haskoin.Transaction.Common +import Haskoin.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 = + oneof + -- Pushing Data + [ opPushData <$> arbitraryBS1 + , return OP_0 + , return OP_1NEGATE + , return OP_RESERVED + , return OP_1 + , return OP_2 + , return OP_3 + , return OP_4 + , return OP_5 + , return OP_6 + , return OP_7 + , return OP_8 + , return OP_9 + , return OP_10 + , return OP_11 + , return OP_12 + , return OP_13 + , return OP_14 + , return OP_15 + , return OP_16 + -- Flow control + , return OP_NOP + , return OP_VER + , return OP_IF + , return OP_NOTIF + , return OP_VERIF + , return OP_VERNOTIF + , return OP_ELSE + , return OP_ENDIF + , return OP_VERIFY + , return OP_RETURN + -- Stack operations + , return OP_TOALTSTACK + , return OP_FROMALTSTACK + , return OP_IFDUP + , return OP_DEPTH + , return OP_DROP + , return OP_DUP + , return OP_NIP + , return OP_OVER + , return OP_PICK + , return OP_ROLL + , return OP_ROT + , return OP_SWAP + , return OP_TUCK + , return OP_2DROP + , return OP_2DUP + , return OP_3DUP + , return OP_2OVER + , return OP_2ROT + , return OP_2SWAP + -- Splice + , return OP_CAT + , return OP_SUBSTR + , return OP_LEFT + , return OP_RIGHT + , return OP_SIZE + -- Bitwise logic + , return OP_INVERT + , return OP_AND + , return OP_OR + , return OP_XOR + , return OP_EQUAL + , return OP_EQUALVERIFY + , return OP_RESERVED1 + , return OP_RESERVED2 + -- Arithmetic + , return OP_1ADD + , return OP_1SUB + , return OP_2MUL + , return OP_2DIV + , return OP_NEGATE + , return OP_ABS + , return OP_NOT + , return OP_0NOTEQUAL + , return OP_ADD + , return OP_SUB + , return OP_MUL + , return OP_DIV + , return OP_MOD + , return OP_LSHIFT + , return OP_RSHIFT + , return OP_BOOLAND + , return OP_BOOLOR + , return OP_NUMEQUAL + , return OP_NUMEQUALVERIFY + , return OP_NUMNOTEQUAL + , return OP_LESSTHAN + , return OP_GREATERTHAN + , return OP_LESSTHANOREQUAL + , return OP_GREATERTHANOREQUAL + , return OP_MIN + , return OP_MAX + , return OP_WITHIN + -- Crypto + , return OP_RIPEMD160 + , return OP_SHA1 + , return OP_SHA256 + , return OP_HASH160 + , return OP_HASH256 + , return OP_CODESEPARATOR + , return OP_CHECKSIG + , return OP_CHECKSIGVERIFY + , return OP_CHECKMULTISIG + , return OP_CHECKMULTISIGVERIFY + -- Expansion + , return OP_NOP1 + , return OP_NOP2 + , return OP_NOP3 + , return OP_NOP4 + , return OP_NOP5 + , return OP_NOP6 + , return OP_NOP7 + , return OP_NOP8 + , return OP_NOP9 + , return OP_NOP10 + -- Other + , return OP_PUBKEYHASH + , return OP_PUBKEY + , return $ OP_INVALIDOPCODE 0xff + ] + +-- | Arbtirary 'ScriptOp' with a value in @[OP_1 .. OP_16]@. +arbitraryIntScriptOp :: Gen ScriptOp +arbitraryIntScriptOp = + elements + [ OP_1, OP_2, OP_3, OP_4 + , OP_5, OP_6, OP_7, OP_8 + , OP_9, OP_10, OP_11, OP_12 + , OP_13, OP_14, OP_15, OP_16 + ] + +-- | 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 + +-- | Arbitrary message hash, private key and corresponding 'TxSignature'. The +-- signature is generated deterministically using a random message and a random +-- private key. +arbitraryTxSignature :: Network -> Gen (TxHash, SecKey, TxSignature) +arbitraryTxSignature net = do + (m, key, sig) <- arbitrarySignature + sh <- (fromIntegral <$> (arbitrary :: Gen Word8)) `suchThat` filterBad + let txsig = TxSignature sig sh + return (TxHash m, key, txsig) + where + filterBad sh = not $ + isSigHashUnknown sh || + isNothing (getSigHashForkId net) && hasForkIdFlag sh + +-- | Arbitrary transaction signature that could also be empty. +arbitraryTxSignatureEmpty :: Network -> Gen TxSignature +arbitraryTxSignatureEmpty net = + frequency [ (1, return TxSignatureEmpty) + , (10, lst3 <$> arbitraryTxSignature net) + ] + +-- | Arbitrary m of n parameters. +arbitraryMSParam :: Gen (Int, Int) +arbitraryMSParam = do + m <- choose (1,16) + n <- choose (m,16) + return (m, n) + +-- | Arbitrary 'ScriptOutput' (Can by any valid type). +arbitraryScriptOutput :: Network -> Gen ScriptOutput +arbitraryScriptOutput net = + oneof $ + [ arbitraryPKOutput + , arbitraryPKHashOutput + , arbitraryMSOutput + , arbitrarySHOutput + , arbitraryDCOutput + ] ++ + if getSegWit net + then [arbitraryWPKHashOutput, arbitraryWSHOutput] + else [] + +-- | Arbitrary 'ScriptOutput' of type 'PayPK', 'PayPKHash' or 'PayMS' +-- (Not 'PayScriptHash', 'DataCarrier', or SegWit) +arbitrarySimpleOutput :: Gen ScriptOutput +arbitrarySimpleOutput = + oneof + [ arbitraryPKOutput + , arbitraryPKHashOutput + , arbitraryMSOutput + ] + +-- | Arbitrary 'ScriptOutput' of type 'PayPK' +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 + +-- | Arbitrary 'ScriptOutput' of type 'PayMS'. +arbitraryMSOutput :: Gen ScriptOutput +arbitraryMSOutput = do + (m, n) <- arbitraryMSParam + keys <- map snd <$> vectorOf n arbitraryKeyPair + return $ PayMulSig keys m + +-- | Arbitrary 'ScriptOutput' of type 'PayMS', only using compressed keys. +arbitraryMSOutputC :: Gen ScriptOutput +arbitraryMSOutputC = do + (m, n) <- arbitraryMSParam + keys <- + map snd <$> + vectorOf n (arbitraryKeyPair `suchThat` (pubKeyCompressed . snd)) + return $ PayMulSig keys m + +-- | 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 = + oneof + [ arbitraryPKInput net + , arbitraryPKHashInput net + , arbitraryMSInput net + , arbitrarySHInput net + ] + +-- | Arbitrary 'ScriptInput' of type 'SpendPK', 'SpendPKHash' or 'SpendMulSig' +-- (not 'ScriptHashInput') +arbitrarySimpleInput :: Network -> Gen ScriptInput +arbitrarySimpleInput net = + oneof + [ arbitraryPKInput net + , arbitraryPKHashInput net + , arbitraryMSInput net + ] + +-- | Arbitrary 'ScriptInput' of type 'SpendPK'. +arbitraryPKInput :: Network -> Gen ScriptInput +arbitraryPKInput net = RegularInput . SpendPK <$> arbitraryTxSignatureEmpty net + +-- | Arbitrary 'ScriptInput' of type 'SpendPK'. +arbitraryPKHashInput :: Network -> Gen ScriptInput +arbitraryPKHashInput net = do + sig <- arbitraryTxSignatureEmpty net + key <- snd <$> arbitraryKeyPair + return $ RegularInput $ SpendPKHash sig key + +-- | Like 'arbitraryPKHashInput' without empty signatures. +arbitraryPKHashInputFull :: Network -> Gen ScriptInput +arbitraryPKHashInputFull net = do + sig <- lst3 <$> arbitraryTxSignature net + key <- snd <$> arbitraryKeyPair + return $ RegularInput $ SpendPKHash sig key + +-- | Like above but only compressed. +arbitraryPKHashInputFullC :: Network -> Gen ScriptInput +arbitraryPKHashInputFullC net = do + sig <- lst3 <$> arbitraryTxSignature net + key <- fmap snd $ arbitraryKeyPair `suchThat` (pubKeyCompressed . snd) + return $ RegularInput $ SpendPKHash sig key + +-- | Arbitrary 'ScriptInput' of type 'SpendMulSig'. +arbitraryMSInput :: Network -> Gen ScriptInput +arbitraryMSInput net = do + m <- fst <$> arbitraryMSParam + 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'. +arbitraryMulSigSHInput :: Network -> Gen ScriptInput +arbitraryMulSigSHInput net = + arbitraryMSOutput >>= \case + rdm@(PayMulSig _ m) -> do + sigs <- vectorOf m (arbitraryTxSignatureEmpty net) + return $ ScriptHashInput (SpendMulSig sigs) rdm + _ -> undefined + +-- | Arbitrary 'ScriptInput' of type 'ScriptHashInput' containing a +-- 'RedeemScript' of type 'PayMulSig' and an input of type 'SpendMulSig'. +arbitraryMulSigSHInputC :: Network -> Gen ScriptInput +arbitraryMulSigSHInputC net = + arbitraryMSOutputC >>= \case + rdm@(PayMulSig _ m) -> do + sigs <- vectorOf m (arbitraryTxSignatureEmpty net) + return $ ScriptHashInput (SpendMulSig sigs) rdm + _ -> undefined + +-- | Like 'arbitraryMulSigSHCInput' with no empty signatures. +arbitraryMulSigSHInputFull :: Network -> Gen ScriptInput +arbitraryMulSigSHInputFull net = + arbitraryMSOutput >>= \case + rdm@(PayMulSig _ m) -> do + sigs <- map lst3 <$> vectorOf m (arbitraryTxSignature net) + return $ ScriptHashInput (SpendMulSig sigs) rdm + _ -> undefined + +-- | Like 'arbitraryMulSigSHCInput' with no empty signatures. +arbitraryMulSigSHInputFullC :: Network -> Gen ScriptInput +arbitraryMulSigSHInputFullC net = + arbitraryMSOutputC >>= \case + rdm@(PayMulSig _ m) -> do + sigs <- map lst3 <$> vectorOf m (arbitraryTxSignature net) + return $ ScriptHashInput (SpendMulSig sigs) rdm + _ -> undefined diff --git a/test/Haskoin/Test/Transaction.hs b/test/Haskoin/Test/Transaction.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Test/Transaction.hs @@ -0,0 +1,275 @@ +{-| +Module : Haskoin.Test.Transaction +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX +-} +module Haskoin.Test.Transaction where + +import Control.Monad +import qualified Data.ByteString as BS +import Data.Either (fromRight) +import Data.List (nub, nubBy, permutations) +import Data.Word (Word64) +import Haskoin.Address +import Haskoin.Constants +import Haskoin.Keys.Common +import Haskoin.Script +import Haskoin.Test.Crypto +import Haskoin.Test.Keys +import Haskoin.Test.Script +import Haskoin.Test.Util +import Haskoin.Transaction +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) + <*> (encodeOutputBS <$> arbitraryScriptOutput net) + +-- | Arbitrary 'TxIn'. +arbitraryTxIn :: Network -> Gen TxIn +arbitraryTxIn net = + 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 + ni <- choose (0, 5) + no <- + if wit + then choose (0, 5) + else choose + ( if ni == 0 + then 2 + else 0 + , 5 -- avoid witness case + ) + inps <- vectorOf ni (arbitraryTxIn net) + outs <- vectorOf no (arbitraryTxOut net) + let uniqueInps = nubBy (\a b -> prevOutput a == prevOutput b) inps + w <- if wit then vectorOf (length uniqueInps) (listOf arbitraryBS) else return [] + Tx <$> arbitrary <*> pure uniqueInps <*> pure outs <*> pure w <*> arbitrary + +-- | 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 (0, 5) + no <- choose (0, 5) + inps <- vectorOf ni (arbitraryAddrOnlyTxIn net) + 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 + ni <- choose (0, 5) + no <- choose (0, 5) + inps <- vectorOf ni (arbitraryAddrOnlyTxInFull net) + 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. +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 + inp <- + 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 + v <- getTestCoin <$> arbitrarySatoshi net + out <- oneof [arbitraryPKHashOutput, arbitrarySHOutput] + return $ TxOut v $ encodeOutputBS out + +-- | Arbitrary 'SigInput' with the corresponding private keys used +-- to generate the 'ScriptOutput' or 'RedeemScript'. +arbitrarySigInput :: Network -> Gen (SigInput, [SecKeyI]) +arbitrarySigInput net = + oneof + [ wrapKey <$> arbitraryPKSigInput net + , wrapKey <$> arbitraryPKHashSigInput net + , arbitraryMSSigInput net + , arbitrarySHSigInput net + , wrapKey <$> arbitraryWPKHSigInput net + , arbitraryWSHSigInput net + ] + +-- | Arbitrary 'SigInput' with 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 + (k, p) <- arbitraryKeyPair + let out | pkh = PayPKHash $ getAddrHash160 $ pubKeyAddr p + | otherwise = PayPK p + (val, op, sh) <- arbitraryInputStuff net + return (SigInput out val op sh Nothing, k) + +-- | Arbitrary value, out point and sighash for an input. +arbitraryInputStuff :: Network -> Gen (Word64, OutPoint, SigHash) +arbitraryInputStuff net = do + val <- getTestCoin <$> arbitrarySatoshi net + op <- arbitraryOutPoint + sh <- arbitraryValidSigHash net + return (val, op, sh) + +-- | Arbitrary 'SigInput' with a 'ScriptOutput' of type 'PayMulSig'. +arbitraryMSSigInput :: Network -> Gen (SigInput, [SecKeyI]) +arbitraryMSSigInput net = do + (m, n) <- arbitraryMSParam + ks <- vectorOf n arbitraryKeyPair + let out = PayMulSig (map snd ks) m + (val, op, sh) <- arbitraryInputStuff net + perm <- choose (0, n - 1) + let ksPerm = map fst $ take m $ permutations ks !! perm + return (SigInput out val op sh Nothing, ksPerm) + +-- | Arbitrary 'SigInput' with 'ScriptOutput' of type 'PaySH' and a +-- 'RedeemScript'. +arbitrarySHSigInput :: Network -> Gen (SigInput, [SecKeyI]) +arbitrarySHSigInput net = do + (SigInput rdm val op sh _, ks) <- oneof + [ wrapKey <$> arbitraryPKSigInput net + , wrapKey <$> arbitraryPKHashSigInput net + , arbitraryMSSigInput net + ] + let out = PayScriptHash $ getAddrHash160 $ payToScriptAddress rdm + return (SigInput out val op sh $ Just rdm, ks) + +arbitraryWPKHSigInput :: Network -> Gen (SigInput, SecKeyI) +arbitraryWPKHSigInput net = do + (k, p) <- arbitraryKeyPair + (val, op, sh) <- arbitraryInputStuff net + let out = PayWitnessPKHash . getAddrHash160 $ pubKeyAddr p + return (SigInput out val op sh Nothing, k) + +arbitraryWSHSigInput :: Network -> Gen (SigInput, [SecKeyI]) +arbitraryWSHSigInput net = do + (SigInput rdm val op sh _, ks) <- oneof + [ wrapKey <$> arbitraryPKSigInput net + , wrapKey <$> arbitraryPKHashSigInput net + , arbitraryMSSigInput net + ] + let out = PayWitnessScriptHash . getAddrHash256 $ payToWitnessScriptAddress rdm + return (SigInput out val op sh $ Just rdm, ks) + +-- | Arbitrary 'Tx' (empty 'TxIn'), 'SigInputs' and private keys that can be +-- passed to 'signTx' or 'detSignTx' to fully sign the 'Tx'. +arbitrarySigningData :: Network -> Gen (Tx, [SigInput], [SecKeyI]) +arbitrarySigningData net = do + v <- arbitrary + ni <- choose (1, 5) + no <- choose (1, 5) + sigis <- vectorOf ni (arbitrarySigInput net) + let uSigis = nubBy (\(a, _) (b, _) -> sigInputOP a == sigInputOP b) sigis + inps <- forM uSigis $ \(s, _) -> TxIn (sigInputOP s) BS.empty <$> arbitrary + outs <- vectorOf no (arbitraryTxOut net) + l <- arbitrary + perm <- choose (0, length inps - 1) + let tx = Tx v (permutations inps !! perm) outs [] l + keys = concatMap snd uSigis + return (tx, map fst uSigis, keys) + +-- | Arbitrary transaction with empty inputs. +arbitraryEmptyTx :: Network -> Gen Tx +arbitraryEmptyTx net = do + v <- arbitrary + no <- choose (1,5) + ni <- choose (1,5) + outs <- vectorOf no (arbitraryTxOut net) + ops <- vectorOf ni arbitraryOutPoint + t <- arbitrary + s <- arbitrary + return $ Tx v (map (\op -> TxIn op BS.empty s) (nub ops)) outs [] t + +-- | Arbitrary partially-signed transactions. +arbitraryPartialTxs :: + Network -> Gen ([Tx], [(ScriptOutput, Word64, OutPoint, Int, Int)]) +arbitraryPartialTxs net = do + tx <- arbitraryEmptyTx net + res <- + forM (map prevOutput $ txIn tx) $ \op -> do + (so, val, rdmM, prvs, m, n) <- arbitraryData + txs <- mapM (singleSig so val rdmM tx op . secKeyData) prvs + return (txs, (so, val, op, m, n)) + return (concatMap fst res, map snd res) + where + singleSig so val rdmM tx op prv = do + sh <- arbitraryValidSigHash net + let sigi = SigInput so val op sh rdmM + return . fromRight (error "Could not decode transaction") $ + signTx net tx [sigi] [prv] + arbitraryData = do + (m, n) <- arbitraryMSParam + val <- getTestCoin <$> arbitrarySatoshi net + nPrv <- choose (m, n) + keys <- vectorOf n arbitraryKeyPair + perm <- choose (0, length keys - 1) + let pubKeys = map snd keys + prvKeys = take nPrv $ permutations (map fst keys) !! perm + let so = PayMulSig pubKeys m + elements + [ (so, val, Nothing, prvKeys, m, n) + , ( PayScriptHash $ getAddrHash160 $ payToScriptAddress so + , val + , Just so + , prvKeys + , m + , n) + ] + +wrapKey :: (SigInput, SecKeyI) -> (SigInput, [SecKeyI]) +wrapKey (s, k) = (s, [k]) diff --git a/test/Haskoin/Test/Util.hs b/test/Haskoin/Test/Util.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Test/Util.hs @@ -0,0 +1,40 @@ +{-| +Module : Haskoin.Test.Util +Copyright : No rights reserved +License : UNLICENSE +Maintainer : jprupp@protonmail.ch +Stability : experimental +Portability : POSIX +-} +module Haskoin.Test.Util where + +import Data.ByteString (ByteString, pack) +import Data.Time.Clock (UTCTime (..)) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Word (Word32) +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 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 = frequency [ (1, return Nothing) + , (5, Just <$> g) + ] + diff --git a/test/Haskoin/Transaction/PartialSpec.hs b/test/Haskoin/Transaction/PartialSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Transaction/PartialSpec.hs @@ -0,0 +1,335 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Haskoin.Transaction.PartialSpec (spec) where + +import Control.Monad.Fail (MonadFail) +import Data.ByteString (ByteString) +import Data.Either (fromRight, isLeft, isRight) +import Data.HashMap.Strict (fromList, singleton) +import Data.Maybe (fromJust, isJust) +import Data.Serialize as S +import Data.Text (Text) +import Test.Hspec +import Test.HUnit (Assertion, assertBool, + assertEqual) +import Test.QuickCheck + +import Haskoin.Address +import Haskoin.Constants +import Haskoin.Crypto +import Haskoin.Keys +import Haskoin.Script +import Haskoin.Test +import Haskoin.Transaction +import Haskoin.Transaction.Partial +import Haskoin.Util + +spec :: Spec +spec = describe "partially signed bitcoin transaction unit tests" $ do + it "encodes trivial psbt" $ + encodeHex (S.encode trivialPSBT) == trivialPSBTHex + it "decodes trivial psbt" $ + decodeHexPSBT trivialPSBTHex == Right trivialPSBT + it "encodes and decodes non-empty transactions" $ + S.decode (S.encode nonEmptyTransactionPSBT) == Right nonEmptyTransactionPSBT + it "does not decode invalid bip vectors" $ + mapM_ invalidVecTest invalidVec + it "encodes valid bip vecs" $ + mapM_ (uncurry encodeVecTest) validEncodeVec + it "decodes valid bip vecs" $ + mapM_ (uncurry decodeVecTest) $ zip [1..] validVec + it "decodes vector 2" vec2Test + it "decodes vector 3" vec3Test + it "decodes vector 4" vec4Test + it "decodes vector 5" vec5Test + it "decodes vector 6" vec6Test + it "signed and finalized p2pkh PSBTs verify" $ property $ + forAll arbitraryKeyPair $ verifyNonWitnessPSBT btc . unfinalizedPkhPSBT btc + it "signed and finalized multisig PSBTs verify" $ property $ + forAll arbitraryMultiSig $ verifyNonWitnessPSBT btc . unfinalizedMsPSBT btc + +vec2Test :: Assertion +vec2Test = do + psbt <- decodeHexPSBTM "Cannot parse validVec2" validVec2Hex + assertEqual "2 inputs" 2 (length $ inputs psbt) + assertEqual "2 outputs" 2 (length $ outputs psbt) + assertBool "final script sig" $ isJust (finalScriptSig . head $ inputs psbt) + + let rdmScript = fromJust . inputRedeemScript $ inputs psbt !! 1 + assertBool "p2wpkh" $ (isPayWitnessPKHash <$> decodeOutput rdmScript) == Right True + + let scrptPubKey = witnessScriptPubKey $ inputs psbt !! 1 + rdmScriptP2SH = toP2SH rdmScript + assertEqual "redeem script pubkey equal" rdmScriptP2SH scrptPubKey + assertEqual "expected redeem script" expectedOut rdmScriptP2SH + + mapM_ (assertEqual "outputs are empty" emptyOutput) (outputs psbt) + +vec3Test :: Assertion +vec3Test = do + psbt <- decodeHexPSBTM "Cannot parse validVec3" validVec3Hex + assertEqual "1 input" 1 (length $ inputs psbt) + assertEqual "2 outputs" 2 (length $ outputs psbt) + let txInput = head . txIn $ unsignedTransaction psbt + firstInput = head $ inputs psbt + Just utx = nonWitnessUtxo firstInput + OutPoint prevHash prevVOut = prevOutput txInput + assertEqual "txids of inputs match" prevHash (txHash utx) + let prevOutputKey = fromRight (error "Could not decode key") + . decodeOutputBS . scriptOutput $ txOut utx !! fromIntegral prevVOut + assertBool "p2pkh" $ isPayPKHash prevOutputKey + assertEqual "sighash type" sigHashAll (fromJust $ sigHashType firstInput) + +vec4Test :: Assertion +vec4Test = do + psbt <- decodeHexPSBTM "Cannot parse validVec4" validVec4Hex + assertEqual "2 inputs" 2 (length $ inputs psbt) + assertEqual "2 outputs" 2 (length $ outputs psbt) + let firstInput = head $ inputs psbt + secondInput = inputs psbt !! 1 + assertEqual "first input not final script sig" Nothing (finalScriptSig firstInput) + assertEqual "second input not final script sig" Nothing (finalScriptSig secondInput) + + let rdmScript = fromJust $ inputRedeemScript secondInput + assertBool "p2wpkh" $ (isPayWitnessPKHash <$> decodeOutput rdmScript) == Right True + + let scrptPubKey = witnessScriptPubKey secondInput + rdmScriptP2SH = toP2SH rdmScript + assertEqual "redeem script pubkey equal" rdmScriptP2SH scrptPubKey + assertEqual "expected redeem script" expectedOut rdmScriptP2SH + + assertBool "all non-empty outputs" $ emptyOutput `notElem` outputs psbt + +vec5Test :: Assertion +vec5Test = do + psbt <- decodeHexPSBTM "Cannot parse validVec5" validVec5Hex + assertEqual "1 input" 1 (length $ inputs psbt) + assertEqual "1 output" 1 (length $ outputs psbt) + let input = head $ inputs psbt + assertEqual "input not final script sig" Nothing (finalScriptSig input) + + let rdmScript = fromJust $ inputRedeemScript input + assertBool "p2wsh" $ (isPayWitnessScriptHash <$> decodeOutput rdmScript) == Right True + + let scrptPubKey = witnessScriptPubKey input + rdmScriptP2SH = toP2SH rdmScript + assertEqual "redeem script pubkey equal" rdmScriptP2SH scrptPubKey + assertEqual "expected redeem script" expectedOut2 rdmScriptP2SH + where + expectedOut2 = fromRight (error "could not decode expected output") + . decodeOutputBS . fromJust $ decodeHex "a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87" + +vec6Test :: Assertion +vec6Test = do + psbt <- decodeHexPSBTM "Cannot parse validVec6" validVec6Hex + assertEqual "1 input" 1 (length $ inputs psbt) + assertEqual "1 output" 1 (length $ outputs psbt) + + let tx = unsignedTransaction psbt + assertEqual "correct transaction" "75c5c9665a570569ad77dd1279e6fd4628a093c4dcbf8d41532614044c14c115" (txHash tx) + + assertEqual "correct unknowns" expectedUnknowns (inputUnknown . head $ inputs psbt) + where + expectedUnknowns = UnknownMap $ singleton + (Key 0x0f (fromJust $ decodeHex "010203040506070809")) + (fromJust $ decodeHex "0102030405060708090a0b0c0d0e0f") + +expectedOut :: ScriptOutput +expectedOut = fromRight (error "could not decode expected output") + . decodeOutputBS . fromJust $ decodeHex "a9143545e6e33b832c47050f24d3eeb93c9c03948bc787" + +witnessScriptPubKey :: Input -> ScriptOutput +witnessScriptPubKey = fromRight (error "could not decode witness utxo") + . decodeOutputBS . scriptOutput . 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 . S.decode . fromJust . decodeHex + where + encodeScript :: Script -> ByteString + encodeScript = S.encode + +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 + { unsignedTransaction = Tx { txVersion = 2, txIn = [], txOut = [], txWitness = [], txLockTime = 0 } + , globalUnknown = UnknownMap mempty + , inputs = [] + , outputs = [] + } + +trivialPSBTHex :: Text +trivialPSBTHex = "70736274ff01000a0200000000000000000000" + +nonEmptyTransactionPSBT :: PartiallySignedTransaction +nonEmptyTransactionPSBT = emptyPSBT testTx1 + +verifyNonWitnessPSBT :: Network -> PartiallySignedTransaction -> Bool +verifyNonWitnessPSBT net psbt = verifyStdTx net (finalTransaction (complete psbt)) sigData + where + sigData = inputSigData =<< zip (inputs psbt) (txIn $ unsignedTransaction psbt) + decodeOutScript = fromRight (error "Could not parse output script") . decodeOutputBS + inputSigData (input, txInput) = + map (\(TxOut val script) -> (decodeOutScript script, val, prevOutput txInput)) + (txOut . fromJust $ nonWitnessUtxo input) + +unfinalizedPkhPSBT :: Network -> (SecKeyI, PubKeyI) -> PartiallySignedTransaction +unfinalizedPkhPSBT net (prvKey, pubKey) = (emptyPSBT currTx) + { inputs = [ emptyInput { nonWitnessUtxo = Just prevTx, partialSigs = singleton pubKey sig } ] } + where + currTx = unfinalizedTx (txHash prevTx) + prevTx = testUtxo [prevOut] + prevOutScript = addressToScript (pubKeyAddr pubKey) + prevOut = TxOut { outValue = 200000000, scriptOutput = S.encode prevOutScript } + h = txSigHash net currTx prevOutScript (outValue prevOut) 0 sigHashAll + sig = encodeTxSig $ TxSignature (signHash (secKeyData prvKey) h) sigHashAll + +arbitraryMultiSig :: Gen ([(SecKeyI, PubKeyI)], Int) +arbitraryMultiSig = do + (m, n) <- arbitraryMSParam + keys <- vectorOf n arbitraryKeyPair + return (keys, m) + +unfinalizedMsPSBT :: Network -> ([(SecKeyI, PubKeyI)], Int) -> PartiallySignedTransaction +unfinalizedMsPSBT net (keys, m) = (emptyPSBT currTx) + { inputs = [ emptyInput { nonWitnessUtxo = Just prevTx, partialSigs = sigs + , inputRedeemScript = Just prevOutScript + } ] } + where + currTx = unfinalizedTx (txHash prevTx) + prevTx = testUtxo [prevOut] + prevOutScript = encodeOutput $ PayMulSig (map snd keys) m + prevOut = TxOut { outValue = 200000000, scriptOutput = encodeOutputBS (toP2SH prevOutScript) } + h = txSigHash net currTx prevOutScript (outValue prevOut) 0 sigHashAll + sigs = fromList $ map sig keys + sig (prvKey, pubKey) = (pubKey, encodeTxSig $ TxSignature (signHash (secKeyData prvKey) h) sigHashAll) + +unfinalizedTx :: TxHash -> Tx +unfinalizedTx prevHash = Tx + { txVersion = 2 + , txIn = [ TxIn + { prevOutput = OutPoint prevHash 0 + , scriptInput = "" + , txInSequence = 4294967294 + } ] + , txOut = + [ TxOut { outValue = 99999699, scriptOutput = hexScript "76a914d0c59903c5bac2868760e90fd521a4665aa7652088ac" } + , TxOut { outValue = 100000000, scriptOutput = hexScript "a9143545e6e33b832c47050f24d3eeb93c9c03948bc787" } + ] + , txWitness = [] + , txLockTime = 1257139 + } + +invalidVec :: [Text] +invalidVec = + [ "0200000001268171371edff285e937adeea4b37b78000c0566cbb3ad64641713ca42171bf6000000006a473044022070b2245123e6bf474d60c5b50c043d4c691a5d2435f09a34a7662a9dc251790a022001329ca9dacf280bdf30740ec0390422422c81cb45839457aeb76fc12edd95b3012102657d118d3357b8e0f4c2cd46db7b39f6d9c38d9a70abcb9b2de5dc8dbfe4ce31feffffff02d3dff505000000001976a914d0c59903c5bac2868760e90fd521a4665aa7652088ac00e1f5050000000017a9143545e6e33b832c47050f24d3eeb93c9c03948bc787b32e1300" + , "70736274ff0100750200000001268171371edff285e937adeea4b37b78000c0566cbb3ad64641713ca42171bf60000000000feffffff02d3dff505000000001976a914d0c59903c5bac2868760e90fd521a4665aa7652088ac00e1f5050000000017a9143545e6e33b832c47050f24d3eeb93c9c03948bc787b32e1300000100fda5010100000000010289a3c71eab4d20e0371bbba4cc698fa295c9463afa2e397f8533ccb62f9567e50100000017160014be18d152a9b012039daf3da7de4f53349eecb985ffffffff86f8aa43a71dff1448893a530a7237ef6b4608bbb2dd2d0171e63aec6a4890b40100000017160014fe3e9ef1a745e974d902c4355943abcb34bd5353ffffffff0200c2eb0b000000001976a91485cff1097fd9e008bb34af709c62197b38978a4888ac72fef84e2c00000017a914339725ba21efd62ac753a9bcd067d6c7a6a39d05870247304402202712be22e0270f394f568311dc7ca9a68970b8025fdd3b240229f07f8a5f3a240220018b38d7dcd314e734c9276bd6fb40f673325bc4baa144c800d2f2f02db2765c012103d2e15674941bad4a996372cb87e1856d3652606d98562fe39c5e9e7e413f210502483045022100d12b852d85dcd961d2f5f4ab660654df6eedcc794c0c33ce5cc309ffb5fce58d022067338a8e0e1725c197fb1a88af59f51e44e4255b20167c8684031c05d1f2592a01210223b72beef0965d10be0778efecd61fcac6f79a4ea169393380734464f84f2ab30000000000" + , "70736274ff0100fd0a010200000002ab0949a08c5af7c49b8212f417e2f15ab3f5c33dcf153821a8139f877a5b7be4000000006a47304402204759661797c01b036b25928948686218347d89864b719e1f7fcf57d1e511658702205309eabf56aa4d8891ffd111fdf1336f3a29da866d7f8486d75546ceedaf93190121035cdc61fc7ba971c0b501a646a2a83b102cb43881217ca682dc86e2d73fa88292feffffffab0949a08c5af7c49b8212f417e2f15ab3f5c33dcf153821a8139f877a5b7be40100000000feffffff02603bea0b000000001976a914768a40bbd740cbe81d988e71de2a4d5c71396b1d88ac8e240000000000001976a9146f4620b553fa095e721b9ee0efe9fa039cca459788ac00000000000001012000e1f5050000000017a9143545e6e33b832c47050f24d3eeb93c9c03948bc787010416001485d13537f2e265405a34dbafa9e3dda01fb82308000000" + , "70736274ff000100fda5010100000000010289a3c71eab4d20e0371bbba4cc698fa295c9463afa2e397f8533ccb62f9567e50100000017160014be18d152a9b012039daf3da7de4f53349eecb985ffffffff86f8aa43a71dff1448893a530a7237ef6b4608bbb2dd2d0171e63aec6a4890b40100000017160014fe3e9ef1a745e974d902c4355943abcb34bd5353ffffffff0200c2eb0b000000001976a91485cff1097fd9e008bb34af709c62197b38978a4888ac72fef84e2c00000017a914339725ba21efd62ac753a9bcd067d6c7a6a39d05870247304402202712be22e0270f394f568311dc7ca9a68970b8025fdd3b240229f07f8a5f3a240220018b38d7dcd314e734c9276bd6fb40f673325bc4baa144c800d2f2f02db2765c012103d2e15674941bad4a996372cb87e1856d3652606d98562fe39c5e9e7e413f210502483045022100d12b852d85dcd961d2f5f4ab660654df6eedcc794c0c33ce5cc309ffb5fce58d022067338a8e0e1725c197fb1a88af59f51e44e4255b20167c8684031c05d1f2592a01210223b72beef0965d10be0778efecd61fcac6f79a4ea169393380734464f84f2ab30000000000" + , "70736274ff0100750200000001268171371edff285e937adeea4b37b78000c0566cbb3ad64641713ca42171bf60000000000feffffff02d3dff505000000001976a914d0c59903c5bac2868760e90fd521a4665aa7652088ac00e1f5050000000017a9143545e6e33b832c47050f24d3eeb93c9c03948bc787b32e1300000100fda5010100000000010289a3c71eab4d20e0371bbba4cc698fa295c9463afa2e397f8533ccb62f9567e50100000017160014be18d152a9b012039daf3da7de4f53349eecb985ffffffff86f8aa43a71dff1448893a530a7237ef6b4608bbb2dd2d0171e63aec6a4890b40100000017160014fe3e9ef1a745e974d902c4355943abcb34bd5353ffffffff0200c2eb0b000000001976a91485cff1097fd9e008bb34af709c62197b38978a4888ac72fef84e2c00000017a914339725ba21efd62ac753a9bcd067d6c7a6a39d05870247304402202712be22e0270f394f568311dc7ca9a68970b8025fdd3b240229f07f8a5f3a240220018b38d7dcd314e734c9276bd6fb40f673325bc4baa144c800d2f2f02db2765c012103d2e15674941bad4a996372cb87e1856d3652606d98562fe39c5e9e7e413f210502483045022100d12b852d85dcd961d2f5f4ab660654df6eedcc794c0c33ce5cc309ffb5fce58d022067338a8e0e1725c197fb1a88af59f51e44e4255b20167c8684031c05d1f2592a01210223b72beef0965d10be0778efecd61fcac6f79a4ea169393380734464f84f2ab30000000001003f0200000001ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff0000000000ffffffff010000000000000000036a010000000000000000" + , "70736274ff020001550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac0000000000010120955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87220203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4646304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a010104220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681010547522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae220603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4610b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000" + , "70736274ff0100550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac000000000002010020955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87220203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4646304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a010104220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681010547522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae220603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4610b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000" + , "70736274ff0100550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac0000000000010120955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87210203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd46304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a010104220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681010547522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae220603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4610b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000" + , "70736274ff0100550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac0000000000010120955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87220203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4646304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a01020400220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681010547522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae220603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4610b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000" + , "70736274ff0100550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac0000000000010120955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87220203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4646304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a010104220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d568102050047522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae220603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4610b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000" + , "70736274ff0100550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac0000000000010120955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87220203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4646304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a010104220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681010547522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae210603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd10b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000" + , "70736274ff01009a020000000258e87a21b56daf0c23be8e7070456c336f7cbaa5c8757924f545887bb2abdd750000000000ffffffff838d0427d0ec650a68aa46bb0b098aea4422c071b2ca78352a077959d07cea1d0100000000ffffffff0270aaf00800000000160014d85c2b71d0060b09c9886aeb815e50991dda124d00e1f5050000000016001400aea9a2e5f0f876a588df5546e8742d1d87008f0000000000020000bb0200000001aad73931018bd25f84ae400b68848be09db706eac2ac18298babee71ab656f8b0000000048473044022058f6fc7c6a33e1b31548d481c826c015bd30135aad42cd67790dab66d2ad243b02204a1ced2604c6735b6393e5b41691dd78b00f0c5942fb9f751856faa938157dba01feffffff0280f0fa020000000017a9140fb9463421696b82c833af241c78c17ddbde493487d0f20a270100000017a91429ca74f8a08f81999428185c97b5d852e4063f6187650000000107da00473044022074018ad4180097b873323c0015720b3684cc8123891048e7dbcd9b55ad679c99022073d369b740e3eb53dcefa33823c8070514ca55a7dd9544f157c167913261118c01483045022100f61038b308dc1da865a34852746f015772934208c6d24454393cd99bdf2217770220056e675a675a6d0a02b85b14e5e29074d8a25a9b5760bea2816f661910a006ea01475221029583bf39ae0a609747ad199addd634fa6108559d6c5cd39b4c2183f1ab96e07f2102dab61ff49a14db6a7d02b0cd1fbb78fc4b18312b5b4e54dae4dba2fbfef536d752ae0001012000c2eb0b0000000017a914b7f5faf40e3d40a5a459b1db3535f2b72fa921e8870107232200208c2353173743b595dfb4a07b72ba8e42e3797da74e87fe7d9d7497e3b20289030108da0400473044022062eb7a556107a7c73f45ac4ab5a1dddf6f7075fb1275969a7f383efff784bcb202200c05dbb7470dbf2f08557dd356c7325c1ed30913e996cd3840945db12228da5f01473044022065f45ba5998b59a27ffe1a7bed016af1f1f90d54b3aa8f7450aa5f56a25103bd02207f724703ad1edb96680b284b56d4ffcb88f7fb759eabbe08aa30f29b851383d20147522103089dc10c7ac6db54f91329af617333db388cead0c231f723379d1b99030b02dc21023add904f3d6dcf59ddb906b0dee23529b7ffb9ed50e5e86151926860221f0e7352ae00220203a9a4c37f5996d3aa25dbac6b570af0650394492942460b354753ed9eeca5877110d90c6a4f000000800000008004000080002202027f6399757d2eff55a136ad02c684b1838b6556e5f1b6b34282a94b6b5005109610d90c6a4f00000080000000800500008000" + , "70736274ff01009a020000000258e87a21b56daf0c23be8e7070456c336f7cbaa5c8757924f545887bb2abdd750000000000ffffffff838d0427d0ec650a68aa46bb0b098aea4422c071b2ca78352a077959d07cea1d0100000000ffffffff0270aaf00800000000160014d85c2b71d0060b09c9886aeb815e50991dda124d00e1f5050000000016001400aea9a2e5f0f876a588df5546e8742d1d87008f00000000000100bb0200000001aad73931018bd25f84ae400b68848be09db706eac2ac18298babee71ab656f8b0000000048473044022058f6fc7c6a33e1b31548d481c826c015bd30135aad42cd67790dab66d2ad243b02204a1ced2604c6735b6393e5b41691dd78b00f0c5942fb9f751856faa938157dba01feffffff0280f0fa020000000017a9140fb9463421696b82c833af241c78c17ddbde493487d0f20a270100000017a91429ca74f8a08f81999428185c97b5d852e4063f618765000000020700da00473044022074018ad4180097b873323c0015720b3684cc8123891048e7dbcd9b55ad679c99022073d369b740e3eb53dcefa33823c8070514ca55a7dd9544f157c167913261118c01483045022100f61038b308dc1da865a34852746f015772934208c6d24454393cd99bdf2217770220056e675a675a6d0a02b85b14e5e29074d8a25a9b5760bea2816f661910a006ea01475221029583bf39ae0a609747ad199addd634fa6108559d6c5cd39b4c2183f1ab96e07f2102dab61ff49a14db6a7d02b0cd1fbb78fc4b18312b5b4e54dae4dba2fbfef536d752ae0001012000c2eb0b0000000017a914b7f5faf40e3d40a5a459b1db3535f2b72fa921e8870107232200208c2353173743b595dfb4a07b72ba8e42e3797da74e87fe7d9d7497e3b20289030108da0400473044022062eb7a556107a7c73f45ac4ab5a1dddf6f7075fb1275969a7f383efff784bcb202200c05dbb7470dbf2f08557dd356c7325c1ed30913e996cd3840945db12228da5f01473044022065f45ba5998b59a27ffe1a7bed016af1f1f90d54b3aa8f7450aa5f56a25103bd02207f724703ad1edb96680b284b56d4ffcb88f7fb759eabbe08aa30f29b851383d20147522103089dc10c7ac6db54f91329af617333db388cead0c231f723379d1b99030b02dc21023add904f3d6dcf59ddb906b0dee23529b7ffb9ed50e5e86151926860221f0e7352ae00220203a9a4c37f5996d3aa25dbac6b570af0650394492942460b354753ed9eeca5877110d90c6a4f000000800000008004000080002202027f6399757d2eff55a136ad02c684b1838b6556e5f1b6b34282a94b6b5005109610d90c6a4f00000080000000800500008000" + , "70736274ff01009a020000000258e87a21b56daf0c23be8e7070456c336f7cbaa5c8757924f545887bb2abdd750000000000ffffffff838d0427d0ec650a68aa46bb0b098aea4422c071b2ca78352a077959d07cea1d0100000000ffffffff0270aaf00800000000160014d85c2b71d0060b09c9886aeb815e50991dda124d00e1f5050000000016001400aea9a2e5f0f876a588df5546e8742d1d87008f00000000000100bb0200000001aad73931018bd25f84ae400b68848be09db706eac2ac18298babee71ab656f8b0000000048473044022058f6fc7c6a33e1b31548d481c826c015bd30135aad42cd67790dab66d2ad243b02204a1ced2604c6735b6393e5b41691dd78b00f0c5942fb9f751856faa938157dba01feffffff0280f0fa020000000017a9140fb9463421696b82c833af241c78c17ddbde493487d0f20a270100000017a91429ca74f8a08f81999428185c97b5d852e4063f6187650000000107da00473044022074018ad4180097b873323c0015720b3684cc8123891048e7dbcd9b55ad679c99022073d369b740e3eb53dcefa33823c8070514ca55a7dd9544f157c167913261118c01483045022100f61038b308dc1da865a34852746f015772934208c6d24454393cd99bdf2217770220056e675a675a6d0a02b85b14e5e29074d8a25a9b5760bea2816f661910a006ea01475221029583bf39ae0a609747ad199addd634fa6108559d6c5cd39b4c2183f1ab96e07f2102dab61ff49a14db6a7d02b0cd1fbb78fc4b18312b5b4e54dae4dba2fbfef536d752ae0001012000c2eb0b0000000017a914b7f5faf40e3d40a5a459b1db3535f2b72fa921e8870107232200208c2353173743b595dfb4a07b72ba8e42e3797da74e87fe7d9d7497e3b2028903020800da0400473044022062eb7a556107a7c73f45ac4ab5a1dddf6f7075fb1275969a7f383efff784bcb202200c05dbb7470dbf2f08557dd356c7325c1ed30913e996cd3840945db12228da5f01473044022065f45ba5998b59a27ffe1a7bed016af1f1f90d54b3aa8f7450aa5f56a25103bd02207f724703ad1edb96680b284b56d4ffcb88f7fb759eabbe08aa30f29b851383d20147522103089dc10c7ac6db54f91329af617333db388cead0c231f723379d1b99030b02dc21023add904f3d6dcf59ddb906b0dee23529b7ffb9ed50e5e86151926860221f0e7352ae00220203a9a4c37f5996d3aa25dbac6b570af0650394492942460b354753ed9eeca5877110d90c6a4f000000800000008004000080002202027f6399757d2eff55a136ad02c684b1838b6556e5f1b6b34282a94b6b5005109610d90c6a4f00000080000000800500008000" + , "70736274ff01009a020000000258e87a21b56daf0c23be8e7070456c336f7cbaa5c8757924f545887bb2abdd750000000000ffffffff838d0427d0ec650a68aa46bb0b098aea4422c071b2ca78352a077959d07cea1d0100000000ffffffff0270aaf00800000000160014d85c2b71d0060b09c9886aeb815e50991dda124d00e1f5050000000016001400aea9a2e5f0f876a588df5546e8742d1d87008f00000000000100bb0200000001aad73931018bd25f84ae400b68848be09db706eac2ac18298babee71ab656f8b0000000048473044022058f6fc7c6a33e1b31548d481c826c015bd30135aad42cd67790dab66d2ad243b02204a1ced2604c6735b6393e5b41691dd78b00f0c5942fb9f751856faa938157dba01feffffff0280f0fa020000000017a9140fb9463421696b82c833af241c78c17ddbde493487d0f20a270100000017a91429ca74f8a08f81999428185c97b5d852e4063f6187650000000107da00473044022074018ad4180097b873323c0015720b3684cc8123891048e7dbcd9b55ad679c99022073d369b740e3eb53dcefa33823c8070514ca55a7dd9544f157c167913261118c01483045022100f61038b308dc1da865a34852746f015772934208c6d24454393cd99bdf2217770220056e675a675a6d0a02b85b14e5e29074d8a25a9b5760bea2816f661910a006ea01475221029583bf39ae0a609747ad199addd634fa6108559d6c5cd39b4c2183f1ab96e07f2102dab61ff49a14db6a7d02b0cd1fbb78fc4b18312b5b4e54dae4dba2fbfef536d752ae0001012000c2eb0b0000000017a914b7f5faf40e3d40a5a459b1db3535f2b72fa921e8870107232200208c2353173743b595dfb4a07b72ba8e42e3797da74e87fe7d9d7497e3b20289030108da0400473044022062eb7a556107a7c73f45ac4ab5a1dddf6f7075fb1275969a7f383efff784bcb202200c05dbb7470dbf2f08557dd356c7325c1ed30913e996cd3840945db12228da5f01473044022065f45ba5998b59a27ffe1a7bed016af1f1f90d54b3aa8f7450aa5f56a25103bd02207f724703ad1edb96680b284b56d4ffcb88f7fb759eabbe08aa30f29b851383d20147522103089dc10c7ac6db54f91329af617333db388cead0c231f723379d1b99030b02dc21023add904f3d6dcf59ddb906b0dee23529b7ffb9ed50e5e86151926860221f0e7352ae00210203a9a4c37f5996d3aa25dbac6b570af0650394492942460b354753ed9eeca58710d90c6a4f000000800000008004000080002202027f6399757d2eff55a136ad02c684b1838b6556e5f1b6b34282a94b6b5005109610d90c6a4f00000080000000800500008000" + , "70736274ff0100730200000001301ae986e516a1ec8ac5b4bc6573d32f83b465e23ad76167d68b38e730b4dbdb0000000000ffffffff02747b01000000000017a91403aa17ae882b5d0d54b25d63104e4ffece7b9ea2876043993b0000000017a914b921b1ba6f722e4bfa83b6557a3139986a42ec8387000000000001011f00ca9a3b00000000160014d2d94b64ae08587eefc8eeb187c601e939f9037c0203000100000000010016001462e9e982fff34dd8239610316b090cd2a3b747cb000100220020876bad832f1d168015ed41232a9ea65a1815d9ef13c0ef8759f64b5b2b278a65010125512103b7ce23a01c5b4bf00a642537cdfabb315b668332867478ef51309d2bd57f8a8751ae00" + , "70736274ff0100730200000001301ae986e516a1ec8ac5b4bc6573d32f83b465e23ad76167d68b38e730b4dbdb0000000000ffffffff02747b01000000000017a91403aa17ae882b5d0d54b25d63104e4ffece7b9ea2876043993b0000000017a914b921b1ba6f722e4bfa83b6557a3139986a42ec8387000000000001011f00ca9a3b00000000160014d2d94b64ae08587eefc8eeb187c601e939f9037c0002000016001462e9e982fff34dd8239610316b090cd2a3b747cb000100220020876bad832f1d168015ed41232a9ea65a1815d9ef13c0ef8759f64b5b2b278a65010125512103b7ce23a01c5b4bf00a642537cdfabb315b668332867478ef51309d2bd57f8a8751ae00" + , "70736274ff0100730200000001301ae986e516a1ec8ac5b4bc6573d32f83b465e23ad76167d68b38e730b4dbdb0000000000ffffffff02747b01000000000017a91403aa17ae882b5d0d54b25d63104e4ffece7b9ea2876043993b0000000017a914b921b1ba6f722e4bfa83b6557a3139986a42ec8387000000000001011f00ca9a3b00000000160014d2d94b64ae08587eefc8eeb187c601e939f9037c00010016001462e9e982fff34dd8239610316b090cd2a3b747cb000100220020876bad832f1d168015ed41232a9ea65a1815d9ef13c0ef8759f64b5b2b278a6521010025512103b7ce23a01c5b4bf00a642537cdfabb315b668332867478ef51309d2bd57f8a8751ae00" + ] + + +validEncodeVec :: [(PartiallySignedTransaction, Text)] +validEncodeVec = [(validVec1, validVec1Hex)] + +testTx1 :: Tx +testTx1 = Tx + { txVersion = 2 + , txIn = [ TxIn + { prevOutput = OutPoint "f61b1742ca13176464adb3cb66050c00787bb3a4eead37e985f2df1e37718126" 0 + , scriptInput = "" + , txInSequence = 4294967294 + } ] + , txOut = + [ TxOut { outValue = 99999699, scriptOutput = hexScript "76a914d0c59903c5bac2868760e90fd521a4665aa7652088ac" } + , TxOut { outValue = 100000000, scriptOutput = hexScript "a9143545e6e33b832c47050f24d3eeb93c9c03948bc787" } + ] + , txWitness = [] + , txLockTime = 1257139 + } + +testUtxo :: [TxOut] -> Tx +testUtxo prevOuts = Tx + { txVersion = 1 + , txIn = + [ TxIn + { prevOutput = OutPoint "e567952fb6cc33857f392efa3a46c995a28f69cca4bb1b37e0204dab1ec7a389" 1 + , scriptInput = hexScript "160014be18d152a9b012039daf3da7de4f53349eecb985" + , txInSequence = 4294967295 + } + , TxIn + { prevOutput = OutPoint "b490486aec3ae671012dddb2bb08466bef37720a533a894814ff1da743aaf886" 1 + , scriptInput = hexScript "160014fe3e9ef1a745e974d902c4355943abcb34bd5353" + , txInSequence = 4294967295 + } + ] + , txOut = prevOuts + , txWitness = + [ + [ fromJust $ decodeHex "304402202712be22e0270f394f568311dc7ca9a68970b8025fdd3b240229f07f8a5f3a240220018b38d7dcd314e734c9276bd6fb40f673325bc4baa144c800d2f2f02db2765c01" + , fromJust $ decodeHex "03d2e15674941bad4a996372cb87e1856d3652606d98562fe39c5e9e7e413f2105" + ] + , [ fromJust $ decodeHex "3045022100d12b852d85dcd961d2f5f4ab660654df6eedcc794c0c33ce5cc309ffb5fce58d022067338a8e0e1725c197fb1a88af59f51e44e4255b20167c8684031c05d1f2592a01" + , fromJust $ decodeHex "0223b72beef0965d10be0778efecd61fcac6f79a4ea169393380734464f84f2ab3" + ] + ] + , txLockTime = 0 + } + +testUtxo1 :: Tx +testUtxo1 = testUtxo + [ TxOut { outValue = 200000000, scriptOutput = hexScript "76a91485cff1097fd9e008bb34af709c62197b38978a4888ac" } + , 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" diff --git a/test/Haskoin/TransactionSpec.hs b/test/Haskoin/TransactionSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/TransactionSpec.hs @@ -0,0 +1,396 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Haskoin.TransactionSpec (spec) where + +import Data.Aeson as A +import qualified Data.ByteString as B +import Data.Either +import Data.Map.Strict (singleton) +import Data.Maybe +import Data.Serialize as S +import Data.String (fromString) +import Data.String.Conversions +import Data.Text (Text) +import Data.Word (Word32, Word64) +import Haskoin.Address +import Haskoin.Constants +import Haskoin.Keys +import Haskoin.Script +import Haskoin.Test +import Haskoin.Transaction +import Haskoin.Transaction.Segwit (isSegwit) +import Haskoin.Util +import Safe (readMay) +import Test.Hspec +import Test.HUnit (Assertion, assertBool) +import Test.QuickCheck + +spec :: Spec +spec = do + let net = btc + describe "transaction unit tests" $ do + it "compute txid from tx" $ + mapM_ runTxIDVec txIDVec + it "build pkhash transaction (generated from bitcoind)" $ + mapM_ runPKHashVec pkHashVec + it "encode satoshi core script pubkey" tEncodeSatoshiCoreScriptPubKey + -- + -- These tests depend on signatures matching exactly those in the spec. + -- Fedora includes a version of libsecp256k1 that computes signatures + -- using a slighlty different deterministic nonce algorithm. + -- + -- it "agrees with BIP143 p2wpkh example" testBip143p2wpkh + -- it "agrees with BIP143 p2sh-p2wpkh example" testBip143p2shp2wpkh + -- it "builds a p2wsh multisig transaction" testP2WSHMulsig + -- it "agrees with BIP143 p2sh-p2wsh multisig example" testBip143p2shp2wpkhMulsig + describe "btc transaction" $ do + it "decode and encode txid" $ + property $ + forAll arbitraryTxHash $ \h -> hexToTxHash (txHashToHex h) == Just h + it "from string transaction id" $ + property $ + forAll arbitraryTxHash $ \h -> fromString (cs $ txHashToHex h) == h + it "building address tx" $ + property $ + forAll arbitraryAddress $ + forAll (arbitrarySatoshi net) . testBuildAddrTx net + it "guess transaction size" $ + property $ forAll (arbitraryAddrOnlyTxFull net) (testGuessSize net) + it "choose coins" $ + property $ forAll (listOf (arbitrarySatoshi net)) testChooseCoins + it "choose multisig coins" $ + property $ + forAll arbitraryMSParam $ + forAll (listOf (arbitrarySatoshi net)) . testChooseMSCoins + it "sign and validate transaction" $ + property $ forAll (arbitrarySigningData net) (testDetSignTx net) + it "sign and validate (nested) transaction" $ + property $ forAll (arbitrarySigningData net) (testDetSignNestedTx net) + it "merge partially signed transactions" $ + property $ forAll (arbitraryPartialTxs net) (testMergeTx net) + describe "json serialization" $ do + it "encodes and decodes transaction" $ + property $ forAll (arbitraryTx net) testID + it "encodes and decodes transaction hash" $ + property $ forAll arbitraryTxHash testID + describe "transaction serialization" $ do + it "encodes and decodes tx input" $ + property $ forAll (arbitraryTxIn net) cerealID + it "encodes and decodes tx output" $ + property $ forAll (arbitraryTxOut net) cerealID + it "encodes and decodes outpoint" $ + property $ forAll arbitraryOutPoint cerealID + it "encodes and decodes transaction" $ + property $ forAll (arbitraryTx net) cerealID + it "encodes and decodes witness transaction" $ + property $ forAll (arbitraryWitnessTx net) cerealID + it "encodes and decodes legacy transaction" $ + property $ forAll (arbitraryLegacyTx net) cerealID + +cerealID :: (Serialize a, Eq a) => a -> Bool +cerealID x = S.decode (S.encode x) == Right x + +runTxIDVec :: (Text, Text) -> Assertion +runTxIDVec (tid, tx) = assertBool "txid" $ txHashToHex (txHash txBS) == tid + where + txBS = fromJust $ either (const Nothing) return . S.decode =<< decodeHex tx + +txIDVec :: [(Text, Text)] +txIDVec = + [ ( "23b397edccd3740a74adb603c9756370fafcde9bcc4483eb271ecad09a94dd63" + , "0100000001b14bdcbc3e01bdaad36cc08e81e69c82e1060bc14e518db2b49aa43ad90ba26000000000490047304402203f16c6f40162ab686621ef3000b04e75418a0c0cb2d8aebeac894ae360ac1e780220ddc15ecdfc3507ac48e1681a33eb60996631bf6bf5bc0a0682c4db743ce7ca2b01ffffffff0140420f00000000001976a914660d4ef3a743e3e696ad990364e555c271ad504b88ac00000000" + ) + , ( "c99c49da4c38af669dea436d3e73780dfdb6c1ecf9958baa52960e8baee30e73" + , "01000000010276b76b07f4935c70acf54fbf1f438a4c397a9fb7e633873c4dd3bc062b6b40000000008c493046022100d23459d03ed7e9511a47d13292d3430a04627de6235b6e51a40f9cd386f2abe3022100e7d25b080f0bb8d8d5f878bba7d54ad2fda650ea8d158a33ee3cbd11768191fd004104b0e2c879e4daf7b9ab68350228c159766676a14f5815084ba166432aab46198d4cca98fa3e9981d0a90b2effc514b76279476550ba3663fdcaff94c38420e9d5000000000100093d00000000001976a9149a7b0f3b80c6baaeedce0a0842553800f832ba1f88ac00000000" + ) + , ( "f7fdd091fa6d8f5e7a8c2458f5c38faffff2d3f1406b6e4fe2c99dcc0d2d1cbb" + , "01000000023d6cf972d4dff9c519eff407ea800361dd0a121de1da8b6f4138a2f25de864b4000000008a4730440220ffda47bfc776bcd269da4832626ac332adfca6dd835e8ecd83cd1ebe7d709b0e022049cffa1cdc102a0b56e0e04913606c70af702a1149dc3b305ab9439288fee090014104266abb36d66eb4218a6dd31f09bb92cf3cfa803c7ea72c1fc80a50f919273e613f895b855fb7465ccbc8919ad1bd4a306c783f22cd3227327694c4fa4c1c439affffffff21ebc9ba20594737864352e95b727f1a565756f9d365083eb1a8596ec98c97b7010000008a4730440220503ff10e9f1e0de731407a4a245531c9ff17676eda461f8ceeb8c06049fa2c810220c008ac34694510298fa60b3f000df01caa244f165b727d4896eb84f81e46bcc4014104266abb36d66eb4218a6dd31f09bb92cf3cfa803c7ea72c1fc80a50f919273e613f895b855fb7465ccbc8919ad1bd4a306c783f22cd3227327694c4fa4c1c439affffffff01f0da5200000000001976a914857ccd42dded6df32949d4646dfa10a92458cfaa88ac00000000" + ) + , ( "afd9c17f8913577ec3509520bd6e5d63e9c0fd2a5f70c787993b097ba6ca9fae" + , "010000000370ac0a1ae588aaf284c308d67ca92c69a39e2db81337e563bf40c59da0a5cf63000000006a4730440220360d20baff382059040ba9be98947fd678fb08aab2bb0c172efa996fd8ece9b702201b4fb0de67f015c90e7ac8a193aeab486a1f587e0f54d0fb9552ef7f5ce6caec032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff7d815b6447e35fbea097e00e028fb7dfbad4f3f0987b4734676c84f3fcd0e804010000006b483045022100c714310be1e3a9ff1c5f7cacc65c2d8e781fc3a88ceb063c6153bf950650802102200b2d0979c76e12bb480da635f192cc8dc6f905380dd4ac1ff35a4f68f462fffd032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff3f1f097333e4d46d51f5e77b53264db8f7f5d2e18217e1099957d0f5af7713ee010000006c493046022100b663499ef73273a3788dea342717c2640ac43c5a1cf862c9e09b206fcb3f6bb8022100b09972e75972d9148f2bdd462e5cb69b57c1214b88fc55ca638676c07cfc10d8032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff0380841e00000000001976a914bfb282c70c4191f45b5a6665cad1682f2c9cfdfb88ac80841e00000000001976a9149857cc07bed33a5cf12b9c5e0500b675d500c81188ace0fd1c00000000001976a91443c52850606c872403c0601e69fa34b26f62db4a88ac00000000" + ) + ] + +runPKHashVec :: ([(Text, Word32)], [(Text, Word64)], Text) -> Assertion +runPKHashVec (xs, ys, res) = + assertBool "Build PKHash Tx" $ encodeHex (S.encode tx) == res + where + tx = + fromRight (error "Could not decode transaction") $ + buildAddrTx btc (map f xs) ys + f (tid, ix) = OutPoint (fromJust $ hexToTxHash tid) ix + +-- These test vectors have been generated from bitcoind raw transaction api + +pkHashVec :: [([(Text, Word32)], [(Text, Word64)], Text)] +pkHashVec = + [ + ( [("eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db",14)] + , [("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb",90000000)] + , "0100000001db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654a1eb29eb0e00000000ffffffff01804a5d05000000001976a91424aa604689cc582292b97668bedd91dd5bf9374c88ac00000000" + ) + , ( [ ("eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db",0) + , ("0001000000000000000000000000000000000000000000000000000000000000",2147483647) + ] + , [ ("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb",1) + , ("19VCgS642vzEA1sdByoSn6GsWBwraV8D4n",2100000000000000) + ] + , "0100000002db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654a1eb29eb0000000000ffffffff0000000000000000000000000000000000000000000000000000000000000100ffffff7f00ffffffff0201000000000000001976a91424aa604689cc582292b97668bedd91dd5bf9374c88ac0040075af07507001976a9145d16672f53981ff21c5f42b40d1954993cbca54f88ac00000000" + ) + , ( [ ("eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db",0) + , ("0001000000000000000000000000000000000000000000000000000000000000",2147483647) + ] + , [] + , "0100000002db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654a1eb29eb0000000000ffffffff0000000000000000000000000000000000000000000000000000000000000100ffffff7f00ffffffff0000000000" + ) + , ( [] + , [ ("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb",1) + , ("19VCgS642vzEA1sdByoSn6GsWBwraV8D4n",2100000000000000) + ] + , "01000000000201000000000000001976a91424aa604689cc582292b97668bedd91dd5bf9374c88ac0040075af07507001976a9145d16672f53981ff21c5f42b40d1954993cbca54f88ac00000000" + ) + ] + +tEncodeSatoshiCoreScriptPubKey :: Assertion +tEncodeSatoshiCoreScriptPubKey = assertBool "tEncodeSatoshiCoreScriptPubKey" $ + t1BsOutputScriptPubKey == encodeSatoshiCoreScriptPubKey t1SatoshiCoreJsonScriptPubKey + where + t1BsOutputScriptPubKey :: Text + t1BsOutputScriptPubKey = "514104cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef58bbfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d11fcdd0d348ac4410461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2fcfdeb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39f58b25c15342af52ae" + t1SatoshiCoreJsonScriptPubKey :: String + t1SatoshiCoreJsonScriptPubKey = "1 0x41 0x04cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef58bbfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d11fcdd0d348ac4 0x41 0x0461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2fcfdeb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39f58b25c15342af 2 OP_CHECKMULTISIG" + +encodeSatoshiCoreScriptPubKey :: String -> Text +encodeSatoshiCoreScriptPubKey = + mconcat . map encodeSatoshiCoreScriptPiece . words + where + encodeSatoshiCoreScriptPiece :: String -> Text + encodeSatoshiCoreScriptPiece s = case (readMay ("OP_" ++ s) :: Maybe ScriptOp) of + Just op -> encodeHex . S.encode $ op + Nothing -> case take 2 s of + "OP" -> encodeHex . S.encode . (read :: String -> ScriptOp) $ s + "0x" -> (fromString . drop 2 :: String -> Text) s + _ -> case (readMay s :: Maybe Int) of -- can we get rid of this case now? + Just i -> encodeHex . S.encode . intToScriptOp $ i + Nothing -> error $ "encodeSatoshiCoreScriptPubKey: " ++ s + +-- +-- Following tests depend on specific secp256k1 deterministic nonce computation. +-- Fedora distributes the Bitcoin ABC fork of this library, which computes nonces differently. +-- + +-- -- Reproduce the P2WPKH example from BIP 143 +-- testBip143p2wpkh :: Assertion +-- testBip143p2wpkh = assertEqual "BIP143 p2wpkh" (Right exampleSignedTx) generatedSignedTx +-- where +-- exampleSignedTx = "01000000000102fff7f7881a8099afa6940d42d1e7f6362bec38171ea3edf433541db4e4ad969f00000000494830450221008b9d1dc26ba6a9cb62127b02742fa9d754cd3bebf337f7a55d114c8e5cdd30be022040529b194ba3f9281a99f2b1c0a19c0489bc22ede944ccf4ecbab4cc618ef3ed01eeffffffef51e1b804cc89d182d279655c3aa89e815b1b309fe287d9b2b55d57b90ec68a0100000000ffffffff02202cb206000000001976a9148280b37df378db99f66f85c95a783a76ac7a6d5988ac9093510d000000001976a9143bde42dbee7e4dbe6a21b2d50ce2f0167faa815988ac000247304402203609e17b84f6a7d30c80bfa610b5b4542f32a8a0d5447a12fb1366d7f01cc44a0220573a954c4518331561406f90300e8f3358f51928d43c212a8caed02de67eebee0121025476c2e83188368da1ff3e292e7acafcdb3566bb0ad253f62fc70f07aeee635711000000" + +-- unsignedTx = "0100000002fff7f7881a8099afa6940d42d1e7f6362bec38171ea3edf433541db4e4ad969f0000000000eeffffffef51e1b804cc89d182d279655c3aa89e815b1b309fe287d9b2b55d57b90ec68a0100000000ffffffff02202cb206000000001976a9148280b37df378db99f66f85c95a783a76ac7a6d5988ac9093510d000000001976a9143bde42dbee7e4dbe6a21b2d50ce2f0167faa815988ac11000000" + +-- Just key0 = secHexKey "bbc27228ddcb9209d7fd6f36b02f7dfa6252af40bb2f1cbc7a557da8027ff866" +-- pubKey0 = toPubKey key0 + +-- Just key1 = secHexKey "619c335025c7f4012e556c2a58b2506e30b8511b53ade95ea316fd8c3286feb9" + +-- [op0, op1] = prevOutput <$> txIn unsignedTx + +-- sigIn0 = SigInput (PayPK pubKey0) 625000000 op0 sigHashAll Nothing + +-- WitnessPubKeyAddress h = pubKeyWitnessAddr $ toPubKey key1 +-- 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 = assertEqual "BIP143 p2sh-p2wpkh" (Right exampleSignedTx) generatedSignedTx +-- where +-- exampleSignedTx = "01000000000101db6b1b20aa0fd7b23880be2ecbd4a98130974cf4748fb66092ac4d3ceb1a5477010000001716001479091972186c449eb1ded22b78e40d009bdf0089feffffff02b8b4eb0b000000001976a914a457b684d7f0d539a46a45bbc043f35b59d0d96388ac0008af2f000000001976a914fd270b1ee6abcaea97fea7ad0402e8bd8ad6d77c88ac02473044022047ac8e878352d3ebbde1c94ce3a10d057c24175747116f8288e5d794d12d482f0220217f36a485cae903c713331d877c1f64677e3622ad4010726870540656fe9dcb012103ad1d8e89212f0b92c74d23bb710c00662ad1470198ac48c43f7d6f93a2a2687392040000" + +-- unsignedTx = "0100000001db6b1b20aa0fd7b23880be2ecbd4a98130974cf4748fb66092ac4d3ceb1a54770100000000feffffff02b8b4eb0b000000001976a914a457b684d7f0d539a46a45bbc043f35b59d0d96388ac0008af2f000000001976a914fd270b1ee6abcaea97fea7ad0402e8bd8ad6d77c88ac92040000" + +-- Just key0 = secHexKey "eb696a065ef48a2192da5b28b694f87544b30fae8327c4510137a922f32c6dcf" + +-- op0 = prevOutput . head $ txIn unsignedTx +-- WitnessPubKeyAddress h = pubKeyWitnessAddr $ toPubKey key0 +-- 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 = assertEqual "p2wsh multisig" (Right exampleSignedTx) generatedSignedTx +-- where +-- exampleSignedTx = "01000000000101d2e34df5d7ee565208eddd231548916b9b0e99f4f5071f896134a448c5fb07bf0100000000ffffffff01f0b9f505000000001976a9143d5a352cab583b12fbcb26d1269b4a2c951a33ad88ac0400483045022100fad4fedd2bb4c439c64637eb8e9150d9020a7212808b8dc0578d5ff5b4ad65fe0220714640f261b37eb3106310bf853f4b706e51436fb6b64c2ab00768814eb55b9801473044022100baff4e4ceea4022b9725a2e6f6d77997a554f858165b91ac8c16c9833008bee9021f5f70ebc3f8580dc0a5e96451e3697bdf1f1f5883944f0f33ab0cfb272354040169522102ba46d3bb8db74c77c6cf082db57fc0548058fcdea811549e186526e3d10caf6721038ac8aef2dd9cea5e7d66e2f6e23f177a6c21f69ea311fa0c85d81badb6b37ceb2103d96d2bfbbc040faaf93491d69e2bfe9695e2d8e007a7f26db96c2ee42db15dc953ae00000000" + +-- unsignedTx = "0100000001d2e34df5d7ee565208eddd231548916b9b0e99f4f5071f896134a448c5fb07bf0100000000ffffffff01f0b9f505000000001976a9143d5a352cab583b12fbcb26d1269b4a2c951a33ad88ac00000000" + +-- op0 = head $ prevOutput <$> txIn unsignedTx + +-- Just keys = traverse secHexKey [ "3030303030303030303030303030303030303030303030303030303030303031" +-- , "3030303030303030303030303030303030303030303030303030303030303032" +-- , "3030303030303030303030303030303030303030303030303030303030303033" +-- ] + +-- rdm = PayMulSig (toPubKey <$> keys) 2 +-- sigIn = SigInput (toP2WSH $ encodeOutput rdm) 100000000 op0 sigHashAll (Just rdm) +-- generatedSignedTx = signTx btc unsignedTx [sigIn] (take 2 keys) + +-- -- Reproduce the P2SH-P2WSH multisig example from BIP 143 +-- testBip143p2shp2wpkhMulsig :: Assertion +-- testBip143p2shp2wpkhMulsig = +-- assertEqual "BIP143 p2sh-p2wsh multisig" (Right exampleSignedTx) generatedSignedTx +-- where +-- exampleSignedTx = "0100000000010136641869ca081e70f394c6948e8af409e18b619df2ed74aa106c1ca29787b96e0100000023220020a16b5755f7f6f96dbd65f5f0d6ab9418b89af4b1f14a1bb8a09062c35f0dcb54ffffffff0200e9a435000000001976a914389ffce9cd9ae88dcc0631e88a821ffdbe9bfe2688acc0832f05000000001976a9147480a33f950689af511e6e84c138dbbd3c3ee41588ac080047304402206ac44d672dac41f9b00e28f4df20c52eeb087207e8d758d76d92c6fab3b73e2b0220367750dbbe19290069cba53d096f44530e4f98acaa594810388cf7409a1870ce01473044022068c7946a43232757cbdf9176f009a928e1cd9a1a8c212f15c1e11ac9f2925d9002205b75f937ff2f9f3c1246e547e54f62e027f64eefa2695578cc6432cdabce271502473044022059ebf56d98010a932cf8ecfec54c48e6139ed6adb0728c09cbe1e4fa0915302e022007cd986c8fa870ff5d2b3a89139c9fe7e499259875357e20fcbb15571c76795403483045022100fbefd94bd0a488d50b79102b5dad4ab6ced30c4069f1eaa69a4b5a763414067e02203156c6a5c9cf88f91265f5a942e96213afae16d83321c8b31bb342142a14d16381483045022100a5263ea0553ba89221984bd7f0b13613db16e7a70c549a86de0cc0444141a407022005c360ef0ae5a5d4f9f2f87a56c1546cc8268cab08c73501d6b3be2e1e1a8a08824730440220525406a1482936d5a21888260dc165497a90a15669636d8edca6b9fe490d309c022032af0c646a34a44d1f4576bf6a4a74b67940f8faa84c7df9abe12a01a11e2b4783cf56210307b8ae49ac90a048e9b53357a2354b3334e9c8bee813ecb98e99a7e07e8c3ba32103b28f0c28bfab54554ae8c658ac5c3e0ce6e79ad336331f78c428dd43eea8449b21034b8113d703413d57761b8b9781957b8c0ac1dfe69f492580ca4195f50376ba4a21033400f6afecb833092a9a21cfdf1ed1376e58c5d1f47de74683123987e967a8f42103a6d48b1131e94ba04d9737d61acdaa1322008af9602b3b14862c07a1789aac162102d8b661b0b3302ee2f162b09e07a55ad5dfbe673a9f01d9f0c19617681024306b56ae00000000" + +-- unsignedTx = "010000000136641869ca081e70f394c6948e8af409e18b619df2ed74aa106c1ca29787b96e0100000000ffffffff0200e9a435000000001976a914389ffce9cd9ae88dcc0631e88a821ffdbe9bfe2688acc0832f05000000001976a9147480a33f950689af511e6e84c138dbbd3c3ee41588ac00000000" + +-- op0 = head $ prevOutput <$> txIn unsignedTx + +-- rawKeys = [ "730fff80e1413068a05b57d6a58261f07551163369787f349438ea38ca80fac6" +-- , "11fa3d25a17cbc22b29c44a484ba552b5a53149d106d3d853e22fdd05a2d8bb3" +-- , "77bf4141a87d55bdd7f3cd0bdccf6e9e642935fec45f2f30047be7b799120661" +-- , "14af36970f5025ea3e8b5542c0f8ebe7763e674838d08808896b63c3351ffe49" +-- , "fe9a95c19eef81dde2b95c1284ef39be497d128e2aa46916fb02d552485e0323" +-- , "428a7aee9f0c2af0cd19af3cf1c78149951ea528726989b2e83e4778d2c3f890" +-- ] + +-- Just keys@[key0, key1, key2, key3, key4, key5] = traverse secHexKey rawKeys + +-- rdm = PayMulSig (toPubKey <$> keys) 6 +-- sigIn sh = SigInput (toP2WSH $ encodeOutput rdm) 987654321 op0 sh (Just rdm) + +-- sigHashesA = [sigHashAll, sigHashNone, sigHashSingle] +-- sigHashesB = setAnyoneCanPayFlag <$> sigHashesA +-- sigIns = sigIn <$> (sigHashesA <> sigHashesB) + +-- 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 + +{- Building Transactions -} + +testBuildAddrTx :: Network -> Address -> TestCoin -> Bool +testBuildAddrTx net a (TestCoin v) + | isPubKeyAddress a = Right (PayPKHash (getAddrHash160 a)) == out + | isScriptAddress a = Right (PayScriptHash (getAddrHash160 a)) == out + | otherwise = undefined + where + tx = buildAddrTx net [] [(fromJust (addrToString net a), v)] + out = + decodeOutputBS $ + scriptOutput $ + head $ txOut (fromRight (error "Could not build transaction") tx) + +testGuessSize :: Network -> Tx -> Bool +testGuessSize net 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) + = guess >= len && guess <= len + 2 * delta + where + delta = pki + sum (map fst msi) + guess = guessTxSize pki msi pkout msout + len = B.length $ S.encode tx + ins = map f $ txIn tx + f i = + fromRight (error "Could not decode input") $ + decodeInputBS net $ scriptInput i + pki = length $ filter isSpendPKHash ins + msi = concatMap shData ins + shData (ScriptHashInput _ (PayMulSig keys r)) = [(r, length keys)] + shData _ = [] + out = + map + (fromRight (error "Could not decode transaction output") . + decodeOutputBS . scriptOutput) $ + txOut tx + pkout = length $ filter isPayPKHash out + msout = length $ filter isPayScriptHash out + +testChooseCoins :: [TestCoin] -> Word64 -> Word64 -> Int -> Property +testChooseCoins coins target byteFee nOut = nOut >= 0 ==> + case chooseCoins target byteFee nOut True coins of + Right (chosen, change) -> + let outSum = sum $ map coinValue chosen + fee = guessTxFee byteFee nOut (length chosen) + in outSum == target + change + fee + Left _ -> + let fee = guessTxFee byteFee nOut (length coins) + in target == 0 || s < target + fee + where + s = sum $ map coinValue coins + +testChooseMSCoins :: (Int, Int) -> [TestCoin] + -> Word64 -> Word64 -> Int -> Property +testChooseMSCoins (m, n) coins target byteFee nOut = nOut >= 0 ==> + case chooseMSCoins target byteFee (m,n) nOut True coins of + Right (chosen,change) -> + let outSum = sum $ map coinValue chosen + fee = guessMSTxFee byteFee (m,n) nOut (length chosen) + in outSum == target + change + fee + Left _ -> + let fee = guessMSTxFee byteFee (m,n) nOut (length coins) + in target == 0 || s < target + fee + where + s = sum $ map coinValue coins + +{- Signing Transactions -} + +testDetSignTx :: Network -> (Tx, [SigInput], [SecKeyI]) -> Bool +testDetSignTx net (tx, sigis, prv) = + not (verifyStdTx net tx verData) && + not (verifyStdTx net txSigP verData) && verifyStdTx net txSigC verData + where + txSigP = + fromRight (error "Could not decode transaction") $ + signTx net tx sigis (map secKeyData (tail prv)) + txSigC = + fromRight (error "Could not decode transaction") $ + signTx net txSigP sigis [secKeyData (head prv)] + verData = map (\(SigInput s v o _ _) -> (s, v, o)) sigis + +testDetSignNestedTx :: Network -> (Tx, [SigInput], [SecKeyI]) -> Bool +testDetSignNestedTx net (tx, sigis, prv) = + not (verifyStdTx net tx verData) && + not (verifyStdTx net txSigP verData) && verifyStdTx net txSigC verData + where + txSigP = + fromRight (error "Could not decode transaction") $ + signNestedWitnessTx net tx sigis (secKeyData <$> tail prv) + txSigC = + fromRight (error "Could not decode transaction") $ + signNestedWitnessTx net txSigP sigis [secKeyData (head prv)] + verData = handleSegwit <$> sigis + handleSegwit (SigInput s v o _ _) + | 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 + [ isRight mergeRes + , length (txIn mergedTx) == length os + , if enoughSigs then isValid else not isValid + -- Signature count == min (length txs) (sum required signatures) + , sum (map snd sigMap) == min (length txs) (sum (map fst sigMap)) + ] + where + outs = map (\(so, val, op, _, _) -> (so, val, op)) os + mergeRes = mergeTxs net txs outs + mergedTx = fromRight (error "Could not merge") mergeRes + isValid = verifyStdTx net mergedTx outs + enoughSigs = all (\(m,c) -> c >= m) sigMap + sigMap = map (\((_,_,_,m,_), inp) -> (m, sigCnt inp)) $ zip os $ txIn mergedTx + sigCnt inp = case decodeInputBS net $ scriptInput inp of + Right (RegularInput (SpendMulSig sigs)) -> length sigs + Right (ScriptHashInput (SpendMulSig sigs) _) -> length sigs + _ -> error "Invalid input script type" + +testID :: (FromJSON a, ToJSON a, Eq a) => a -> Bool +testID x = + (A.decode . A.encode) (singleton ("object" :: String) x) == + Just (singleton ("object" :: String) x) diff --git a/test/Haskoin/UtilSpec.hs b/test/Haskoin/UtilSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/UtilSpec.hs @@ -0,0 +1,64 @@ +module Haskoin.UtilSpec (spec) where + +import qualified Data.ByteString as BS +import Data.Either (fromLeft, fromRight, isLeft, isRight) +import Data.Foldable (toList) +import Data.List (permutations) +import Data.Maybe +import qualified Data.Sequence as Seq +import Haskoin.Test +import Haskoin.Util +import Test.Hspec +import Test.QuickCheck + +spec :: Spec +spec = + describe "utility functions" $ do + it "bsToInteger . integerToBS" $ property getPutInteger + it "decodeHex . encodeHex" $ property $ forAll arbitraryBS fromToHex + it "compare updateIndex with Data.Sequence" $ property testUpdateIndex + it "matchTemplate" $ property testMatchTemplate + it "testing matchTemplate with two lists" $ + property testMatchTemplateLen + it "either helper functions" $ property testEither + +{- 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 + res = matchTemplate as bs (==) + idx = + if null as + then 0 + 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 (==) + +testEither :: Either String Int -> Bool +testEither e = + case e of + (Right v) -> + isRight e && + not (isLeft e) && + fromRight (error "Unexpected Left") e == v && + eitherToMaybe e == Just v + (Left v) -> + isLeft e && + not (isRight e) && + fromLeft (error "Unexpected Right") e == v && + isNothing (eitherToMaybe e) diff --git a/test/Network/Haskoin/Address/Bech32Spec.hs b/test/Network/Haskoin/Address/Bech32Spec.hs deleted file mode 100644 --- a/test/Network/Haskoin/Address/Bech32Spec.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Network.Haskoin.Address.Bech32Spec - ( spec - ) where - -import Control.Monad -import Data.Bits (xor) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Char (chr, ord, toLower) -import Data.Maybe -import Data.String.Conversions -import Data.Text (Text, append, pack, snoc, - uncons) -import qualified Data.Text as T -import Data.Word (Word8) -import Network.Haskoin.Address -import Network.Haskoin.Address.Bech32 -import Network.Haskoin.Util -import Test.Hspec -import Test.HUnit - -spec = do - describe "bech32 checksum" $ do - it "should have valid checksum" $ forM_ validChecksums testValidChecksum - it "should have invalid checksum" $ - forM_ invalidChecksums testInvalidChecksum - it "should be a valid address" $ forM_ validAddresses testValidAddress - it "should be an invalid address" $ - forM_ invalidAddresses testInvalidAddress - it "should be same for the input in different case" $ - all (== Just "test12hrzfj") . map (flip bech32Encode []) $ hrpCaseVariants - describe "more encoding/decoding cases" $ do - it "length > 90" $ - assert $ - isNothing $ - bech32Encode "bc" (replicate 82 (word5 (1 :: Word8))) - it "segwit version bounds" $ - assert $ isNothing $ segwitEncode "bc" 17 [] - it "segwit prog len version 0" $ - assert $ isNothing $ segwitEncode "bc" 0 (replicate 30 1) - it "segwit prog len version != 0" $ - assert $ isJust $ segwitEncode "bc" 1 (replicate 30 1) - it "segwit prog len version != 0" $ - assert $ isNothing $ segwitEncode "bc" 1 (replicate 41 1) - it "empty HRP encode" $ assert $ isNothing $ bech32Encode "" [] - it "empty HRP encode" $ - assert $ isNothing $ bech32Decode "10a06t8" - it "hrp lowercased" $ - bech32Encode "HRP" [] `shouldBe` bech32Encode "hrp" [] - - -testValidChecksum :: Bech32 -> Assertion -testValidChecksum checksum = case bech32Decode checksum of - Nothing -> assertFailure (show checksum) - Just (resultHRP, resultData) -> do - -- test that a corrupted checksum fails decoding. - let (hrp, rest) = T.breakOnEnd "1" checksum - Just (first, rest') = uncons rest - checksumCorrupted = (hrp `snoc` chr (ord first `xor` 1)) `append` rest' - assertBool (show checksum ++ " corrupted") - $ isNothing (bech32Decode checksumCorrupted) - -- test that re-encoding the decoded checksum results in the same checksum. - let checksumEncoded = bech32Encode resultHRP resultData - expectedChecksum = Just $ T.toLower checksum - assertEqual (show checksum ++ " re-encode") - 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 - hrp = T.take 2 address' - case segwitDecode hrp address of - Nothing -> assertFailure "decode failed" - Just (witver, witprog) -> do - assertEqual (show address) - (decodeHex hexscript) - (Just $ segwitScriptPubkey witver witprog) - assertEqual (show address) - (Just address') - (segwitEncode hrp witver witprog) - -testInvalidAddress :: Text -> Assertion -testInvalidAddress address = do - assertBool (show address) (isNothing $ segwitDecode "bc" address) - assertBool (show address) (isNothing $ segwitDecode "tb" address) - -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 :: [Text] -validChecksums = - [ "A12UEL5L" - , "an83characterlonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1tt5tgs" - , "abcdef1qpzry9x8gf2tvdw0s3jn54khce6mua7lmqqqxw" - , "11qqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqc8247j" - , "split1checkupstagehandshakeupstreamerranterredcaperred2y9e3w" - ] - -invalidChecksums :: [Text] -invalidChecksums = - [ " 1nwldj5" - , "\DEL1axkwrx" - , "an84characterslonghumanreadablepartthatcontainsthenumber1andtheexcludedcharactersbio1569pvx" - , "pzry9x0s0muk" - , "1pzry9x0s0muk" - , "x1b4n0q5v" - , "li1dgmt3" - , "de1lg7wt\xFF" - ] - -validAddresses :: [(Text, Text)] -validAddresses = - [ ("BC1QW508D6QEJXTDG4Y5R3ZARVARY0C5XW7KV8F3T4", "0014751e76e8199196d454941c45d1b3a323f1433bd6") - , ("tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sl5k7" - ,"00201863143c14c5166804bd19203356da136c985678cd4d27a1b8c6329604903262") - , ("bc1pw508d6qejxtdg4y5r3zarvary0c5xw7kw508d6qejxtdg4y5r3zarvary0c5xw7k7grplx" - ,"5128751e76e8199196d454941c45d1b3a323f1433bd6751e76e8199196d454941c45d1b3a323f1433bd6") - , ("BC1SW50QA3JX3S", "6002751e") - , ("bc1zw508d6qejxtdg4y5r3zarvaryvg6kdaj", "5210751e76e8199196d454941c45d1b3a323") - , ("tb1qqqqqp399et2xygdj5xreqhjjvcmzhxw4aywxecjdzew6hylgvsesrxh6hy" - ,"0020000000c4a5cad46221b2a187905e5266362b99d5e91c6ce24d165dab93e86433") - ] - -invalidAddresses :: [Text] -invalidAddresses = - [ "tc1qw508d6qejxtdg4y5r3zarvary0c5xw7kg3g4ty" - , "bc1qw508d6qejxtdg4y5r3zarvary0c5xw7kv8f3t5" - , "BC13W508D6QEJXTDG4Y5R3ZARVARY0C5XW7KN40WF2" - , "bc1rw5uspcuh" - , "bc10w508d6qejxtdg4y5r3zarvary0c5xw7kw508d6qejxtdg4y5r3zarvary0c5xw7kw5rljs90" - , "BC1QR508D6QEJXTDG4Y5R3ZARVARYV98GJ9P" - , "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3q0sL5k7" - , "bc1zw508d6qejxtdg4y5r3zarvaryvqyzf3du" - , "tb1qrp33g0q5c5txsp9arysrx4k6zdkfs4nce4xj0gdcccefvpysxf3pjxtptv" - , "bc1gmk9yu" - ] - -hrpCaseVariants:: [Text] -hrpCaseVariants = map T.pack hrpTestPermutations - -hrpTestPermutations :: [String] -hrpTestPermutations = do - a <- ['t', 'T'] - b <- ['e', 'E'] - c <- ['s', 'S'] - d <- ['t', 'T'] - return [a, b, c, d] diff --git a/test/Network/Haskoin/Address/CashAddrSpec.hs b/test/Network/Haskoin/Address/CashAddrSpec.hs deleted file mode 100644 --- a/test/Network/Haskoin/Address/CashAddrSpec.hs +++ /dev/null @@ -1,280 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Network.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 Network.Haskoin.Address -import Network.Haskoin.Address.CashAddr -import Network.Haskoin.Constants -import Network.Haskoin.Util -import Test.Hspec -import Test.HUnit - -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 = - addrToString bch =<< - stringToAddr btc "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu" - addr `shouldBe` - Just "bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a" - it "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR" $ do - let addr = - addrToString bch =<< - stringToAddr btc "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR" - addr `shouldBe` - Just "bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy" - it "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb" $ do - let addr = - addrToString bch =<< - stringToAddr btc "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb" - addr `shouldBe` - Just "bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r" - it "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC" $ do - let addr = - addrToString bch =<< - stringToAddr btc "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC" - addr `shouldBe` - Just "bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq" - it "3LDsS579y7sruadqu11beEJoTjdFiFCdX4" $ do - let addr = - addrToString bch =<< - stringToAddr btc "3LDsS579y7sruadqu11beEJoTjdFiFCdX4" - addr `shouldBe` - Just "bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e" - it "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw" $ do - let addr = - addrToString bch =<< - stringToAddr btc "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw" - addr `shouldBe` - Just "bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37" - describe "base58 to cashaddr translation test vectors" $ do - it "bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a" $ do - let addr = - addrToString btc =<< - stringToAddr - bch - "bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a" - addr `shouldBe` Just "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu" - it "bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy" $ do - let addr = - addrToString btc =<< - stringToAddr - bch - "bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy" - addr `shouldBe` Just "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR" - it "bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r" $ do - let addr = - addrToString btc =<< - stringToAddr - bch - "bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r" - addr `shouldBe` Just "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb" - it "bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq" $ do - let addr = - addrToString btc =<< - stringToAddr - bch - "bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq" - addr `shouldBe` Just "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC" - it "bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e" $ do - let addr = - addrToString btc =<< - stringToAddr - bch - "bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e" - addr `shouldBe` Just "3LDsS579y7sruadqu11beEJoTjdFiFCdX4" - it "bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37" $ do - let addr = - addrToString btc =<< - stringToAddr - 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/Network/Haskoin/AddressSpec.hs b/test/Network/Haskoin/AddressSpec.hs deleted file mode 100644 --- a/test/Network/Haskoin/AddressSpec.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Network.Haskoin.AddressSpec (spec) where - -import Data.Aeson -import Data.Aeson.Types -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS (append, empty, pack) -import Data.Either (isRight) -import Data.Maybe (isJust, fromJust) -import qualified Data.Serialize as S -import Data.Text (Text) -import Network.Haskoin.Address -import Network.Haskoin.Address.Base58 -import Network.Haskoin.Constants -import Network.Haskoin.Keys (derivePubKeyI) -import Network.Haskoin.Test -import Test.Hspec -import Test.HUnit (Assertion, assertBool, - assertEqual) -import Test.QuickCheck - -spec :: Spec -spec = do - let net = btc - describe "btc address" . it "base58 encodings" $ mapM_ runVector vectors - describe "btc-test address" $ props btcTest - describe "bch address" $ props bch - describe "bch-test address" $ props bchTest - describe "bch-regtest address" $ props bchRegTest - describe "json serialization" . it "encodes and decodes address" $ - forAll arbitraryAddress (testCustom (addrFromJSON net) (addrToJSON net)) - describe "witness address vectors" . it "p2sh(pwpkh)" $ - mapM_ testCompatWitness compatWitnessVectors - -props :: Network -> Spec -props net = do - it "encodes and decodes base58 bytestring" $ - property $ - forAll arbitraryBS $ \bs -> decodeBase58 (encodeBase58 bs) == Just bs - it "encodes and decodes base58 bytestring with checksum" $ - property $ - forAll arbitraryBS $ \bs -> - decodeBase58Check (encodeBase58Check bs) == Just bs - it "encodes and decodes address" $ - property $ - forAll arbitraryAddress $ \a -> - (stringToAddr net =<< addrToString net a) == Just a - it "shows and reads address" $ - property $ forAll arbitraryAddress $ \a -> read (show a) == a - -runVector :: (ByteString, Text, Text) -> Assertion -runVector (bs, e, chk) = do - assertEqual "encodeBase58" e b58 - assertEqual "encodeBase58Check" chk b58Chk - assertEqual "decodeBase58" (Just bs) (decodeBase58 b58) - assertEqual "decodeBase58Check" (Just bs) (decodeBase58Check b58Chk) - where - b58 = encodeBase58 bs - b58Chk = encodeBase58Check bs - -vectors :: [(ByteString, Text, Text)] -vectors = - [ ( BS.empty, "", "3QJmnh" ) - , ( BS.pack [0], "1", "1Wh4bh" ) - , ( BS.pack [0,0,0,0], "1111", "11114bdQda" ) - , ( BS.pack [0,0,1,0,0], "11LUw", "113CUwsFVuo" ) - , ( BS.pack [255], "5Q", "VrZDWwe" ) - , ( BS.pack [0,0,0,0] `BS.append` BS.pack [1..255] - , "1111cWB5HCBdLjAuqGGReWE3R3CguuwSjw6RHn39s2yuDRTS5NsBgNiFpWgAnEx6VQi8csexkgYw3mdYrMHr8x9i7aEwP8kZ7vccXWqKDvGv3u1GxFKPuAkn8JCPPGDMf3vMMnbzm6Nh9zh1gcNsMvH3ZNLmP5fSG6DGbbi2tuwMWPthr4boWwCxf7ewSgNQeacyozhKDDQQ1qL5fQFUW52QKUZDZ5fw3KXNQJMcNTcaB723LchjeKun7MuGW5qyCBZYzA1KjofN1gYBV3NqyhQJ3Ns746GNuf9N2pQPmHz4xpnSrrfCvy6TVVz5d4PdrjeshsWQwpZsZGzvbdAdN8MKV5QsBDY" - , "111151KWPPBRzdWPr1ASeu172gVgLf1YfUp6VJyk6K9t4cLqYtFHcMa2iX8S3NJEprUcW7W5LvaPRpz7UG7puBj5STE3nKhCGt5eckYq7mMn5nT7oTTic2BAX6zDdqrmGCnkszQkzkz8e5QLGDjf7KeQgtEDm4UER6DMSdBjFQVa6cHrrJn9myVyyhUrsVnfUk2WmNFZvkWv3Tnvzo2cJ1xW62XDfUgYz1pd97eUGGPuXvDFfLsBVd1dfdUhPwxW7pMPgdWHTmg5uqKGFF6vE4xXpAqZTbTxRZjCDdTn68c2wrcxApm8hq3JX65Hix7VtcD13FF8b7BzBtwjXq1ze6NMjKgUcqpJTN9vt" - ) - ] - -testCustom :: Eq a => (Value -> Parser a) -> (a -> Value) -> a -> Bool -testCustom f g x = parseMaybe f (g x) == Just x - -compatWitnessVectors :: [(Network, Text, Text)] -compatWitnessVectors = - [ ( btcTest - , "cNUnpYpMsJXYCERYBciJnsWBpcYEFjdcbq6dxj4SskGhs7uHuJ7Q" - , "2N6PDTueBHvXzW61B4oe5SW1D3v2Z3Vpbvw") - ] - -testCompatWitness :: (Network, Text, Text) -> Assertion -testCompatWitness (net, seckey, addr) = do - let seckeyM = fromWif net seckey - assertBool "decode seckey" (isJust seckeyM) - let pubkey = derivePubKeyI (fromJust seckeyM) - let addrM = addrToString btcTest (pubKeyCompatWitnessAddr pubkey) - assertBool "address can be encoded" (isJust addrM) - assertEqual "witness address matches" addr (fromJust addrM) diff --git a/test/Network/Haskoin/BlockSpec.hs b/test/Network/Haskoin/BlockSpec.hs deleted file mode 100644 --- a/test/Network/Haskoin/BlockSpec.hs +++ /dev/null @@ -1,359 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Network.Haskoin.BlockSpec - ( spec - ) where - -import Control.Monad.State.Strict -import Data.Aeson as A -import Data.Either (fromRight) -import Data.Map.Strict (singleton) -import Data.Maybe (fromJust) -import Data.Serialize as S -import Data.String (fromString) -import Data.String.Conversions (cs) -import Data.Text (Text) -import Network.Haskoin.Block -import Network.Haskoin.Block.Headers -import Network.Haskoin.Block.Merkle -import Network.Haskoin.Constants -import Network.Haskoin.Test -import Network.Haskoin.Transaction -import Test.Hspec -import Test.HUnit hiding (State) -import Test.QuickCheck - -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 - either error (const $ return ()) bnsE - where - bhs = appendBlocks net 6 bh i - -spec :: Spec -spec = do - let net = bchRegTest - describe "blockchain headers" $ do - it "gets best block" $ - let bb = - withChain net $ do - chain net (getGenesisHeader net) 100 - getBestBlockHeader - in nodeHeight bb `shouldBe` 100 - it "builds a block locator" $ - let 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" $ - let bb = withChain net $ splitChain net >> getBestBlockHeader - in nodeHeight bb `shouldBe` 4035 - describe "block hash" $ do - it "encodes and decodes block hash" $ - property $ - forAll arbitraryBlockHash $ \h -> - hexToBlockHash (blockHashToHex h) == Just h - it "from string block hash" $ - property $ - forAll arbitraryBlockHash $ \h -> - fromString (cs $ blockHashToHex h) == h - it "show and read block hash" $ - property $ forAll arbitraryBlockHash $ \h -> read (show h) == h - it "json block hash" $ property $ forAll arbitraryBlockHash testID - describe "merkle trees" $ do - let net' = btc - it "builds tree of right width at height 1" $ property testTreeWidth - it "builds tree of right width at height 0" $ property testBaseWidth - it "builds and extracts partial merkle tree" $ - property $ - forAll - (listOf1 ((,) <$> arbitraryTxHash <*> arbitrary)) - (buildExtractTree net') - it "merkle root test vectors" $ - mapM_ runMerkleVector merkleVectors - describe "compact number" $ do - it "compact number local vectors" testCompact - it "compact number imported vectors" testCompactBitcoinCore - describe "block serialization" $ do - it "encodes and decodes block" $ - property $ forAll (arbitraryBlock net) cerealID - it "encodes and decodes block JSON" $ - property $ forAll (arbitraryBlock net) testID - it "encodes and decodes block header" $ - property $ forAll arbitraryBlockHeader cerealID - it "encodes and decodes block header JSON" $ - property $ forAll arbitraryBlockHeader testID - it "encodes and decodes getblocks" $ - property $ forAll arbitraryGetBlocks cerealID - it "encodes and decodes getheaders" $ - property $ forAll arbitraryGetHeaders cerealID - it "encodes and decdoes headers" $ - property $ forAll arbitraryHeaders cerealID - it "encodes and decodes merkle block" $ - property $ forAll arbitraryMerkleBlock cerealID - describe "helper functions" $ do - it "computes bitcoin block subsidy correctly" (testSubsidy btc) - it "computes regtest block subsidy correctly" (testSubsidy btcRegTest) - --- 0 → → 2015 → → → → → → → 4031 --- ↓ --- → → 2035 → → → → → → 4035* --- ↓ --- → → 2185 -splitChain :: Network -> State HeaderMemory () -splitChain net = do - start <- go 1 (getGenesisHeader net) 2015 - e 2015 (head start) - tail1 <- go 2 (nodeHeader $ head start) 2016 - e 4031 (head tail1) - tail2 <- go 3 (nodeHeader $ head start) 20 - e 2035 (head tail2) - tail3 <- go 4 (nodeHeader $ head tail2) 2000 - e 4035 (head tail3) - tail4 <- go 5 (nodeHeader $ head tail2) 150 - e 2185 (head tail4) - sp1 <- splitPoint (head tail1) (head tail3) - unless (sp1 == head start) $ - error $ - "Split point wrong between blocks 4031 and 4035: " ++ - show (nodeHeight sp1) - sp2 <- splitPoint (head tail4) (head tail3) - unless (sp2 == head tail2) $ - error $ - "Split point wrong between blocks 2185 and 4035: " ++ - show (nodeHeight sp2) - where - e n bn = - unless (nodeHeight bn == n) $ - error $ - "Node height " ++ - show (nodeHeight bn) ++ " of first chunk should be " ++ show n - go seed start n = do - let bhs = appendBlocks net seed start n - bnE <- connectBlocks net myTime bhs - case bnE of - Right bn -> return bn - Left ex -> error ex - -{- 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) - where - (f, h) = buildPartialMerkle txs - (r, m) = - fromRight (error "Could not extract matches from Merkle tree") $ - extractMatches net f h (length txs) - -testCompact :: Assertion -testCompact = do - assertEqual "vector 1" 0x05123456 (encodeCompact 0x1234560000) - assertEqual "vector 2" (0x1234560000, False) (decodeCompact 0x05123456) - assertEqual "vector 3" 0x0600c0de (encodeCompact 0xc0de000000) - assertEqual "vector 4" (0xc0de000000, False) (decodeCompact 0x0600c0de) - assertEqual "vector 5" 0x05c0de00 (encodeCompact (-0x40de000000)) - assertEqual "vector 6" (-0x40de000000, False) (decodeCompact 0x05c0de00) - -testCompactBitcoinCore :: Assertion -testCompactBitcoinCore = do - assertEqual "zero" (0, False) (decodeCompact 0x00000000) - assertEqual - "zero (encode · decode)" - 0x00000000 - (encodeCompact . fst $ decodeCompact 0x00000000) - assertEqual "rounds to zero" (0, False) (decodeCompact 0x00123456) - assertEqual "rounds to zero" (0, False) (decodeCompact 0x01003456) - assertEqual "rounds to zero" (0, False) (decodeCompact 0x02000056) - assertEqual "rounds to zero" (0, False) (decodeCompact 0x03000000) - assertEqual "rounds to zero" (0, False) (decodeCompact 0x04000000) - assertEqual "rounds to zero" (0, False) (decodeCompact 0x00923456) - assertEqual "rounds to zero" (0, False) (decodeCompact 0x01803456) - assertEqual "rounds to zero" (0, False) (decodeCompact 0x02800056) - assertEqual "rounds to zero" (0, False) (decodeCompact 0x03800000) - assertEqual "rounds to zero" (0, False) (decodeCompact 0x04800000) - assertEqual "vector 1 (decode)" (0x12, False) (decodeCompact 0x01123456) - assertEqual - "vector 1 (encode · decode)" - 0x01120000 - (encodeCompact . fst $ decodeCompact 0x01123456) - assertEqual "0x80 bit set" 0x02008000 (encodeCompact 0x80) - assertEqual - "vector 2 (negative) (decode)" - (-0x7e, False) - (decodeCompact 0x01fedcba) - assertEqual - "vector 2 (negative) (encode · decode)" - 0x01fe0000 - (encodeCompact . fst $ decodeCompact 0x01fedcba) - assertEqual "vector 3 (decode)" (0x1234, False) (decodeCompact 0x02123456) - assertEqual - "vector 3 (encode · decode)" - 0x02123400 - (encodeCompact . fst $ decodeCompact 0x02123456) - assertEqual "vector 4 (decode)" (0x123456, False) (decodeCompact 0x03123456) - assertEqual - "vector 4 (encode · decode)" - 0x03123456 - (encodeCompact . fst $ decodeCompact 0x03123456) - assertEqual - "vector 5 (decode)" - (0x12345600, False) - (decodeCompact 0x04123456) - assertEqual - "vector 5 (encode · decode)" - 0x04123456 - (encodeCompact . fst $ decodeCompact 0x04123456) - assertEqual - "vector 6 (decode)" - (-0x12345600, False) - (decodeCompact 0x04923456) - assertEqual - "vector 6 (encode · decode)" - 0x04923456 - (encodeCompact . fst $ decodeCompact 0x04923456) - assertEqual - "vector 7 (decode)" - (0x92340000, False) - (decodeCompact 0x05009234) - assertEqual - "vector 7 (encode · decode)" - 0x05009234 - (encodeCompact . fst $ decodeCompact 0x05009234) - assertEqual - "vector 8 (decode)" - ( 0x1234560000000000000000000000000000000000000000000000000000000000 - , False) - (decodeCompact 0x20123456) - assertEqual - "vector 8 (encode · decode)" - 0x20123456 - (encodeCompact . fst $ decodeCompact 0x20123456) - assertBool "vector 9 (decode) (overflow)" (snd $ decodeCompact 0xff123456) - assertBool - "vector 9 (decode) (positive)" - ((> 0) . fst $ decodeCompact 0xff123456) - -runMerkleVector :: (Text, [Text]) -> Assertion -runMerkleVector (r, hs) = - assertBool "merkle vector" $ - buildMerkleRoot (map f hs) == getTxHash (f r) - where - f = fromJust . hexToTxHash - -merkleVectors :: [(Text, [Text])] -merkleVectors = - -- Block 000000000000cd7e8cf6510303dde76121a1a791c15dba0be4be7022b07cf9e1 - [ ( "fb6698ac95b754256c5e71b4fbe07638cb6ca83ee67f44e181b91727f09f4b1f" - , [ "dd96fdcfaec994bf583af650ff6022980ee0ba1686d84d0a3a2d24eabf34bc52" - , "1bc216f786a564378710ae589916fc8e092ddfb9f24fe6c47b733550d476d5d9" - , "a1db0b0194426064b067899ff2d975fb277fd52dbb1a38370800c76dd6503d41" - , "d69f7fb0e668fbd437d1bf5211cc34d7eb8746f50cfddf705fe10bc2f8f7035f" - , "5b4057cd80be7df5ed2ac42b776897ed3c26e3a01e4072075b8129c587094ef6" - , "ed6dabcfba0ef43c50d89a8a0e4b236b1bc6585d4c3bbf49728b55f44312d6bc" - , "056aaa9a3c635909c794e9b0acc7dccb0456c59a84c6b08417335bee4515e3d3" - , "05bae5f1d1c874171692e1fc06f664e63eb143d3f096601ef938e4a9012eee66" - , "b5e48e94e3f2fba197b3f591e01f47e185d7834d669529d44078e41c671aab0f" - , "3b56aeadfc0c5484fd507bc89f13f2e5f61c42e0a4ae9062eda9a9aeef7db6a4" - , "2affa187e1ebb94a2a86578b9f64951e854ff3d346fef259acfb6d0f5212e0d3" - ] - ) - -- Block 00000000000007cc4b6f07bfed72bccc1ed8dd031a93969a4c22211f784457d4 - , ( "886fea311d2dc64c315519f2d647e43998d780d2170f77e53dc0d85bf2ee680c" - , [ "c9c9e5211512629fd111cc071d745b8c79bf486b4ea95489eb5de08b5d786b8e" - , "20beb0ee30dfd323ade790ce9a46ae7a174f9ea44ce22a17c4d4eb23b7016f51" - , "d4cb7dd741e78a8f57e12f6c8ddb0361ff2a5bf9365bd7d7df761060847daf9a" - , "ddbfa6fdd29d4b47aeaadf82a4bf0a93d58cd7d8401fabf860a1ae8eeb51f42e" - , "9d82bafe44abee248b968c86f165051c8413482c232659795335c52922dab471" - , "86035372d31b53efd848cea7231aa9738c209aff64d3c59b1619341afb5b6ba3" - , "11e7a7393d9658813dfaebc04fa6d4b73bac8d641bffa7067da879523d43d030" - , "2f676b9aa5bc0ebf3395032c84c466e40cac29f80434cd1138e31c2d0fcc5c13" - , "37567d559fbfae07fda9a90de0ce30b202128bc8ebdfef5ad2b53e865a3478c2" - , "0b8e6c1200c454361e94e261738429e9c9b8dcffd85ec8511bbf5dc7e2e0ada8" - ] - ) - -- Block 00000000839a8e6886ab5951d76f411475428afc90947ee320161bbf18eb6048 - , ( "0e3e2357e806b6cdb1f70b54c3a3a17b6714ee1f0e68bebb44a74b1efd512098" - , [ "0e3e2357e806b6cdb1f70b54c3a3a17b6714ee1f0e68bebb44a74b1efd512098" ] - ) - -- Block 000000000004d160ac1f7b775d7c1823345aeadd5fcb29ca2ad2403bb7babd4c - , ( "aae018650f513fc42d55b2210ec3ceeeb194fb1261d37989de07451fc0cbac5c" - , [ "a4454f22831acd7904a9902c5070a3ee4bf4c2b13bc6b2dc66735dd3c4414028" - , "45297f334278885108dd38a0b689ed95a4373dd3f7e4413e6aebdc2654fb771b" - ] - ) - -- Block 000000000001d1b13a7e86ddb20da178f20d6da5cd037a29c2a15b8b84cc774e - , ( "ca3580505feb87544760ac14a5859659e23be05f765bbed9f86a3c9aad1a5d0c" - , [ "60702384c6e9d34ff03c2b3e726bdc649befe603216815bd0a2974921d0d9549" - , "11f40f58941d2a81a1616a3b84b7dd8b9d07e68750827de488c11a18f54220bb" - , "d78e82527aa8cf16e375010bc666362c0258d3c0da1885a1871121706da8b633" - ] - ) - -- Block 0000000000000630a4e2266a31776e952a19b7c99a6387917d9de9032f608021 - , ( "dcce8be0a9a41e7bb726c5b49d957d90b5308e3dc5dce070ccbc8996e265a6c2" - , [ "c0f58ff12cd1023b05f8f7035cc62bf50958ddb216a4e0eb5471deb7ef25fe81" - , "24e5bbf9008641b8fcf3d076fef66c28c695362ba9f6a6042f8275a98414ee92" - , "e8e1f72abad5e34dabc0f6de46a484b17a9af857d1c41de19482fadf6f7f4b27" - , "540e4d34d9fd9e5ec02853054be7ad9260379bc23388489049cca1b0f7cf518a" - , "324444835c5fe0545f98c4240011b75e6ea1bb76f41829e4cfbe7f75b6cee924" - , "e7d31437ac21bceb0c222a82b2723e2b8a7654147e33397679f041537022a4b2" - , "a8b5768d8b33525ee89d546a6a6897f8e42ba9d56a2c5e871a5d2ab40258dc95" - , "7ba712b31bae8d45810a5cda3838c7e7fb9abd6e88bb4b3ee79be9ea2f714bb4" - , "2ae1c4d927b06edaa626b230976ad8062bbae24da9378d1de2409da5ab08a26d" - , "3c417dc8087d6878003624b74431e17fec9ca761389034b1b1e0f32cbfb11f4f" - , "de6de7beae8d8c98c7d46b4409d5460e58e3204d8b4caed256c7471998595909" - , "c7c3c211402b7c4379f7b01fadc67260ee58d11e8d0bcce3d68cb45f3467e99d" - , "77aa2717e727a096d81074bd46ae59462692d20a1acc1a01b2535518ae5aeb53" - , "4859a710bb673aca46208bbd59d1000ae990dafff5f70b56f0853aeeaea3948b" - , "38deca6991988e461b83aa0d49ffef0f304c4b760371682d152eeb8c56a48174" - , "648f4f50dada3574e2dfe2dc68956b01dd97d543859a3540bbe1ef5418d0e494" - , "9cd7be42c2f0cd8bf38738c162cd05108e213ec7958bf2571cb627872963f5c4" - , "6740e0dd8b97e23864af41839fc197238d2f0dbefce9a82c657556be65c465fa" - , "f75c2e4b70db4b0aabc44b77af1ae75d305340fcf6e7b5f806ddcba4aa42b55d" - , "e125c488636749da68e6696b97525a77146c0777c7946927e37afd513d74a4e6" - , "c20526f119aea10880af631eba7f0b60385a22e0b0c402fe8508d41952e58be9" - , "6456c023c7e245f5c57a168633a23f57f4fadb651115f807694a6bed14ae3b55" - , "98b26e364e2888c9f264e4b5e13103c89608609774eb07ce933d8a2a45d19776" - , "2efaa4f167bb65ba5684f8076cd9279fd67fd9c67388c8862809bab5542e637d" - , "ec44eeb84d8d976d77079a822710b4dfdb11a2d9a03d8cc00bab0ae424e84666" - , "410730d9f807d81ac48b8eafac6f1d36642c1c370241b367a35f0bac6ac7c05f" - , "e95a7d0d477fd3db22756a3fd390a50c7bc48dc9e946fea9d24bd0866b3bb0e9" - , "a72fec99d14939216628aaf7a0afc4c017113bcae964e777e6b508864eeaacc4" - , "8548433310fcf75dbbc042121e8318c678e0a017534786dd322a91cebe8d213f" - ] - ) - ] - -testID :: (FromJSON a, ToJSON a, Eq a) => a -> Bool -testID x = - (A.decode . A.encode) (singleton ("object" :: String) x) == - Just (singleton ("object" :: String) x) - -cerealID :: (Serialize a, Eq a) => a -> Bool -cerealID x = S.decode (S.encode x) == Right x - -testSubsidy :: Network -> Assertion -testSubsidy net = go (2 * 50 * 100 * 1000 * 1000) 0 - where - go previous_subsidy halvings = do - let height = halvings * getHalvingInterval net - subsidy = computeSubsidy net height - if halvings >= 64 - then subsidy `shouldBe` 0 - else do - subsidy `shouldBe` (previous_subsidy `div` 2) - go subsidy (halvings + 1) diff --git a/test/Network/Haskoin/Crypto/HashSpec.hs b/test/Network/Haskoin/Crypto/HashSpec.hs deleted file mode 100644 --- a/test/Network/Haskoin/Crypto/HashSpec.hs +++ /dev/null @@ -1,1269 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Network.Haskoin.Crypto.HashSpec (spec) where - -import Data.ByteString (ByteString) -import Data.Map.Strict (singleton) -import Data.Maybe (fromJust) -import Data.Serialize as S -import Data.String (fromString) -import Data.String.Conversions -import Network.Haskoin.Block -import Network.Haskoin.Crypto -import Network.Haskoin.Test -import Network.Haskoin.Util -import Test.Hspec -import Test.HUnit (Assertion, assertBool) -import Test.QuickCheck - --- Test vectors from NIST --- http://csrc.nist.gov/groups/STM/cavp/documents/drbg/drbgtestvectors.zip --- About 1/3 of HMAC DRBG SHA-256 test vectors are tested here - -spec :: Spec -spec = - describe "hash" $ do - it "join512( split512(h) ) == h" $ - property $ - forAll arbitraryHash256 $ forAll arbitraryHash256 . joinSplit512 - it "decodeCompact . encodeCompact i == i" $ property decEncCompact - it "from string 64-byte hash" $ - property $ - forAll arbitraryHash512 $ \h -> - fromString (cs $ encodeHex $ encode h) == h - it "from string 32-byte hash" $ - property $ - forAll arbitraryHash256 $ \h -> - fromString (cs $ encodeHex $ encode h) == h - it "from string 20-byte hash" $ - property $ - forAll arbitraryHash160 $ \h -> - fromString (cs $ encodeHex $ encode h) == h - it "encodes and decodes bytestring" $ - property $ forAll arbitraryBS cerealID - it "encodes and decodes hash160" $ - property $ forAll arbitraryHash160 cerealID - it "encodes and decodes hash256" $ - property $ forAll arbitraryHash256 cerealID - it "encodes and decodes hash512" $ - property $ forAll arbitraryHash512 cerealID - -type TestVector = [ByteString] - -{- - [SHA-256] - [PredictionResistance = False] - [EntropyInputLen = 256] - [NonceLen = 128] - [PersonalizationStringLen = 0] - [AdditionalInputLen = 0] - [ReturnedBitsLen = 1024] --} - -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 -decEncCompact i - -- Integer completely fits inside the mantisse - | abs i <= 0x007fffff = decodeCompact (encodeCompact i) == (i, False) - -- Otherwise precision will be lost and the decoded result will - -- be smaller than the original number - | i >= 0 = fst (decodeCompact (encodeCompact i)) < i - | otherwise = fst (decodeCompact (encodeCompact i)) > i - -cerealID :: (Serialize a, Eq a) => a -> Bool -cerealID x = decode (encode x) == Right x - -t1 :: [TestVector] -t1 = - [ - -- COUNT = 0 - [ "ca851911349384bffe89de1cbdc46e6831e44d34a4fb935ee285dd14b71a7488" - , "659ba96c601dc69fc902940805ec0ca8" - , "" - , "" - , "" - , "e528e9abf2dece54d47c7e75e5fe302149f817ea9fb4bee6f4199697d04d5b89d54fbb978a15b5c443c9ec21036d2460b6f73ebad0dc2aba6e624abf07745bc107694bb7547bb0995f70de25d6b29e2d3011bb19d27676c07162c8b5ccde0668961df86803482cb37ed6d5c0bb8d50cf1f50d476aa0458bdaba806f48be9dcb8" - ], - -- COUNT = 1 - [ "79737479ba4e7642a221fcfd1b820b134e9e3540a35bb48ffae29c20f5418ea3" - , "3593259c092bef4129bc2c6c9e19f343" - , "" - , "" - , "" - , "cf5ad5984f9e43917aa9087380dac46e410ddc8a7731859c84e9d0f31bd43655b924159413e2293b17610f211e09f770f172b8fb693a35b85d3b9e5e63b1dc252ac0e115002e9bedfb4b5b6fd43f33b8e0eafb2d072e1a6fee1f159df9b51e6c8da737e60d5032dd30544ec51558c6f080bdbdab1de8a939e961e06b5f1aca37" - ], - -- COUNT = 2 - [ "b340907445b97a8b589264de4a17c0bea11bb53ad72f9f33297f05d2879d898d" - , "65cb27735d83c0708f72684ea58f7ee5" - , "" - , "" - , "" - , "75183aaaf3574bc68003352ad655d0e9ce9dd17552723b47fab0e84ef903694a32987eeddbdc48efd24195dbdac8a46ba2d972f5808f23a869e71343140361f58b243e62722088fe10a98e43372d252b144e00c89c215a76a121734bdc485486f65c0b16b8963524a3a70e6f38f169c12f6cbdd169dd48fe4421a235847a23ff" - ], - -- COUNT = 3 - [ "8e159f60060a7d6a7e6fe7c9f769c30b98acb1240b25e7ee33f1da834c0858e7" - , "c39d35052201bdcce4e127a04f04d644" - , "" - , "" - , "" - , "62910a77213967ea93d6457e255af51fc79d49629af2fccd81840cdfbb4910991f50a477cbd29edd8a47c4fec9d141f50dfde7c4d8fcab473eff3cc2ee9e7cc90871f180777a97841597b0dd7e779eff9784b9cc33689fd7d48c0dcd341515ac8fecf5c55a6327aea8d58f97220b7462373e84e3b7417a57e80ce946d6120db5" - ], - -- COUNT = 4 - [ "74755f196305f7fb6689b2fe6835dc1d81484fc481a6b8087f649a1952f4df6a" - , "c36387a544a5f2b78007651a7b74b749" - , "" - , "" - , "" - , "b2896f3af4375dab67e8062d82c1a005ef4ed119d13a9f18371b1b873774418684805fd659bfd69964f83a5cfe08667ddad672cafd16befffa9faed49865214f703951b443e6dca22edb636f3308380144b9333de4bcb0735710e4d9266786342fc53babe7bdbe3c01a3addb7f23c63ce2834729fabbd419b47beceb4a460236" - ], - -- COUNT = 5 - [ "4b222718f56a3260b3c2625a4cf80950b7d6c1250f170bd5c28b118abdf23b2f" - , "7aed52d0016fcaef0b6492bc40bbe0e9" - , "" - , "" - , "" - , "a6da029b3665cd39fd50a54c553f99fed3626f4902ffe322dc51f0670dfe8742ed48415cf04bbad5ed3b23b18b7892d170a7dcf3ef8052d5717cb0c1a8b3010d9a9ea5de70ae5356249c0e098946030c46d9d3d209864539444374d8fbcae068e1d6548fa59e6562e6b2d1acbda8da0318c23752ebc9be0c1c1c5b3cf66dd967" - ], - -- COUNT = 6 - [ "b512633f27fb182a076917e39888ba3ff35d23c3742eb8f3c635a044163768e0" - , "e2c39b84629a3de5c301db5643af1c21" - , "" - , "" - , "" - , "fb931d0d0194a97b48d5d4c231fdad5c61aedf1c3a55ac24983ecbf38487b1c93396c6b86ff3920cfa8c77e0146de835ea5809676e702dee6a78100da9aa43d8ec0bf5720befa71f82193205ac2ea403e8d7e0e6270b366dc4200be26afd9f63b7e79286a35c688c57cbff55ac747d4c28bb80a2b2097b3b62ea439950d75dff" - ], - -- COUNT = 7 - [ "aae3ffc8605a975befefcea0a7a286642bc3b95fb37bd0eb0585a4cabf8b3d1e" - , "9504c3c0c4310c1c0746a036c91d9034" - , "" - , "" - , "" - , "2819bd3b0d216dad59ddd6c354c4518153a2b04374b07c49e64a8e4d055575dfbc9a8fcde68bd257ff1ba5c6000564b46d6dd7ecd9c5d684fd757df62d85211575d3562d7814008ab5c8bc00e7b5a649eae2318665b55d762de36eba00c2906c0e0ec8706edb493e51ca5eb4b9f015dc932f262f52a86b11c41e9a6d5b3bd431" - ], - -- COUNT = 8 - [ "b9475210b79b87180e746df704b3cbc7bf8424750e416a7fbb5ce3ef25a82cc6" - , "24baf03599c10df6ef44065d715a93f7" - , "" - , "" - , "" - , "ae12d784f796183c50db5a1a283aa35ed9a2b685dacea97c596ff8c294906d1b1305ba1f80254eb062b874a8dfffa3378c809ab2869aa51a4e6a489692284a25038908a347342175c38401193b8afc498077e10522bec5c70882b7f760ea5946870bd9fc72961eedbe8bff4fd58c7cc1589bb4f369ed0d3bf26c5bbc62e0b2b2" - ], - -- COUNT = 9 - [ "27838eb44ceccb4e36210703ebf38f659bc39dd3277cd76b7a9bcd6bc964b628" - , "39cfe0210db2e7b0eb52a387476e7ea1" - , "" - , "" - , "" - , "e5e72a53605d2aaa67832f97536445ab774dd9bff7f13a0d11fd27bf6593bfb52309f2d4f09d147192199ea584503181de87002f4ee085c7dc18bf32ce5315647a3708e6f404d6588c92b2dda599c131aa350d18c747b33dc8eda15cf40e95263d1231e1b4b68f8d829f86054d49cfdb1b8d96ab0465110569c8583a424a099a" - ], - -- COUNT = 10 - [ "d7129e4f47008ad60c9b5d081ff4ca8eb821a6e4deb91608bf4e2647835373a5" - , "a72882773f78c2fc4878295840a53012" - , "" - , "" - , "" - , "0cbf48585c5de9183b7ff76557f8fc9ebcfdfde07e588a8641156f61b7952725bbee954f87e9b937513b16bba0f2e523d095114658e00f0f3772175acfcb3240a01de631c19c5a834c94cc58d04a6837f0d2782fa53d2f9f65178ee9c837222494c799e64c60406069bd319549b889fa00a0032dd7ba5b1cc9edbf58de82bfcd" - ], - -- COUNT = 11 - [ "67fe5e300c513371976c80de4b20d4473889c9f1214bce718bc32d1da3ab7532" - , "e256d88497738a33923aa003a8d7845c" - , "" - , "" - , "" - , "b44660d64ef7bcebc7a1ab71f8407a02285c7592d755ae6766059e894f694373ed9c776c0cfc8594413eefb400ed427e158d687e28da3ecc205e0f7370fb089676bbb0fa591ec8d916c3d5f18a3eb4a417120705f3e2198154cd60648dbfcfc901242e15711cacd501b2c2826abe870ba32da785ed6f1fdc68f203d1ab43a64f" - ], - -- COUNT = 12 - [ "de8142541255c46d66efc6173b0fe3ffaf5936c897a3ce2e9d5835616aafa2cb" - , "d01f9002c407127bc3297a561d89b81d" - , "" - , "" - , "" - , "64d1020929d74716446d8a4e17205d0756b5264867811aa24d0d0da8644db25d5cde474143c57d12482f6bf0f31d10af9d1da4eb6d701bdd605a8db74fb4e77f79aaa9e450afda50b18d19fae68f03db1d7b5f1738d2fdce9ad3ee9461b58ee242daf7a1d72c45c9213eca34e14810a9fca5208d5c56d8066bab1586f1513de7" - ], - -- COUNT = 13 - [ "4a8e0bd90bdb12f7748ad5f147b115d7385bb1b06aee7d8b76136a25d779bcb7" - , "7f3cce4af8c8ce3c45bdf23c6b181a00" - , "" - , "" - , "" - , "320c7ca4bbeb7af977bc054f604b5086a3f237aa5501658112f3e7a33d2231f5536d2c85c1dad9d9b0bf7f619c81be4854661626839c8c10ae7fdc0c0b571be34b58d66da553676167b00e7d8e49f416aacb2926c6eb2c66ec98bffae20864cf92496db15e3b09e530b7b9648be8d3916b3c20a3a779bec7d66da63396849aaf" - ], - -- COUNT = 14 - [ "451ed024bc4b95f1025b14ec3616f5e42e80824541dc795a2f07500f92adc665" - , "2f28e6ee8de5879db1eccd58c994e5f0" - , "" - , "" - , "" - , "3fb637085ab75f4e95655faae95885166a5fbb423bb03dbf0543be063bcd48799c4f05d4e522634d9275fe02e1edd920e26d9accd43709cb0d8f6e50aa54a5f3bdd618be23cf73ef736ed0ef7524b0d14d5bef8c8aec1cf1ed3e1c38a808b35e61a44078127c7cb3a8fd7addfa50fcf3ff3bc6d6bc355d5436fe9b71eb44f7fd" - ] - ] - -{- - [SHA-256] - [PredictionResistance = False] - [EntropyInputLen = 256] - [NonceLen = 128] - [PersonalizationStringLen = 0] - [AdditionalInputLen = 256] - [ReturnedBitsLen = 1024] --} - -t2 :: [TestVector] -t2 = - [ - -- COUNT = 0 - [ "d3cc4d1acf3dde0c4bd2290d262337042dc632948223d3a2eaab87da44295fbd" - , "0109b0e729f457328aa18569a9224921" - , "" - , "3c311848183c9a212a26f27f8c6647e40375e466a0857cc39c4e47575d53f1f6" - , "fcb9abd19ccfbccef88c9c39bfb3dd7b1c12266c9808992e305bc3cff566e4e4" - , "9c7b758b212cd0fcecd5daa489821712e3cdea4467b560ef5ddc24ab47749a1f1ffdbbb118f4e62fcfca3371b8fbfc5b0646b83e06bfbbab5fac30ea09ea2bc76f1ea568c9be0444b2cc90517b20ca825f2d0eccd88e7175538b85d90ab390183ca6395535d34473af6b5a5b88f5a59ee7561573337ea819da0dcc3573a22974" - ], - -- COUNT = 1 - [ "f97a3cfd91faa046b9e61b9493d436c4931f604b22f1081521b3419151e8ff06" - , "11f3a7d43595357d58120bd1e2dd8aed" - , "" - , "517289afe444a0fe5ed1a41dbbb5eb17150079bdd31e29cf2ff30034d8268e3b" - , "88028d29ef80b4e6f0fe12f91d7449fe75062682e89c571440c0c9b52c42a6e0" - , "c6871cff0824fe55ea7689a52229886730450e5d362da5bf590dcf9acd67fed4cb32107df5d03969a66b1f6494fdf5d63d5b4d0d34ea7399a07d0116126d0d518c7c55ba46e12f62efc8fe28a51c9d428e6d371d7397ab319fc73ded4722e5b4f30004032a6128df5e7497ecf82ca7b0a50e867ef6728a4f509a8c859087039c" - ], - -- COUNT = 2 - [ "0f2f23d64f481cabec7abb01db3aabf125c3173a044b9bf26844300b69dcac8b" - , "9a5ae13232b43aa19cfe8d7958b4b590" - , "" - , "ec4c7a62acab73385f567da10e892ff395a0929f959231a5628188ce0c26e818" - , "6b97b8c6b6bb8935e676c410c17caa8042aa3145f856d0a32b641e4ae5298648" - , "7480a361058bd9afa3db82c9d7586e42269102013f6ec5c269b6d05f17987847748684766b44918fd4b65e1648622fc0e0954178b0279dfc9fa99b66c6f53e51c4860131e9e0644287a4afe4ca8e480417e070db68008a97c3397e4b320b5d1a1d7e1d18a95cfedd7d1e74997052bf649d132deb9ec53aae7dafdab55e6dae93" - ], - -- COUNT = 3 - [ "53c56660c78481be9c63284e005fcc14fbc7fb27732c9bf1366d01a426765a31" - , "dc7a14d0eb5b0b3534e717a0b3c64614" - , "" - , "3aa848706ecb877f5bedf4ffc332d57c22e08747a47e75cff6f0fd1316861c95" - , "9a401afa739b8f752fddacd291e0b854f5eff4a55b515e20cb319852189d3722" - , "5c0eb420e0bf41ce9323e815310e4e8303cd677a8a8b023f31f0d79f0ca15aeb636099a369fd074d69889865eac1b72ab3cbfebdb8cf460b00072802e2ec648b1349a5303be4ccaadd729f1a9ea17482fd026aaeb93f1602bc1404b9853adde40d6c34b844cf148bc088941ecfc1642c8c0b9778e45f3b07e06e21ee2c9e0300" - ], - -- COUNT = 4 - [ "f63c804404902db334c54bb298fc271a21d7acd9f770278e089775710bf4fdd7" - , "3e45009ea9cb2a36ba1aa4bf39178200" - , "" - , "d165a13dc8cc43f3f0952c3f5d3de4136954d983683d4a3e6d2dc4c89bf23423" - , "75106bc86d0336df85097f6af8e80e2da59046a03fa65b06706b8bbc7ffc6785" - , "6363139bba32c22a0f5cd23ca6d437b5669b7d432f786b8af445471bee0b2d24c9d5f2f93717cbe00d1f010cc3b9c515fc9f7336d53d4d26ba5c0d76a90186663c8582eb739c7b6578a3328bf68dc2cec2cd89b3a90201f6993adcc854df0f5c6974d0f5570765a15fe03dbce28942dd2fd16ba2027e68abac83926969349af8" - ], - -- COUNT = 5 - [ "2aaca9147da66c176615726b69e3e851cc3537f5f279fe7344233d8e44cfc99d" - , "4e171f080af9a6081bee9f183ac9e340" - , "" - , "d75a2a6eb66c3833e50f5ec3d2e434cf791448d618026d0c360806d120ded669" - , "b643b74c15b37612e6577ed7ca2a4c67a78d560af9eb50a4108fca742e87b8d6" - , "501dcdc977f4ba856f24eaa4968b374bebb3166b280334cb510232c31ebffde10fa47b7840ef3fe3b77725c2272d3a1d4219baf23e0290c622271edcced58838cf428f0517425d2e19e0d8c89377eecfc378245f283236fafa466c914b99672ceafab369e8889a0c866d8bd639db9fb797254262c6fd44cfa9045ad6340a60ef" - ], - -- COUNT = 6 - [ "a2e4cd48a5cf918d6f55942d95fcb4e8465cdc4f77b7c52b6fae5b16a25ca306" - , "bef036716440db6e6d333d9d760b7ca8" - , "" - , "bfa591c7287f3f931168f95e38869441d1f9a11035ad8ea625bb61b9ea17591c" - , "c00c735463bca215adc372cb892b05e939bf669583341c06d4e31d0e5b363a37" - , "e7d136af69926a5421d4266ee0420fd729f2a4f7c295d3c966bdfa05268180b508b8a2852d1b3a06fd2ab3e13c54005123ef319f42d0c6d3a575e6e7e1496cb28aacadbcf83740fba8f35fcee04bb2ed8a51db3d3362b01094a62fb57e33c99a432f29fce6676cffbbcc05107e794e75e44a02d5e6d9d748c5fbff00a0178d65" - ], - -- COUNT = 7 - [ "95a67771cba69011a79776e713145d309edae56fad5fd6d41d83eaff89df6e5e" - , "be5b5164e31ecc51ba6f7c3c5199eb33" - , "" - , "065f693b229a7c4fd373cd15b3807552dd9bf98c5485cef361949d4e7d774b53" - , "9afb62406f0e812c4f156d58b19a656c904813c1b4a45a0029ae7f50731f8014" - , "f61b61a6e79a41183e8ed6647899d2dc85cdaf5c3abf5c7f3bf37685946dc28f4923dc842f2d4326bd6ce0d50a84cb3ba869d72a36e246910eba6512ba36cd7ed3a5437c9245b00a344308c792b668b458d3c3e16dee2fbec41867da31084d46d8ec168de2148ef64fc5b72069abf5a6ada1ead2b7146bb793ff1c9c3690fa56" - ], - -- COUNT = 8 - [ "a459e1815cbca4514ec8094d5ab2414a557ba6fe10e613c345338d0521e4bf90" - , "62221392e2552e76cd0d36df6e6068eb" - , "" - , "0a3642b02b23b3ef62c701a63401124022f5b896de86dab6e6c7451497aa1dcc" - , "c80514865901371c45ba92d9f95d50bb7c9dd1768cb3dfbc45b968da94965c6e" - , "464e6977b8adaef307c9623e41c357013249c9ffd77f405f3925cebb69f151ce8fbb6a277164002aee7858fc224f6499042aa1e6322deee9a5d133c31d640e12a7487c731ba03ad866a24675badb1d79220c40be689f79c2a0be93cb4dada3e0eac4ab140cb91998b6f11953e68f2319b050c40f71c34de9905ae41b2de1c2f6" - ], - -- COUNT = 9 - [ "252c2cad613e002478162861880979ee4e323025eebb6fb2e0aa9f200e28e0a1" - , "d001bc9a8f2c8c242e4369df0c191989" - , "" - , "9bcfc61cb2bc000034bb3db980eb47c76fb5ecdd40553eff113368d639b947fd" - , "8b0565c767c2610ee0014582e9fbecb96e173005b60e9581503a6dca5637a26e" - , "e96c15fe8a60692b0a7d67171e0195ff6e1c87aab844221e71700d1bbee75feea695f6a740c9760bbe0e812ecf4061d8f0955bc0195e18c4fd1516ebca50ba6a6db86881737dbab8321707675479b87611db6af2c97ea361a5484555ead454defb1a64335de964fc803d40f3a6f057893d2afc25725754f4f00abc51920743dc" - ], - -- COUNT = 10 - [ "8be0ca6adc8b3870c9d69d6021bc1f1d8eb9e649073d35ee6c5aa0b7e56ad8a5" - , "9d1265f7d51fdb65377f1e6edd6ae0e4" - , "" - , "da86167ac997c406bb7979f423986a84ec6614d6caa7afc10aff0699a9b2cf7f" - , "e4baa3c555950b53e2bfdba480cb4c94b59381bac1e33947e0c22e838a9534cf" - , "64384ecc4ea6b458efc227ca697eac5510092265520c0a0d8a0ccf9ed3ca9d58074671188c6a7ad16d0b050cdc072c125d7298d3a31d9f044a9ee40da0089a84fea28cc7f05f1716db952fad29a0e779635cb7a912a959be67be2f0a4170aace2981802e2ff6467e5b46f0ffbff3b42ba5935fd553c82482ac266acf1cd247d7" - ], - -- COUNT = 11 - [ "d43a75b6adf26d60322284cb12ac38327792442aa8f040f60a2f331b33ac4a8f" - , "0682f8b091f811afacaacaec9b04d279" - , "" - , "7fd3b8f512940da7de5d80199d9a7b42670c04a945775a3dba869546cbb9bc65" - , "2575db20bc7aafc2a90a5dabab760db851d754777bc9f05616af1858b24ff3da" - , "0da7a8dc73c163014bf0841913d3067806456bbca6d5de92b85534c6545467313648d71ef17c923d090dc92cff8d4d1a9a2bb63e001dc2e8ab1a597999be3d6cf70ff63fee9985801395fbd4f4990430c4259fcae4fa1fcd73dc3187ccc102d04af7c07532885e5a226fc42809c48f22eecf4f6ab996ae4fcb144786957d9f41" - ], - -- COUNT = 12 - [ "64352f236af5d32067a529a8fd05ba00a338c9de306371a0b00c36e610a48d18" - , "df99ed2c7608c870624b962a5dc68acd" - , "" - , "da416335e7aaf60cf3d06fb438735ce796aad09034f8969c8f8c3f81e32fef24" - , "a28c07c21a2297311adf172c19e83ca0a87731bdffb80548978d2d1cd82cf8a3" - , "132b9f25868729e3853d3c51f99a3b5fae6d4204bea70890daf62e042b776a526c8fb831b80a6d5d3f153237df1fd39b6fd9137963f5516d9cdd4e3f9195c46e9972c15d3edc6606e3368bde1594977fb88d0ca6e6f5f3d057ccadc7d7dab77dfc42658a1e972aa446b20d418286386a52dfc1c714d2ac548713268b0b709729" - ], - -- COUNT = 13 - [ "282f4d2e05a2cd30e9087f5633089389449f04bac11df718c90bb351cd3653a5" - , "90a7daf3c0de9ea286081efc4a684dfb" - , "" - , "2630b4ccc7271cc379cb580b0aaede3d3aa8c1c7ba002cf791f0752c3d739007" - , "c31d69de499f1017be44e3d4fa77ecebc6a9b9934749fcf136f267b29115d2cc" - , "c899094520e0197c37b91dd50778e20a5b950decfb308d39f1db709447ae48f6101d9abe63a783fbb830eec1d359a5f61a2013728966d349213ee96382614aa4135058a967627183810c6622a2158cababe3b8ab99169c89e362108bf5955b4ffc47440f87e4bad0d36bc738e737e072e64d8842e7619f1be0af1141f05afe2d" - ], - -- COUNT = 14 - [ "13c752b9e745ce77bbc7c0dbda982313d3fe66f903e83ebd8dbe4ff0c11380e9" - , "f1a533095d6174164bd7c82532464ae7" - , "" - , "4f53db89b9ba7fc00767bc751fb8f3c103fe0f76acd6d5c7891ab15b2b7cf67c" - , "582c2a7d34679088cca6bd28723c99aac07db46c332dc0153d1673256903b446" - , "6311f4c0c4cd1f86bd48349abb9eb930d4f63df5e5f7217d1d1b91a71d8a6938b0ad2b3e897bd7e3d8703db125fab30e03464fad41e5ddf5bf9aeeb5161b244468cfb26a9d956931a5412c97d64188b0da1bd907819c686f39af82e91cfeef0cbffb5d1e229e383bed26d06412988640706815a6e820796876f416653e464961" - ] - ] - -{- - [SHA-256] - [PredictionResistance = False] - [EntropyInputLen = 256] - [NonceLen = 128] - [PersonalizationStringLen = 256] - [AdditionalInputLen = 0] - [ReturnedBitsLen = 1024] --} - -t3 :: [TestVector] -t3 = - [ - -- COUNT = 0 - [ "5cacc68165a2e2ee20812f35ec73a79dbf30fd475476ac0c44fc6174cdac2b55" - , "6f885496c1e63af620becd9e71ecb824" - , "e72dd8590d4ed5295515c35ed6199e9d211b8f069b3058caa6670b96ef1208d0" - , "" - , "" - , "f1012cf543f94533df27fedfbf58e5b79a3dc517a9c402bdbfc9a0c0f721f9d53faf4aafdc4b8f7a1b580fcaa52338d4bd95f58966a243cdcd3f446ed4bc546d9f607b190dd69954450d16cd0e2d6437067d8b44d19a6af7a7cfa8794e5fbd728e8fb2f2e8db5dd4ff1aa275f35886098e80ff844886060da8b1e7137846b23b" - ], - -- COUNT = 1 - [ "8df013b4d103523073917ddf6a869793059e9943fc8654549e7ab22f7c29f122" - , "da2625af2ddd4abcce3cf4fa4659d84e" - , "b571e66d7c338bc07b76ad3757bb2f9452bf7e07437ae8581ce7bc7c3ac651a9" - , "" - , "" - , "b91cba4cc84fa25df8610b81b641402768a2097234932e37d590b1154cbd23f97452e310e291c45146147f0da2d81761fe90fba64f94419c0f662b28c1ed94da487bb7e73eec798fbcf981b791d1be4f177a8907aa3c401643a5b62b87b89d66b3a60e40d4a8e4e9d82af6d2700e6f535cdb51f75c321729103741030ccc3a56" - ], - -- COUNT = 2 - [ "565b2b77937ba46536b0f693b3d5e4a8a24563f9ef1f676e8b5b2ef17823832f" - , "4ef3064ec29f5b7f9686d75a23d170e3" - , "3b722433226c9dba745087270ab3af2c909425ba6d39f5ce46f07256068319d9" - , "" - , "" - , "d144ee7f8363d128872f82c15663fe658413cd42651098e0a7c51a970de75287ec943f9061e902280a5a9e183a7817a44222d198fbfab184881431b4adf35d3d1019da5a90b3696b2349c8fba15a56d0f9d010a88e3f9eeedb67a69bcaa71281b41afa11af576b765e66858f0eb2e4ec4081609ec81da81df0a0eb06787340ea" - ], - -- COUNT = 3 - [ "fc3832a91b1dcdcaa944f2d93cbceb85c267c491b7b59d017cde4add79a836b6" - , "d5e76ce9eabafed06e33a913e395c5e0" - , "ffc5f6eefd51da64a0f67b5f0cf60d7ab43fc7836bca650022a0cee57a43c148" - , "" - , "" - , "0e713c6cc9a4dbd4249201d12b7bf5c69c3e18eb504bf3252db2f43675e17d99b6a908400cea304011c2e54166dae1f20260008efe4e06a87e0ce525ca482bca223a902a14adcf2374a739a5dfeaf14cadd72efa4d55d15154c974d9521535bcb70658c5b6c944020afb04a87b223b4b8e5d89821704a9985bb010405ba8f3d4" - ], - -- COUNT = 4 - [ "8009eb2cb49fdf16403bcdfd4a9f952191062acb9cc111eca019f957fb9f4451" - , "355598866952394b1eddd85d59f81c9d" - , "09ff1d4b97d83b223d002e05f754be480d13ba968e5aac306d71cc9fc49cc2dd" - , "" - , "" - , "9550903c2f02cf77c8f9c9a37041d0040ee1e3ef65ba1a1fbbcf44fb7a2172bd6b3aaabe850281c3a1778277bacd09614dfefececac64338ae24a1bf150cbf9d9541173a82ecba08aa19b75abb779eb10efa4257d5252e8afcac414bc3bb5d3006b6f36fb9daea4c8c359ef6cdbeff27c1068571dd3c89dc87eda9190086888d" - ], - -- COUNT = 5 - [ "a6e4c9a8bd6da23b9c2b10a7748fd08c4f782fadbac7ea501c17efdc6f6087bd" - , "acdc47edf1d3b21d0aec7631abb6d7d5" - , "c16ee0908a5886dccf332fbc61de9ec7b7972d2c4c83c477409ce8a15c623294" - , "" - , "" - , "a52f93ccb363e2bdf0903622c3caedb7cffd04b726052b8d455744c71b76dee1b71db9880dc3c21850489cb29e412d7d80849cfa9151a151dcbf32a32b4a54cac01d3200200ed66a3a5e5c131a49655ffbf1a8824ff7f265690dffb4054df46a707b9213924c631c5bce379944c856c4f7846e281ac89c64fad3a49909dfb92b" - ], - -- COUNT = 6 - [ "59d6307460a9bdd392dfc0904973991d585696010a71e52d590a5039b4849fa4" - , "34a0aafb95917cbf8c38fc5548373c05" - , "0407b7c57bc11361747c3d67526c36e228028a5d0b145d66ab9a2fe4b07507a0" - , "" - , "" - , "299aba0661315211b09d2861855d0b4b125ab24649461341af6abd903ed6f025223b3299f2126fcad44c675166d800619cf49540946b12138989417904324b0ddad121327211a297f11259c9c34ce4c70c322a653675f78d385e4e2443f8058d141195e17e0bd1b9d44bf3e48c376e6eb44ef020b11cf03eb141c46ecb43cf3d" - ], - -- COUNT = 7 - [ "9ae3506aadbc8358696ba1ba17e876e1157b7048235921503d36d9211b430342" - , "9abf7d66afee5d2b811cba358bbc527d" - , "0d645f6238e9ceb038e4af9772426ca110c5be052f8673b8b5a65c4e53d2f519" - , "" - , "" - , "5f032c7fec6320fe423b6f38085cbad59d826085afe915247b3d546c4c6b174554dd4877c0d671de9554b505393a44e71f209b70f991ac8aa6e08f983fff2a4c817b0cd26c12b2c929378506489a75b2025b358cb5d0400821e7e252ac6376cd94a40c911a7ed8b6087e3de5fa39fa6b314c3ba1c593b864ce4ff281a97c325b" - ], - -- COUNT = 8 - [ "96ae3b8775b36da2a29b889ad878941f43c7d51295d47440cd0e3c4999193109" - , "1fe022a6fc0237b055d4d6a7036b18d5" - , "1e40e97362d0a823d3964c26b81ab53825c56446c5261689011886f19b08e5c2" - , "" - , "" - , "e707cd14b06ce1e6dbcceaedbf08d88891b03f44ad6a797bd12fdeb557d0151df9346a028dec004844ca46adec3051dafb345895fa9f4604d8a13c8ff66ae093fa63c4d9c0816d55a0066d31e8404c841e87b6b2c7b5ae9d7afb6840c2f7b441bf2d3d8bd3f40349c1c014347c1979213c76103e0bece26ad7720601eff42275" - ], - -- COUNT = 9 - [ "33f5120396336e51ee3b0b619b5f873db05ca57cda86aeae2964f51480d14992" - , "6f1f6e9807ba5393edcf3cb4e4bb6113" - , "3709605af44d90196867c927512aa8ba31837063337b4879408d91a05c8efa9f" - , "" - , "" - , "8b8291126ded9acef12516025c99ccce225d844308b584b872c903c7bc6467599a1cead003dc4c70f6d519f5b51ce0da57f53da90dbe8f666a1a1dde297727fee2d44cebd1301fc1ca75956a3fcae0d374e0df6009b668fd21638d2b733e6902d22d5bfb4af1b455975e08eef0ebe4dc87705801e7776583c8de11672729f723" - ], - -- COUNT = 10 - [ "ad300b799005f290fee7f930eebce158b98fb6cb449987fe433f955456b35300" - , "06aa2514e4bd114edf7ac105cfef2772" - , "87ada711465e4169da2a74c931afb9b5a5b190d07b7af342aa99570401c3ee8a" - , "" - , "" - , "80d7c606ff49415a3a92ba1f2943235c01339c8f9cd0b0511fbfdf3ef23c42ffff008524193faaa4b7f2f2eb0cfa221d9df89bd373fe4e158ec06fad3ecf1eb48b8239b0bb826ee69d773883a3e8edac66254610ff70b6609836860e39ea1f3bfa04596fee1f2baca6cebb244774c6c3eb4af1f02899eba8f4188f91776de16f" - ], - -- COUNT = 11 - [ "130b044e2c15ab89375e54b72e7baae6d4cad734b013a090f4df057e634f6ff0" - , "65fd6ac602cd44107d705dbc066e52b6" - , "f374aba16f34d54aae5e494505b67d3818ef1c08ea24967a76876d4361379aec" - , "" - , "" - , "5d179534fb0dba3526993ed8e27ec9f915183d967336bb24352c67f4ab5d7935d3168e57008da851515efbaecb69904b6d899d3bfa6e9805659aef2942c4903875b8fcbc0d1d24d1c075f0ff667c1fc240d8b410dff582fa71fa30878955ce2ed786ef32ef852706e62439b69921f26e84e0f54f62b938f04905f05fcd7c2204" - ], - -- COUNT = 12 - [ "716430e999964b35459c17921fe5f60e09bd9ab234cb8f4ba4932bec4a60a1d5" - , "9533b711e061b07d505da707cafbca03" - , "372ae616d1a1fc45c5aecad0939c49b9e01c93bfb40c835eebd837af747f079d" - , "" - , "" - , "a80d6a1b2d0ce01fe0d26e70fb73da20d45841cf01bfbd50b90d2751a46114c0e758cb787d281a0a9cf62f5c8ce2ee7ca74fefff330efe74926acca6d6f0646e4e3c1a1e52fce1d57b88beda4a5815896f25f38a652cc240deb582921c8b1d03a1da966dd04c2e7eee274df2cd1837096b9f7a0d89a82434076bc30173229a60" - ], - -- COUNT = 13 - [ "7679f154296e6d580854826539003a82d1c54e2e062c619d00da6c6ac820789b" - , "55d12941b0896462e7d888e5322a99a3" - , "ba4d1ed696f58ef64596c76cee87cc1ca83069a79e7982b9a06f9d62f4209faf" - , "" - , "" - , "10dc7cd2bb68c2c28f76d1b04ae2aa287071e04c3b688e1986b05cc1209f691daa55868ebb05b633c75a40a32b49663185fe5bb8f906008347ef51590530948b87613920014802e5864e0758f012e1eae31f0c4c031ef823aecfb2f8a73aaa946fc507037f9050b277bdeaa023123f9d22da1606e82cb7e56de34bf009eccb46" - ], - -- COUNT = 14 - [ "8ca4a964e1ff68753db86753d09222e09b888b500be46f2a3830afa9172a1d6d" - , "a59394e0af764e2f21cf751f623ffa6c" - , "eb8164b3bf6c1750a8de8528af16cffdf400856d82260acd5958894a98afeed5" - , "" - , "" - , "fc5701b508f0264f4fdb88414768e1afb0a5b445400dcfdeddd0eba67b4fea8c056d79a69fd050759fb3d626b29adb8438326fd583f1ba0475ce7707bd294ab01743d077605866425b1cbd0f6c7bba972b30fbe9fce0a719b044fcc1394354895a9f8304a2b5101909808ddfdf66df6237142b6566588e4e1e8949b90c27fc1f" - ] - ] - -{- - [SHA-256] - [PredictionResistance = False] - [EntropyInputLen = 256] - [NonceLen = 128] - [PersonalizationStringLen = 256] - [AdditionalInputLen = 256] - [ReturnedBitsLen = 1024] --} - -t4 :: [TestVector] -t4 = - [ - -- COUNT = 0 - [ "5d3286bc53a258a53ba781e2c4dcd79a790e43bbe0e89fb3eed39086be34174b" - , "c5422294b7318952ace7055ab7570abf" - , "2dba094d008e150d51c4135bb2f03dcde9cbf3468a12908a1b025c120c985b9d" - , "793a7ef8f6f0482beac542bb785c10f8b7b406a4de92667ab168ecc2cf7573c6" - , "2238cdb4e23d629fe0c2a83dd8d5144ce1a6229ef41dabe2a99ff722e510b530" - , "d04678198ae7e1aeb435b45291458ffde0891560748b43330eaf866b5a6385e74c6fa5a5a44bdb284d436e98d244018d6acedcdfa2e9f499d8089e4db86ae89a6ab2d19cb705e2f048f97fb597f04106a1fa6a1416ad3d859118e079a0c319eb95686f4cbcce3b5101c7a0b010ef029c4ef6d06cdfac97efb9773891688c37cf" - ], - -- COUNT = 1 - [ "c2a566a9a1817b15c5c3b778177ac87c24e797be0a845f11c2fe399dd37732f2" - , "cb1894eb2b97b3c56e628329516f86ec" - , "13ce4d8dd2db9796f94156c8e8f0769b0aa1c82c1323b61536603bca37c9ee29" - , "413dd83fe56835abd478cb9693d67635901c40239a266462d3133b83e49c820b" - , "d5c4a71f9d6d95a1bedf0bd2247c277d1f84a4e57a4a8825b82a2d097de63ef1" - , "b3a3698d777699a0dd9fa3f0a9fa57832d3cefac5df24437c6d73a0fe41040f1729038aef1e926352ea59de120bfb7b073183a34106efed6278ff8ad844ba0448115dfddf3319a82de6bb11d80bd871a9acd35c73645e1270fb9fe4fa88ec0e465409ea0cba809fe2f45e04943a2e396bbb7dd2f4e0795303524cc9cc5ea54a1" - ], - -- COUNT = 2 - [ "a33288a96f41dd54b945e060c8bd0c094f1e28267cc1dcbba52063c1a9d54c4d" - , "36918c977e1a7276a2bb475591c367b7" - , "6aa528c940962638dc2201738850fd1fe6f5d0eb9f687ff1af39d9c7b36830d9" - , "37ee633a635e43af59abdb1762c7ea45bfe060ec1d9077ecd2a43a658673f3c7" - , "2eb96f2e28fa9f674bb03ade703b8f791ee5356e2ee85c7ed5bda96325256c61" - , "db2f91932767eb846961ce5321c7003431870508e8c6f8d432ca1f9cee5cdc1aed6e0f133d317eb6990c4b3b0a360cdfb5b43a6e712bd46bca04c414868fab22c6a49c4b89c812697c3a7fbfc8ddf10c8aa5ebf13a09fd114eb2a02a07f69786f3ce7fd30231f22779bc8db103b13fa546dbc45a89a86275281172761683d384" - ], - -- COUNT = 3 - [ "5f37b6e47e1776e735adc03d4b999879477ff4a206231924033d94c0114f911b" - , "7d12d62c79c9f6234ae0314156947459" - , "92d4d9fab5f8bf5119f2663a9df7334f50dcde74fb9d7732f7eba56501e60d54" - , "c9aef0d7a9ba7345d08b6d5b5ce5645c7495b8685e6b93846ffcf470f5abd40d" - , "50d9d1f5074f7d9f1a24a9c63aa47b94da5ba78db1b0f18e4d4fe45c6875813c" - , "20d942bbd7d98700faa37e94d53bf74f2d6bd1d8c95c0b88d842c4857797d59e7c8788aeeac29740122f208f703bf35dc32b0035db0648384feb6aa17a3274bc09b2d2b746c5a06fd82f4469fb86131a49482cb7be7d9b4b95042394cfb18b13f333ec0fe5c227bf1d8f33ecb2e42e358b6c3e034cb585331bd1d27f638029b9" - ], - -- COUNT = 4 - [ "2311c5afd64c584484b2729e84db80c0b4063fe9ca7edc83350488d7e67264a0" - , "6a6dfd975a0dc7b72df1f107c4b3b3a6" - , "2abd870ec5fe26ed14dfa57a3309f920131b70580c3639af2645cd1af93db1b1" - , "c6e532a3b25653b6002aed5269cc2118749306e736bde039d4d569d4f967773f" - , "5e7d26c4da769c373092b2b4f72b109fe34bdb7d169ea38f78ebae5df4a15759" - , "cacaeb1b4ac2305d8714eb50cbe1c67c5a2c0bbc7938fdfdcafef7c85fc40becbf777a4cfb6f14c6eee320943a493d2b0a744a6eb3c256ee9a3763037437df9adce3e2260f0c35e958af0edb5a81debd8bdaf2b8bb2b98b9186e5a222a21609ff58df4cbe1d4898d10d6e7c46f31f5cb1041bfd83a5fb27d5c56c961e91403fc" - ], - -- COUNT = 5 - [ "362ece9d330e1172a8f9e50258476d0c79c3ee50346524ba12d970ee3a6ef8c5" - , "cf11bcb4d9d51311ceacfca8705e833f" - , "abb5a8edde02e526449284ecc31bc713383df3ed085f752e3b6a32f305861eed" - , "746302ab1f4a86b17546bea762e929360f2e95c7788a63545a264ef997c8c65e" - , "b907c5b2a8833a48e56e819228ce9a050b41b3309f5ca37bed720311d92b33af" - , "73c7131a558350590053580873ef956ff952f2aa6ff1bea452e013d1bc2afddea2311756dbe756e63ba6258480c48f3f6c1319b5f572f67ca530af09e39413d1d432bea8f89206619618cb0e7c88e9f2033639d0eb0efc20616b64f940da99b88231984c3fb23f19e890576f555fde394dbd4351f17a7ffd5c369379001bda03" - ], - -- COUNT = 6 - [ "cf614bc29946bc0095f415e8bdeda10aab05392f9cc9187a86ea6ec95ee422e1" - , "77fb5ec22dc0432cc13f4693e2e3bd9a" - , "e4ce77914ffbc5fddf1fb51edfafdc196109139b84c741354135ec8d314c7c43" - , "e1e83ee1205acaf6164dc287aec08e5b32789e5be818078db39e53cad589db51" - , "4e20c0226d5e1e7e805679f03f72452b5bea2d0ba41e0c12329bf60eb3016dd1" - , "838fdf1418a746aa52ae4005d90c3fd301f648c5770ffef2a9f3912e37a93850cc4b8bfcce910aead0cb75958823b1a62e283901c5e4a3980e4ea36257458e2e4953555819b8852a26489b1d74821f80c9908469b43f124ff7ea62497c36159a47353098a1b9ec32e54800d6704371cc37f357ad74aacc203e9b6db97f94d0c4" - ], - -- COUNT = 7 - [ "a8da1d3e233f393fd44d204c200202f7d01896e72c5ac652940cfd15b5d4b0bd" - , "0a112b4cb0890af0a495e0f49fcf6874" - , "d2e32799bc822b8d033299bdf63dc35774f7649e935d25be5b10512c430d1bda" - , "920a82d76fcd2cd106ada64bba232b7b2344f3afe6b1d1d20ee8795144571009" - , "eeaac5878275372025f8231febed64db6a11273c3c00d625fc80a95f18ad7d3f" - , "5f6dae489b53d89027b2cc333c700f090152d77b3eaf01d47f56ce6eca9893ef877b4cb560fab0fbdb34e3d1c6cd8480b33c053d2661a10aa531df4961b97d659c7492584236582b3fe701055efa59c328194cd1e07fcffd910d9ee01b7b9e8c8fda7f7ac01a8e203b8b26eb8078a9b9a5021562c44af24089e3ef84c1d5a6bd" - ], - -- COUNT = 8 - [ "a77b1ed4ecaa650374e1052c405f1d88881c25c87d13dbe1334d8c1a847fa76b" - , "05c143e2f145db216fe7be9ed23635d0" - , "b5c750968ff09ed251d4a1c05342ac843db5246b19045728a634fa4f6e752e54" - , "ff5937bcd01a363696bf8e40adc8e4ab3e56dbf7e7d09451c99e538785fe6697" - , "4acb34eea8266badcf8f6557a0eecf3eb4d7a295c876d6175598cb66a388efb8" - , "ec13eadfcc84e77d2a2efa1a2cd8b1355587cb27feb3d19d75b37f0446333ddb8236e751c63b7a6e595ec24a25051a696dbe8c062dd8896d1446db228a2f10e8094ee07e7ee648ed6bebb2f5ec5aae24c9c640665c28355cc11c116795ecc070790f7fdfc4398900311b6695d5da0175091ed1828d2731085bfb4a20bd86cce0" - ], - -- COUNT = 9 - [ "491686c781e83eb4e21d9989e8d718100b0d21a2c56295888baef1a65f219651" - , "499085296d21065feabf3106101c8d6f" - , "d208a72f9ae34f0817669fb04f49239dd31700f3dc9a93db8d75fb79f9b686c1" - , "9ffc61893a293a864008fdd56d3292600d9e2ec8a1ea8f34ac5931e968905a23" - , "4ff3a397dfdae0912032a302a5e7a07dceca8d9013a21545689319b7c024cd07" - , "3c258ebf2203fca3b322ad1b016e21c7f5c148425f81e4fb0a0e462dce9dfa569c37a006527768297a5b68461b08912642a341b88c85597e30e7561206886098c4e2d861f11513f0ffdbbc78d3a2dd60c105abbb33c5e05ae27081b690fb8b3610917aa9bf1a4ad74481b5ff8334f14e5ad6a6a1eb2259476078076fb7e3a992" - ], - -- COUNT = 10 - [ "36a5267eeeb5a1a7d46de0f8f9281f73cd9611f01198fdaa78c5315205e5a177" - , "b66b5337970df36219321badacc624eb" - , "c2a7b164949da102bece44a423197682ff97627d1fe9654266b8527f64e5b386" - , "a977e2d8637b019c74063d163bb25387dc56f4eb40e502cefc5ae6ad26a6abdc" - , "c5c9819557b1e7d8a86fa8c60be42993edc3ef539c13d9a51fb64b0de06e145e" - , "b471711a4fc7ab7247e65d2c2fe49a50169187187b7978cd2fdb0f8318be3ec55fc68ed4577ad9b42cbb57100b5d35ac86c244c4c93a5b28c1a11c2dfe905d608ec7804dec5bb15cf8d79695534d5e13a6a7e18a887ec9cf184da0cbbc6267f3a952a769403bafcdbb559401be0d8b3300ea7258b4026fc892175efd55ba1a67" - ], - -- COUNT = 11 - [ "a76b0366df89e4073a6b6b9c04da1d6817ce26f1c4825cad4097bdf4d7b9445e" - , "773d3cc3290176773847869be528d1a4" - , "1bfd3bcfb9287a5ad055d1b2b8615fa81c94ac24bc1c219a0f8de58789e0404a" - , "edd879fa56f21d93029da875b683ce50f6fdc4c0da41da051d000eed2afefefa" - , "f528ffd29160039260133ed9654589ce60e39e7f667c34f82cda65ddcf5fff14" - , "39d1ff8848e74dd2cdc6b818ad69823878062116fdf1679942f892c7e191be1c4b6ea268ecdff001b22af0d510f30c2c25b90fc34927f46e3f45d36b0e1848b3a5d54c36c7c65ee7287d325dfbb51b56a438feb6650ce13df88bf06b87ac4a35d2a199ea888629fb0d83f82f0ea160dc79ed220d8ef195b9e80c542f60c2d320" - ], - -- COUNT = 12 - [ "46571e1df43e5e141235e2a9ec85bb0faf1dc0566031e14d41a2fbd0315653ec" - , "b60ef6a3347967519aabeaf748e4e991" - , "759fd8593e3688b23c4a003b655311770d670789878570eb3b155a8e6c2d8c45" - , "033128460b449e1accb0e9c54508759ddc2538bc64b51e6277553f0c60a02723" - , "a5e4a717240bdeac18a0c0e231a11dc04a47d7550f342fa9a7a5ff334eb9327d" - , "9d222df1d530ea7f8f2297a0c79d637da570b48042ecddded75956bba0f0e70b271ffa3c9a53bada6ee1b8a4203c22bfde82a5e2eb1b150f54c6483458569422c1a34a8997d42cc09750167a78bf52a0bd158397af9f83caabe689185c099bf0a9a4853dd3cf8b8e89efebb6a27dba873e65e9927741b22968f2875789b44e01" - ], - -- COUNT = 13 - [ "d63980e63bbe4ac08d2ac5646bf085b82c75995e3fdfc23bb9cc734cd85ca7d2" - , "d33ed1dcae13fb634ba08272d6697590" - , "acd0da070072a5340c4f5f4395568e1a36374e074196ae87f3692ee40487e1df" - , "f567677b5e12e26f3544be3da9314c88fc475bf84804a89a51f12b191392c02b" - , "c01cc7873e93c86e2bfb8fc984cfc2eab5cc58eeef018fedb5cba5aedd386156" - , "b133446f633bcb40724bbf9fa187c39a44b9c094a0a0d40e98977e5466dc2c9adf62a5f4551eeb6406a14658de8a0ed7487c3bf6277e811101284a941745ce16176acc875f1435e14161772fa84609e8123c53dd03cbb868030835c0d11d8d6aa04a1b6f908248b028997737f54735ec4ed7a81fc868199ffb61a779d9340334" - ], - -- COUNT = 14 - [ "3d99f9b7ac3a2fbe9cf15d960bf41f5588fc4db1e0d2a5c9c0fe9059f03593fb" - , "411f504bb63a9b3afa7ffa1357bb48be" - , "0bb5ebd55981a25ba69164da49fa92f2871fd3fc65eb30d0f0d0b8d798a4f8f2" - , "288e948a551284eb3cb23e26299955c2fb8f063c132a92683c1615ecaed80f30" - , "d975b22f79e34acf5db25a2a167ef60a10682dd9964e15533d75f7fa9efc5dcb" - , "ee8d707eea9bc7080d58768c8c64a991606bb808600cafab834db8bc884f866941b4a7eb8d0334d876c0f1151bccc7ce8970593dad0c1809075ce6dbca54c4d4667227331eeac97f83ccb76901762f153c5e8562a8ccf12c8a1f2f480ec6f1975ac097a49770219107d4edea54fb5ee23a8403874929d073d7ef0526a647011a" - ] - ] - -{- Reseed test vectors -} - -{- - [SHA-256] - [PredictionResistance = False] - [EntropyInputLen = 256] - [NonceLen = 128] - [PersonalizationStringLen = 0] - [AdditionalInputLen = 0] - [ReturnedBitsLen = 1024] --} - -r1 :: [TestVector] -r1 = - [ - -- COUNT = 0 - [ "06032cd5eed33f39265f49ecb142c511da9aff2af71203bffaf34a9ca5bd9c0d" - , "0e66f71edc43e42a45ad3c6fc6cdc4df" - , "" - , "01920a4e669ed3a85ae8a33b35a74ad7fb2a6bb4cf395ce00334a9c9a5a5d552" - , "" - , "" - , "" - , "76fc79fe9b50beccc991a11b5635783a83536add03c157fb30645e611c2898bb2b1bc215000209208cd506cb28da2a51bdb03826aaf2bd2335d576d519160842e7158ad0949d1a9ec3e66ea1b1a064b005de914eac2e9d4f2d72a8616a80225422918250ff66a41bd2f864a6a38cc5b6499dc43f7f2bd09e1e0f8f5885935124" - ], - -- COUNT = 1 - [ "aadcf337788bb8ac01976640726bc51635d417777fe6939eded9ccc8a378c76a" - , "9ccc9d80c89ac55a8cfe0f99942f5a4d" - , "" - , "03a57792547e0c98ea1776e4ba80c007346296a56a270a35fd9ea2845c7e81e2" - , "" - , "" - , "" - , "17d09f40a43771f4a2f0db327df637dea972bfff30c98ebc8842dc7a9e3d681c61902f71bffaf5093607fbfba9674a70d048e562ee88f027f630a78522ec6f706bb44ae130e05c8d7eac668bf6980d99b4c0242946452399cb032cc6f9fd96284709bd2fa565b9eb9f2004be6c9ea9ff9128c3f93b60dc30c5fc8587a10de68c" - ], - -- COUNT = 2 - [ "62cda441dd802c7652c00b99cac3652a64fc75388dc9adcf763530ac31df9214" - , "5fdc897a0c1c482204ef07e0805c014b" - , "" - , "bd9bbf717467bf4b5db2aa344dd0d90997c8201b2265f4451270128f5ac05a1a" - , "" - , "" - , "" - , "7e41f9647a5e6750eb8acf13a02f23f3be77611e51992cedb6602c314531aff2a6e4c557da0777d4e85faefcb143f1a92e0dbac8de8b885ced62a124f0b10620f1409ae87e228994b830eca638ccdceedd3fcd07d024b646704f44d5d9c4c3a7b705f37104b45b9cfc2d933ae43c12f53e3e6f798c51be5f640115d45cf919a4" - ], - -- COUNT = 3 - [ "6bdc6ca8eef0e3533abd02580ebbc8a92f382c5b1c8e3eaa12566ecfb90389a3" - , "8f8481cc7735827477e0e4acb7f4a0fa" - , "" - , "72eca6f1560720e6bd1ff0152c12eeff1f959462fd62c72b7dde96abcb7f79fb" - , "" - , "" - , "" - , "d5a2e2f254b5ae65590d4fd1ff5c758e425be4bacdeede7989669f0a22d34274fdfc2bf87135e30abdae2691629c2f6f425bd4e119904d4785ecd9328f15259563e5a71f915ec0c02b66655471067b01016fdf934a47b017e07c21332641400bbe5719050dba22c020b9b2d2cdb933dbc70f76fec4b1d83980fd1a13c4565836" - ], - -- COUNT = 4 - [ "096ef37294d369face1add3eb8b425895e921626495705c5a03ee566b34158ec" - , "6e2e0825534d2989715cc85956e0148d" - , "" - , "1b4f7125f472c253837fa787d5acf0382a3b89c3f41c211d263052402dcc62c5" - , "" - , "" - , "" - , "4541f24f759b5f2ac2b57b51125077cc740b3859a719a9bab1196e6c0ca2bd057af9d3892386a1813fc8875d8d364f15e7fd69d1cc6659470415278164df656295ba9cfcee79f6cbe26ee136e6b45ec224ad379c6079b10a2e0cb5f7f785ef0ab7a7c3fcd9cb6506054d20e2f3ec610cbba9b045a248af56e4f6d3f0c8d96a23" - ], - -- COUNT = 5 - [ "a7dccdd431ae5726b83585b54eae4108f7b7a25c70187c0acbb94c96cc277aa8" - , "94c8f4b8e195a47356a89a50d1389ab5" - , "" - , "51733eee2e922f4055e53939e222e71fae730eb037443db2c7679708abb86a65" - , "" - , "" - , "" - , "99ba2691a622afecc9472418e6a8f9f1cdc1e3583c3bc7a2a650a1ab79dcbccbd656636c573179276e782569420c97438c06be898867f628b1c01eb570263d2c0f09c7aab536f6fba7df6aad19e05c236b645674667c03d1b6a04d7fc11177fe78933b309679f5bf26a4632b9a13e314c4bf4532428d3d95c689002b6dc1fbb1" - ], - -- COUNT = 6 - [ "c286425ecf543a49bcc9196b0db1a80bc54e4948adba6f41712a350a02891fa6" - , "957a659a4ec2e0b7ad185483c220fd61" - , "" - , "08c2129813eea0776fba72788fdf2718759cc3c4207fa20a5fe23ac6e32cc28e" - , "" - , "" - , "" - , "8e1020a4fd84c99e0fc7e3f7ce48de5ed9ec9a5c2ccd624dbe6f30e2f688a31dc55957630357a5d48ca2a456241a28bfb16d8bb000877697a7ce24d9ad4d22b0c15117996f1f270b94f46d7a9bdfa7608fa1dd849177a9b8049e51b6b7a2742623854a1fddb5efc447eed1ea1aed6f02b4b2754ecf71ea0509da2e54f524a7e7" - ], - -- COUNT = 7 - [ "02818bd7c1ec456ace55beeba99f646a6d3aa0ea78356ea726b763ff0dd2d656" - , "c482687d508c9b5c2a75f7ce390014e8" - , "" - , "cf319bfa63980e3cb997fd28771bb5614e3acb1149ba45c133ffbbab17433193" - , "" - , "" - , "" - , "19a231ff26c1865ce75d7a7185c30dd0b333126433d0c8cbf1be0d2b384d4eb3a8aff03540fbfa5f5496521a4e4a64071b44c78bd0b7e68fac9e5695c5c13fd3b9dbe7f7739781a4c8f0b980f1b17d99bce17ceb52b56866ae02456ffef83399c8cf7826f3c45c8a19315890919d20f40fc4e18d07e9c8ccd16c3327b5988f71" - ], - -- COUNT = 8 - [ "77a5c86d99be7bc2502870f4025f9f7563e9174ec67c5f481f21fcf2b41cae4b" - , "ed044ad72ee822506a6d0b1211502967" - , "" - , "778100749f01a4d35c3b4a958aafe296877e0acafd089f50bc7797a42a33ab71" - , "" - , "" - , "" - , "831a4da566f46289904893ef1cc1cd4ad19ee48f3857e2b69e936d10afbdc29822e85d02663d346ef3e09a848b1d9cc04f4c4c6e3b3b0e56a034e2334d34ca08f8097be307ba41d020bc94f8c1937fe85644eeb5592c2b5a2138f7ded9a5b44b200c8b5beb27597c790f94d660eb61e8248391edc3ae2d77656cbe8354275b13" - ], - -- COUNT = 9 - [ "0ea458cff8bfd1dd8b1addcba9c01317d53039e533104e32f96e7d342e6c7b9b" - , "935a4b66fc74c2a48757a99c399e64e3" - , "" - , "6c5f3708e7b714c4ed139b4fa9e8c763af01773484005109a85e33653bb0ce98" - , "" - , "" - , "" - , "373a37af84fddec13645a9768d6a785ae5a2589d64cd9b37980dde2541499210c4f408335de1d585349064f3f53a2b4c5ec6dc2a09591f99ad9fad528ac83474164b45497bf167f81e66fa08463ffea917f6891e48f149fafc20622bb1172f34886feb45c26fd446a4a4e2891b4bc594186896141aaaeeb301b49e7c1a26fec7" - ], - -- COUNT = 10 - [ "bfb68be4ce1756d25bdfad5e0c2f8bec29360901cc4da51d423d1591cc57e1ba" - , "98afe4bd194c143e099680c504cceaab" - , "" - , "b97caf210e82498c3408790d41c320dd4a72007778389b44b7bc3c1c4b8c53f8" - , "" - , "" - , "" - , "409e0aa949fb3b38231bf8732e7959e943a338ea399026b744df15cbfeff8d71b3da023dcce059a88cf0d4b7475f628e4764c8bef13c70cfbbbb6da2a18aabcad919db09d04fc59765edb165147c88dd473a0f3c5ee19237ca955697e001ba654c5ee0bd26761b49333154426bc63286298a8be634fe0d72cfdeef0f3fc48eca" - ], - -- COUNT = 11 - [ "4f6880a64610004463031d67d7924fa446c39138d4d41007e8df3d65691a9367" - , "6b33b2c13600f4b1df6ca3d1960e8dd4" - , "" - , "57b87b8c8f48312b5333d43b367730c0a5ad4725a16778fcb53fe136d136cbfd" - , "" - , "" - , "" - , "73d0f324ed186e2ad06bd1800e262bdbda79ba54e626761bd60f74f43e3bb62958ec1e2f1d940af163e1cadc124e7ebaba2f72e67efd746c7f6d0cad53ef03d859d93cff778a32ee5be172fe7fdbdc232ded360d704a6fa0f70bebe942e56478345492f49dc5c6fc346b88a58947ad250e688e8c626fe1efe7624620e571976e" - ], - -- COUNT = 12 - [ "aae352e111843219cae8f70e7b8f6eb9bb53d246cbec1e4f07d42757143295b4" - , "b84485dccd1bf93210e322eafcbebcd9" - , "" - , "f9237f00d744d8fbff21b9d0043c258e8731817e6a5fb7b4bf5011680e5bc642" - , "" - , "" - , "" - , "cfb28b93522c7d61d8d3ce3f080e435e4c83c7e13a9dab788db8fef0407267a14fbc9324e090e24df5491fedfa81116869983938d4d4d7324a310c3af33a6f7938f602c5e4e63f1771cdaabdab0782b5affb54eb53047c109a9606739dd0065bd21eca33132986554878354f5f9f852e674dd690163b0ff74c7a25e6bae8ce39" - ], - -- COUNT = 13 - [ "589e79e339b7d2a1b879f0b0e1a7d1ad2474eaa8025b070f1ffa877b7124d4ff" - , "0961ed64dbd62065d96e75de6d2ff9d6" - , "" - , "e928388d3af48c2968527a4d2f9c2626fbc3f3f5a5d84e0583ab6f78e7f8b081" - , "" - , "" - , "" - , "fce6ced1ecf474d181ab331f79c3d2cc8a768ec2818de5b3fc7cf418322716d6a6853733561a497c0c25cb288d2c9fcfbca891bafd5a834c85f3603f402acf1a7b1ea92db847ed5c252a862ad4ab5e259715f1fc81da67f5230bf8be50ee8069758095f7d0e559e03f2c6072290e61794458437609e473eb66580cddaad19b71" - ], - -- COUNT = 14 - [ "714277d408ad87fde317f0a94732fce62f1352bdc90936673b4f1daa0925aa26" - , "d16582a99f23010b4248b88d86485419" - , "" - , "bd9fc7cb2fd5063b2c3c0c4f346ad2e3879371a9c805e59b9f2cd2cc2a40894f" - , "" - , "" - , "" - , "62ef7a431288252e0d736c1d4e36cc9ac37107dcd0d0e971a22444a4adae73a41eff0b11c8625e118dbc9226142fd0a6aa10ac9b190919bda44e7248d6c88874612abd77fb3716ea515a2d563237c446e2a282e7c3b0a3aef27d3427cc7d0a7d38714659c3401dbc91d3595159318ebca01ae7d7fd1c89f6ad6b604173b0c744" - ] - ] - -{- - [SHA-256] - [PredictionResistance = False] - [EntropyInputLen = 256] - [NonceLen = 128] - [PersonalizationStringLen = 0] - [AdditionalInputLen = 256] - [ReturnedBitsLen = 1024] --} - -r2 :: [TestVector] -r2 = - [ - -- COUNT = 0 - [ "05ac9fc4c62a02e3f90840da5616218c6de5743d66b8e0fbf833759c5928b53d" - , "2b89a17904922ed8f017a63044848545" - , "" - , "2791126b8b52ee1fd9392a0a13e0083bed4186dc649b739607ac70ec8dcecf9b" - , "43bac13bae715092cf7eb280a2e10a962faf7233c41412f69bc74a35a584e54c" - , "3f2fed4b68d506ecefa21f3f5bb907beb0f17dbc30f6ffbba5e5861408c53a1e" - , "529030df50f410985fde068df82b935ec23d839cb4b269414c0ede6cffea5b68" - , "02ddff5173da2fcffa10215b030d660d61179e61ecc22609b1151a75f1cbcbb4363c3a89299b4b63aca5e581e73c860491010aa35de3337cc6c09ebec8c91a6287586f3a74d9694b462d2720ea2e11bbd02af33adefb4a16e6b370fa0effd57d607547bdcfbb7831f54de7073ad2a7da987a0016a82fa958779a168674b56524" - ], - -- COUNT = 1 - [ "1bea3296f24e9242b96ed00648ac6255007c91f7c1a5088b2482c28c834942bf" - , "71073136a5cc1eb5b5fa09e1790a0bed" - , "" - , "d714329f3fbea1df9d0b0b0d88dfe3774beb63d011935923d048e521b710dc6f" - , "4ef872fd211a426ea1085ab39eb220cc698fdfeabe49b8835d620ab7885de7a4" - , "d74d1669e89875852d9ccbf11c20fe3c13a621ebcb3f7edeea39a2b3379fdcf5" - , "0c8aa67ca310bd8e58c16aba35880f747266dbf624e88ec8f9ee9be5d08fdeb1" - , "ce95b98f13adcdf7a32aa34709d6e02f658ae498d2ab01ce920f69e7e42c4be1d005acf0ca6b17891dfafc620dd4cd3894f8492a5c846089b9b452483eb0b91f3649ec0b6f98d1aaabc2e42cd39c2b25081b85ab50cb723007a0fd83550f32c210b7c4150b5a6bb3b0c9e3c971a09d43acb48e410a77f824b957092aa8ef98bc" - ], - -- COUNT = 2 - [ "a7ea449b49db48601fc3a3d5d77081fab092b8d420ed1b266f704f94352dd726" - , "d11a159b60af8d20a0e37d27e6c74aa3" - , "" - , "50916ab47e8cb5dc843f9fba80639103711f86be8e3aa94f8a64a3fe0e6e5b35" - , "e2bb6768120555e7b9e0d573537a82f8f32f54560e1050b6abb1588fb3441e66" - , "a50cec9d1ecddb2c163d24019e81c31a2b350ccd3ad8181fd31bb8d1f64fa50e" - , "591dbbd48b51abced67f9c6269cf0133cd3dcbb5cfafcb6ef758569c555a5773" - , "0a464abcc8685158372d544635b953fcb1d3821c30aaa93982f9b788935f00f88115aad61d5cee003b3d1cb50f3e961a501e2dd0fc7e1724778b184a4bdf9f64e110dda7446e5544a30bd49a400ea1a5411800e1edfeea349323618afc5dc5782dc4b71d2da4d6a4785f8dd346feb9c8740ffd26bf644e3e4323ff24c30b9f10" - ], - -- COUNT = 3 - [ "14683ec508a29d7812e0f04a3e9d87897000dc07b4fbcfda58eb7cdabc492e58" - , "b2243e744eb980b3ece25ce76383fd46" - , "" - , "18590e0ef4ee2bdae462f76d9324b3002559f74c370cfccf96a571d6955703a7" - , "9ea3ccca1e8d791d22fcda621fc4d51b882df32d94ea8f20ee449313e6909b78" - , "16366a578b5ea4d0cb547790ef5b4fd45d7cd845bc8a7c45e99419c8737debb4" - , "a68caa29a53f1ba857e484d095805dc319fe6963e4c4daaf355f722eba746b92" - , "c4e7532ee816789c2d3da9ff9f4b37139a8515dbf8f9e1d0bf00c12addd79ebbd76236f75f2aa705a09f7955038ebff0d566911c5ea13214e2c2eeb46d23ad86a33b60f7b9448d63eec3e1d59f48b39552857447dc5d7944667a230e3dbfa30ca322f6eacaf7536a286706a627c5083c32de0658b9073857c30fb1d86eb8ad1b" - ], - -- COUNT = 4 - [ "fa261fb230e2822458532ca2d5c39758750e6819a6fcebef10579ba995096959" - , "564e1c9fbcb12878df2bd49202cbf821" - , "" - , "bf7de29e99e7f0e1b9f96f3b1902fb4049c8c6234d20de8316ebe66d97725457" - , "8b7326621f6afbd44a726de48d03bcc5331f7306026c229ea9523497fbeaa88d" - , "33b00b31623d6160c4c6740363a96481be14b19bc47be95641227284c366922a" - , "2d812c8203575790ad6b6f2ed91a49d57460de779a3e881bef3be12e8766dc91" - , "5574e0b4efc17e8ce136e592beabfe32551072bddd740929e698467b40b3991f028a22c760f7034853cc53007e3793e3c4a600d9e9d94528f8dc09aeba86146cdde2b7f71255ae0efc529b49be2205979dba6525bfe155e8819e8e2aeeaa285704242da90b4c4535101cc47d94b0e388a1b2e63ad0cbe158b9e1bbae9cc0007c" - ], - -- COUNT = 5 - [ "61f1471ced56aa04c57e1b512307d4cb92497d9592d7e9e35356e99d585cab1b" - , "84714e960c403a4fac06b2828cc564d9" - , "" - , "7bf97db3c102edc81596d4757045fe6bdc008f35792fc6290b77d889c09c33a8" - , "5b8bdc41f76d98cfa71ed976ea3994706375c8841adb8b6b3b6418e3132e8832" - , "94c8a8fdf38a6ccb8571c89420d899adab169214bb0dfcd43a04622e289935b2" - , "8a4b46e0a7a55907365f82d4ab9376509bd44728cab8cbafb0da901012ad8dcd" - , "933eb159a6af7455b60e40586c064f05f1970f564281b1ebc4662701ac1f299e4eb908c4afcb2e065191281ab576f684aefedd6904bad04d96bd93c0516c62a496c3073a0cda0676a11cc08866b0cc74f62cb9d3db48673b2c3fbeada69f922b4b795ccba22df12ef7125909381f7d681f6b9caba02fb913c5437b98c040c576" - ], - -- COUNT = 6 - [ "a1d5bb7d70621dee6b668b28c56d5610c2f8ced30284cc3e0e48de331af05062" - , "88a49e3e54c5ea54c98b95de81bcc807" - , "" - , "b4e2426e98f6eed97a6cdf690a89ee109e84c3dca16c883c26fa4ac671638d8d" - , "5bd1e086ed228cfd8b55c1731fea40c3a63d022599ca2da4bb23118f4821ba62" - , "b754b53ac226e8ebe47a3d31496ec822de06fca2e7ef5bf1dec6c83d05368ec3" - , "fa7e76b2805d90b3d89fff545010d84f67aa3a2c9eb2ba232e75f4d53267dac3" - , "df6b2460688fa537df3ddfe5575fca5eb8abad56cbc4e5a618a2b4a7daf6e215c3a497974c502f9d0ec35de3fc2ea5d4f10de9b2aee66dcc7e7ae6357983095959b817f0383e3030771bd2ed97406acf78a1a4a5f30fa0992289c9202e69e3eb1eabe227c11409ff430f6dfca1a923a8b17bc4b87e908007f5e9759c41482b01" - ], - -- COUNT = 7 - [ "68f21d14525d56233c7e263482d344c388a840103a77fb20ac60ce463cabdc79" - , "59fa80ae570f3e0c60ac7e2578cec3cb" - , "" - , "7584b4166530442f06e241dd904f562167e2fdae3247ab853a4a9d4884a5fa46" - , "f6a5482f139045c5389c9246d772c782c4ebf79c3a84b5cf779f458a69a52914" - , "9d37b1ce99f8079993ddf0bd54bab218016685b22655a678ce4300105f3a45b7" - , "4c97c67026ff43c2ee730e7b2ce8cce4794fd0588deb16185fa6792ddd0d46de" - , "e5f8874be0a8345aabf2f829a7c06bb40e60869508c2bdef071d73692c0265f6a5bf9ca6cf47d75cbd9df88b9cb236cdfce37d2fd4913f177dbd41887dae116edfbdad4fd6e4c1a51aad9f9d6afe7fcafced45a4913d742a7ec00fd6170d63a68f986d8c2357765e4d38835d3fea301afab43a50bd9edd2dec6a979732b25292" - ], - -- COUNT = 8 - [ "7988146cbf9598d74cf88dc314af6b25c3f7de96ae9892fb0756318cea01987e" - , "280bc1ae9bfdf8a73c2df07b82a32c9c" - , "" - , "2bbc607085232e5e12ccf7c0c19a5dc80e45eb4b3d4a147fe941fa6c13333474" - , "f3f5c1bb5da59252861753c4980c23f72be1732f899fdea7183b5c024c858a12" - , "44d0cfc4f56ab38fa465a659151b3461b65b2462d1ad6b3463b5cf96ad9dc577" - , "34fb9a3cdacc834ff6241474c4f6e73ed6f5d9ea0337ab2b7468f01ad8a26e93" - , "4caec9e760c4d468e47613fe50de4a366ae20ba76793744a4e14433ea4de79dc188601eb86c803b094641ab2337b99d459d37decc7d27473057be45ba848868ee0fb5f1cf303d2fcd0b3e0c36f65a65f81b3fee8778a1f22302e25dfe34e6d587fa8864e621121880f7cd55f350531c4ce0530099eec2d0059706dcd657708d9" - ], - -- COUNT = 9 - [ "1c974c953fa2a057c9fc9409a6843f6f839aa544bca4fa11e48afd77931d4656" - , "ed7c08285464af7a5dbdc10b944a1270" - , "" - , "78146ad135acb836360d36afc50653dcc36c21662da2a6f6ae05222e75f34000" - , "263c4984c238ded333c86472866353817379502157172cfa51371d82b1efd7b5" - , "79b591529f9a26a0d7c8f8fd64e354b0c134ef1f757e43f9463b3dbb7a3da1ab" - , "7d8f7204b0b5401ddce9e88dcf5facb9a44660a9f5f1c862748e7269c29f7964" - , "72e2ca257b9edaf59b50e05a144f56fb517832fb9ad3489b1e664e3d5412cbf6b2883e891703b2e73aff9ab56da1009fcdef010ab4cdab996795c8f7c47fb1192bb160353997ad39d7d5fd0e2efc9103a7c3f158246afd53fe53ca6782f809698ef5f1f0d85536780a3fd6a8bafa475891c09213088bd1a3dc169257c34a517a" - ], - -- COUNT = 10 - [ "56216d71984a77154569122c777ce57e1d101a6025b28163a25971d39c1c5d0f" - , "5cd148ba7e54f4975ac8e3e0f9b5d06a" - , "" - , "3580f8ca974626c77259c6e37383cb8150b4d0ab0b30e377bed0dc9d1ff1a1bf" - , "15633e3a62b21594d49d3d26c4c3509f96011d4dbb9d48bbbea1b61c453f6abe" - , "6068eaca85c14165b101bb3e8c387c41d3f298918c7f3da2a28786ab0738a6fc" - , "e34f92d2b6aeeeea4ff49bfe7e4b1f462eabb853f0e86fbae0e8b3d51409ce49" - , "587fdb856abc19ede9078797ecb44099e07aadcd83acdcb2b090601d653f4a14c68ab2ebdda63578c5633a825bae4c0c818f89aac58d30fd7b0b5d459a0f3d86fcad78f4bb14dfff08ad81e4ea9f487cb426e91d6e80dfed436ba38fce8d6f21ca2151c92dd5c323b077d6139c66395558f0537026c4a028affa271ef4e7ea23" - ], - -- COUNT = 11 - [ "83eb48bedc1e9294866ab8e5322ef83f6f271f8188e8fdabe5817788bd31570d" - , "d6ed90bc692237f132441ede857a6629" - , "" - , "a4e5e127f992bd5ca79ee56bb8a9bccf74c21814bfaf97ffd052211e802e12e4" - , "84136e403d9ed7f4515c188213abcfaca35715fa55de6d734aec63c4606a68f1" - , "fe9d8ef26e2d2e94b99943148392b2b33a581b4b97a8d7a0ecd41660a61dd10b" - , "594dad642183ce2cdc9494d6bcb358e0e7b767c5a0fa33e456971b8754a9abd5" - , "86715d43ba95fbbca9b7193ea977a820f4b61ba1b7e3b8d161b6c51b09dfd5040d94c04338b14d97ed25af577186b36ae7251a486c8a2d24a35e84a95c89d669d49e307b4a368b72164135ac54d020a970a180dfbed135d2c86f01270846d5301bd73db2c431a8aa10a0a3d03d146e5fafb9a2aa0b4efc80edab06ff3b532236" - ], - -- COUNT = 12 - [ "ba2c94203dab2e6499d8c50dca7b5c34a6b4764834f9816631aa21b9f9c37361" - , "67db133bdefb25e395085bceee5a0afc" - , "" - , "fa8984d16d35302cda35a3a355ab9242ec96fec0652d39282d4a0abf0a80df87" - , "b6fed10255a3fea6772ae1ae6d9f6cbb9bfaa34804e58a5b786f9bc60b348ccd" - , "445e072244edc716d3528f0e0a20ff0cd8f819c0d031736c8da122748f24d6c6" - , "1f856e403c4fa035bac9aa81a20e347c7d8b213aab699d69d9d6186a06ac45c1" - , "79f33fc36b3b47d9ac805bdbbe699909a8d0beb689a8b2723c291bd5bf7f3ce61343d4722a14e4add36312dbb0594910c8828aff1abc159915d498106f9ffb31147478d8c9ef75d1536ba5036506b313f6e85033f8f6fea2a4de817c867a59378c53c70a2f108275daedd415c05b61c4fd5d48c54be9adb9dea6c40a2ec99ee0" - ], - -- COUNT = 13 - [ "0db4c51492db4fe973b4bb1c52a1e873b58fc6bb37a3a4bfc252b03b994495d1" - , "a2a3900f169bba3f78a42526c700de62" - , "" - , "29d5aab356876447e3a20d81c7e3fc6975e2b984180a91493044442999e1ca3a" - , "40b34183b4e72cdff5952b317b3d45943d0fdcfa0527f3563055f7c73ae8f892" - , "dc94220c99ffb595c7c4d6de8de5a6bb4b38847169e24a557ef6d879ad84149d" - , "b2376626fd2f5218b3ed4a5609b43aa24d371cd2176ea017c2b99cf868060021" - , "f0bd6bc4c506d9427a09352d9c1970b146360732841a6323f4cb602c87dedfb5ff7e6964b9144933af3c5c83017ccd6a94bdca467a504564aaa7b452591a16ff6a1e7e94ddc98f9a58016cdcb8caaed6c80671ba48cc81a832d341093dda1d4e5001ec6bf66348b21e3692a13df92538ad572bb2023822072fc95f9590293ffc" - ], - -- COUNT = 14 - [ "593845f0adfeffa7c169f8a610147ae8a08c0072fc0c14c3977d3de0d00b55af" - , "9e0eb2507342ee01c02beadee7d077bd" - , "" - , "aefe591697eab678c52e20013aa424b95cfd217b259757fbe17335563f5b5706" - , "cbb5be0ef9bf0555ee58955c4d971fb9baa6d6070c3f7244a4eb88b48f0793bf" - , "6dd878394abdc0402146ba07005327c55f4d821bfebca08d04e66824e3760ab4" - , "ba86a691d6cbf452b1e2fd1dfb5d31ef9ea5b8be92c4988dc5f560733b371f69" - , "00735cbfafac5df82e5cb28fc619b01e2ba9571dc0023d26f09c37fb37d0e809066165a97e532bf86fa7d148078e865fe1a09e27a6889be1533b459cd9cd229494b5cf4d2abf28c38180278d47281f13820276ec85effb8d45284eb9eef5d179ab4880023ab2bd08ee3f766f990286bf32430c042f5521bbfd0c7ee09e2254d7" - ] - ] - -{- - [SHA-256] - [PredictionResistance = False] - [EntropyInputLen = 256] - [NonceLen = 128] - [PersonalizationStringLen = 256] - [AdditionalInputLen = 0] - [ReturnedBitsLen = 1024] --} - -r3 :: [TestVector] -r3 = - [ - -- COUNT = 0 - [ "fa0ee1fe39c7c390aa94159d0de97564342b591777f3e5f6a4ba2aea342ec840" - , "dd0820655cb2ffdb0da9e9310a67c9e5" - , "f2e58fe60a3afc59dad37595415ffd318ccf69d67780f6fa0797dc9aa43e144c" - , "e0629b6d7975ddfa96a399648740e60f1f9557dc58b3d7415f9ba9d4dbb501f6" - , "" - , "" - , "" - , "f92d4cf99a535b20222a52a68db04c5af6f5ffc7b66a473a37a256bd8d298f9b4aa4af7e8d181e02367903f93bdb744c6c2f3f3472626b40ce9bd6a70e7b8f93992a16a76fab6b5f162568e08ee6c3e804aefd952ddd3acb791c50f2ad69e9a04028a06a9c01d3a62aca2aaf6efe69ed97a016213a2dd642b4886764072d9cbe" - ], - -- COUNT = 1 - [ "cff72f345115376a57f4db8a5c9f64053e7379171a5a1e81e82aad3448d17d44" - , "d1e971ec795d098b3dae14ffcbeecfd9" - , "6ec0c798c240f22740cad7e27b41f5e42dccaf66def3b7f341c4d827294f83c9" - , "45ec80f0c00cad0ff0b7616d2a930af3f5cf23cd61be7fbf7c65be0031e93e38" - , "" - , "" - , "" - , "17a7901e2550de088f472518d377cc4cc6979f4a64f4975c74344215e4807a1234eefef99f64cb8abc3fb86209f6fc7ddd03e94f83746c5abe5360cdde4f2525ccf7167e6f0befae05b38fd6089a2ab83719874ce8f670480d5f3ed9bf40538a15aaad112db1618a58b10687b68875f00f139a72bdf043f736e4a320c06efd2c" - ], - -- COUNT = 2 - [ "b7099b06fc7a8a74c58219729db6b0f780d7b4fa307bc3d3f9f22bfb763596a3" - , "b8772059a135a6b61da72f375411de26" - , "2ac1bfb24e0b8c6ac2803e89261822b7f72a0320df2b199171b79bcbdb40b719" - , "9aec4f56ec5e96fbd96048b9a63ac8d047aedbbeea7712e241133b1a357ecfc4" - , "" - , "" - , "" - , "0e1f2bfef778f5e5be671ecb4971624ec784ed2732abc4fbb98a8b482fb68737df91fd15acfad2951403ac77c5ca3edffc1e03398ae6cf6ac24a91678db5c7290abc3fa001aa02d50399326f85d2b8942199a1575f6746364740a5910552c639804d7530c0d41339345a58ff0080eccf1711895192a3817a8dc3f00f28cc10cc" - ], - -- COUNT = 3 - [ "7ba02a734c8744b15ef8b4074fe639b32e4431762ab5b7cd4d5df675ea90672b" - , "8a424f32108607c8f1f45d97f500ee12" - , "3ad627433f465187c48141e30c2678106091e7a680229a534b851b8d46feb957" - , "d8f02b59b6a3dd276bc69cba68efcf11ab83ead1397afd9841786bd1bb5da97a" - , "" - , "" - , "" - , "1fb91186ba4b4459d994b4b9f4ca252c7be6294d6cdb5fe56f8ff784d4b190a1c6456e0a41223bbbdf83ed8e7cfbfa765d9d8bc7ea5f4d79ea7eccb4928081a21de4cca36620d6267f55d9a352b76fc0a57375884112c31f65ff28e76d315698c29e6c4c05cb58b0a07ae66143b4abc78b9d25c78b4121e1e45bef1a6c1793e2" - ], - -- COUNT = 4 - [ "9a8865dfe053ae77cb6a9365b88f34eec17ea5cbfb0b1f04d1459e7fa9c4f3cb" - , "180c0a74da3ec464df11fac172d1c632" - , "336372ec82d0d68befad83691966ef6ffc65105388eb2d6eed826c2285037c77" - , "75b95108eff1fabe83613e1c4de575e72a5cdc4bb9311dd006f971a052386692" - , "" - , "" - , "" - , "3c683f6d4f8f5a4018d01633dfee74266aaa68ed6fc649e81b64dfdf5f75e75d5c058d66cf5fd01a4f143a6ff695517a4a43bd3adfd1fb2c28ba9a41063140bedbffdb4d21b1ace1550d59209ec61f1e2dbacb2a9116a79cb1410bf2deca5218080aacd9c68e1d6557721a8913e23f617e30f2e594f61267d5ed81464ee730b2" - ], - -- COUNT = 5 - [ "22c1af2f2a4c885f06988567da9fc90f34f80f6dd5101c281beef497a6a1b2f8" - , "3fafdecf79a4174801f133131629037b" - , "80327dac486111b8a8b2c8e8381fb2d713a67695c2e660b2b0d4af696cc3e1de" - , "f95a0e4bd24f0e2e9e444f511b7632868ead0d5bb3846771264e03f8ab8ed074" - , "" - , "" - , "" - , "77a7fea2f35a188f6d1bfdd49b569d8c45e2dd431d35a18c6f432c724f1e33ae92cb89a9cf91519e50705a53199f5b572dc85c1aef8f28fb52dc7986228f66954d54eda84a86962cf25cf765bd9949876349291b1aae5f88fcf4b376912d205add4f53b2770c657946c0d824281f441509153f48356d9d43f8a927e0693db8fc" - ], - -- COUNT = 6 - [ "d0840e3a8d629d5b883d33e053a341b21c674e67e1999f068c497ecfaabfd6f6" - , "071de7244ecb2fdf7ab27f2d84aa7b7a" - , "90d609527fad96ffe64ab153860346f3d237c8940555ae17b47842d82d3b0943" - , "1dd1a8b59856c49a388f594c5f42cc2e4a56b3ccb8a65e7066e44c12f4344d50" - , "" - , "" - , "" - , "7ab28a9b2d3ae999195553e6550cced4c2daccbe7ec9dcbb0d467fabba185b727fbfd9830242cd098f4db3cf4a85e8bf8e8d5974b62b28550922b32ed5bfc1a522b6605cf93bf8d90bdec1c5b9e59c6fc37a817d437068a87254be1f7c4618ada46fbc3a2efb02e44524e21d91be7534cf05fbfd858304b706d6a91ea1cc6ad5" - ], - -- COUNT = 7 - [ "2e2dd56869104492767a59778652831919e1c8b970f84e824ae4116597a0ab7f" - , "01c42a7e983641de46c82fd09b4f2f76" - , "bcd9e1508fcc22820a8be07180fea5045367333b569e111b011cd57dc1858765" - , "7306507cd3ca7eec667e640d270cfbb033063d97520b6b7e38ff3cea0e79d12b" - , "" - , "" - , "" - , "b915726c7b8c5dc3975f1a334684b973abf6a9495d930088cf5d071548e4fd29a67b55cc561ed6949ad28150a9fb4307c1fa5f783a7ea872e8d7c7e67ff0c2906081ee915737d813c25be5c30b952a36f393e6baa56ab01adc2b4776ad7b5d036a53659877c7a4e5220a897d6c0799af37beeed91173fbe9c613c3b6b9bb28e5" - ], - -- COUNT = 8 - [ "d1aab0f16bd47a5ccd67c22e094daa3735eae21aa57f0bcd9e053d9d0d545cb8" - , "199310dfe1b01265b8c0d2b46d6c7c9f" - , "625b4b8f4de72ea9cb6f70556322dc2a19d6b2b32de623f557e419a084ba60fd" - , "f50cabae4e060f3971096b78e550cda2837a26a693d905db2d992d589b268f44" - , "" - , "" - , "" - , "987e1fdfe004c619cf1e9034576707eccd849400e19c87a1fef5b0179ec51c42a2f8c45d7942d0023a023c89f188b2634362703985695369863322f58619c50a7385a2dc91fc78f94b59f0131dc2b56a0d7c699d427285da1c104b0ad1739da10d8071c23993787045dc21f0070e1e9aa1658fc8e3add73dac7262e80e0aa2ee" - ], - -- COUNT = 9 - [ "449480eaa100aff6f48dc6286a5a81b9728b084864f78a9da98f606a00a6a41f" - , "e53c6c5ac3da9f4726389a03f97bb640" - , "6b8fedc084d8e28d333aef6db3702b6351f0d24e30908cccb63794282655886b" - , "73a6d64e1966ae324388dc12c14544e9dc5ae4fcb331e99d350c456ff16f9aa0" - , "" - , "" - , "" - , "a06912d362da7eb25598857f6d65344c3e23ec3deb80c6e43158845b95eaeca241c0bbbd67ac385e24693444455cc1c2c08c1134d956b8bc93b28be9c2d3322b3e09252979dfb8d39d04c94f81bebda5c73110605a237b561216bda9ee9bdee1cc0c7728bcc8304682334ca944e467a27a85313fa5395a9c790e35defd2edb12" - ], - -- COUNT = 10 - [ "9a6174166e97aa4981ddf580bc01c96754b9f0ba042750aabfda1cffe56e8581" - , "d7512ff6b7db7ce141b2bb01dcd0425e" - , "ed75288f23275f9422444da5d3b53ccb3c4ac8acfb659a1e9b7655c2db52f879" - , "6888b9277e57dc57663d402eba8d03cf56a070dc868e6a128b18040002baf690" - , "" - , "" - , "" - , "03519dfb2ff88cc2b53eecc48ae2a18ddcf91a5d69d5aefcdda8444e6df790a5240e67b2a4de75b4bb8a31f0f8aeb5e785ffb7a1341bb52fe00a05ee66fa2d44ea9956e055f9ffa6647c3bfe851ab364ade71a0d356de710ddafb7622b1da1bc53fd4d3210407289c68d8aeb346bf15806dbe787e781b94f63da3e1f61b5ac60" - ], - -- COUNT = 11 - [ "9c6ae1002ee1b0add0be563ce50f899da936e13efa620d08c2688c192514763a" - , "fde7db5160c73044be73e9d4c1b22d86" - , "8fdaaeffd64e53f7b4374d902d441209964e12b65d29afec258e65db6de167ca" - , "bcc28fd58e397f53f494ad8132df82c5d8c4c22ea0b7139bd81eeba65667bb69" - , "" - , "" - , "" - , "021d938c9b4db780c7d8134aeff1053e5b8843370b8ae9a6749fca7199d809810f1bc8dfa49426470c30c3616f903e35fbacb23420a32f1bee567cc32300f704246ddc0217f236ef52c3ec9e2433ca66f05c25721f7661c43f22c1a125ed5db531bd0836eb435c27eefc7424ce9d845e1d4cc4c503097b4ffca788e674a5cb53" - ], - -- COUNT = 12 - [ "fe96a85b69d46b540918927bb609dc57642eeaefd46bb5da2163a0bc60294b58" - , "22195a410d24db45589448dfe979d3fd" - , "20f698833a4472fd7b78fb9b0c4eb68604f166a2694c4af48dac2b2376790e1e" - , "09cb870879d3f734214f6a4bd2e08c62a2a954bebe559416d8c3551aafe71d6a" - , "" - , "" - , "" - , "d3e96dbe29e1fcb8ed83b19dbfb240e6f41679fbe83853aa71446617e63e5af78cf98b331d15bccb8c673c4e5d5dcec467a1fe26a6cd1696d0c9bc49f78139d051287df7f3ae0dbb4bbf581cb8211931063c3f4612ced53f59d1b4ebb875729139f5d2a7d60642e8f2835eed888b7e3e49c0dffd012cd746abfa3e1c5c2308c6" - ], - -- COUNT = 13 - [ "a4fd693ff0a8af24bcec352d3196549fd0da5ee5d99ca58416ca03ce4c50f38e" - , "8cd67f2bf71d4366ce61396642531ff5" - , "368969c15a4849d7593be8b162113b9298a535c148ff668a9e8b147fb3af4eba" - , "83d2be9a0d74e6a42159ae630acebf4e15271ef7f14f3de14752be0e0e822b11" - , "" - , "" - , "" - , "e9188fc0eaec74b2608e21e3a40be94aaf4ae08eb684de8f8bba2d5fd3b073aa5531c938c0fc628da65725c54b5c68bb91d7d326565e96685e0a4e7b220c50e0caf1628edba5bd755b31894f8cb90afa76e88c5eb9e61b4932444c1397dee3e32241a3fb70a3929e49f6da02eea54812abb3d6b5cee18f03af1e0b4958430ab3" - ], - -- COUNT = 14 - [ "254ff5687a6dad3f1d237dc762f58d24ef2e2c084d0a48d26a3dc81e5490cda3" - , "f2ec392acca491e03ce47b95963a49fc" - , "f806b9b4a56682c61b55cb6a334caf87ffe135adfea6d0c3fc22b39898fbd078" - , "b8494b1c1f1752fb6f80d732a89b08115857f7cc96e7dff05ebb822706889917" - , "" - , "" - , "" - , "0e527e00494d55564f9d9b28e7110f9a61ce36c883b5be2dcb055444164cdddd1a9f2731716f22d6ff476ce413c77abfc0e946871d5481345c2e97b4bfdd12ac03df606fc56bdb99ac7b71a69b5b9160373bbec3e9dde477180af454e7acc6bc58dc0afb4281c0de4354c1bf599054e3800c6d60d892858865b5361f50bfca9b" - ] - ] - -{- - [SHA-256] - [PredictionResistance = False] - [EntropyInputLen = 256] - [NonceLen = 128] - [PersonalizationStringLen = 256] - [AdditionalInputLen = 256] - [ReturnedBitsLen = 1024] --} - -r4 :: [TestVector] -r4 = - [ - -- COUNT = 0 - [ "cdb0d9117cc6dbc9ef9dcb06a97579841d72dc18b2d46a1cb61e314012bdf416" - , "d0c0d01d156016d0eb6b7e9c7c3c8da8" - , "6f0fb9eab3f9ea7ab0a719bfa879bf0aaed683307fda0c6d73ce018b6e34faaa" - , "8ec6f7d5a8e2e88f43986f70b86e050d07c84b931bcf18e601c5a3eee3064c82" - , "1ab4ca9014fa98a55938316de8ba5a68c629b0741bdd058c4d70c91cda5099b3" - , "16e2d0721b58d839a122852abd3bf2c942a31c84d82fca74211871880d7162ff" - , "53686f042a7b087d5d2eca0d2a96de131f275ed7151189f7ca52deaa78b79fb2" - , "dda04a2ca7b8147af1548f5d086591ca4fd951a345ce52b3cd49d47e84aa31a183e31fbc42a1ff1d95afec7143c8008c97bc2a9c091df0a763848391f68cb4a366ad89857ac725a53b303ddea767be8dc5f605b1b95f6d24c9f06be65a973a089320b3cc42569dcfd4b92b62a993785b0301b3fc452445656fce22664827b88f" - ], - -- COUNT = 1 - [ "3e42348bf76c0559cce9a44704308c85d9c205b676af0ac6ba377a5da12d3244" - , "9af783973c632a490f03dbb4b4852b1e" - , "2e51c7a8ac70adc37fc7e40d59a8e5bf8dfd8f7b027c77e6ec648bd0c41a78de" - , "45718ac567fd2660b91c8f5f1f8f186c58c6284b6968eadc9810b7beeca148a1" - , "63a107246a2070739aa4bed6746439d8c2ce678a54fc887c5aba29c502da7ba9" - , "e4576291b1cde51c5044fdc5375624cebf63333c58c7457ca7490da037a9556e" - , "b5a3fbd57784b15fd875e0b0c5e59ec5f089829fac51620aa998fff003534d6f" - , "c624d26087ffb8f39836c067ba37217f1977c47172d5dcb7d40193a1cfe20158b774558cbee8eb6f9c62d629e1bcf70a1439e46c5709ba4c94a006ba94994796e10660d6cb1e150a243f7ba5d35c8572fd96f43c08490131797e86d3ed8467b692f92f668631b1d32862c3dc43bfba686fe72fdd947db2792463e920522eb4bc" - ], - -- COUNT = 2 - [ "b63fdd83c674699ba473faab9c358434771c5fa0348ca0faf7ebd7cf5891826b" - , "5fd204e2598d9626edab4158a8cfd95f" - , "2a5dfad8494306d9d4648a805c4602216a746ae3493492693a50a86d1ba05c64" - , "adea5ba92f8010bb1a6a4b6fae2caa0b384165adf721253afd635d6021f764af" - , "07c69d8d2b8aa1454c5c48083dd41477fda6bfcf0385638379933a60ed2e0a77" - , "a14e902247a3d6493d3fbc8519518b71a660e5502cf7ecfc796cfaa5b4ee4baa" - , "60e690e4a1eba14aec5187112a383e9991347fab7bac7cb2a40a52579a0d2718" - , "792b47b6ed221623bb187d63e3f039c6983d94efd5771dc9b4c40bee65924513485a6332baeda6a96f9bb431f592d73462b61d9d914a72b56fa9d87597426fb246424ebcd7abd51b2eefec8f5b839c0b3c34015342ace296b5f2218fa194b50aea1c89663460292c92c45f112ddbf6b9406f6e7ccee9c47ed2d90a27be5dd73e" - ], - -- COUNT = 3 - [ "dab85f98eaf0cfba013b97de4d9c264ca6fe120366cb83e8b3113c68b34e39d5" - , "d05108e1028ae67b4ea63bdc6d75eb88" - , "09fed3822f6f5e5b9e575d31dc215de1607b0dfc927412618c2d8f79166dbaba" - , "1794885a64470744198b7d0bc24472ffe8daf3c7eb219df6ddf180e484fe0aa5" - , "8d74d01b582f70b92f53b43468084e1586d9b36465d333d5faaf6911e62fe40e" - , "ef7f6b6eb479ab05b3f9ab6dd72eac8b1e86d887f1bcae363cae386d0275a06f" - , "7442b2a792a6a29559bb8a515d56916ee18200580aa02e1237dd358619382d8f" - , "49d2cbfa0897b7d961c293c1e572fb26f28e7b956e746f6eda90454c1370a29e25303ceadc7837514dc638553b487ef9487c977c10625409178ad6506d103c487a66655d08659d92a4d5994d1c8ddb28fe60f2e49577d6e80cae1478068c98268f45e6293c9326c7f726ec89601351c0a26fd3a6549f8a41c6f58692c86594c0" - ], - -- COUNT = 4 - [ "0f0aa84ef12e10ae2b279e799c683441862457b9bc25581c2cd3d5b58a5b3246" - , "f74f4230c2427a52f01f39e825d250ac" - , "d02b2f53da48b923c2921e0f75bd7e6139d7030aead5aeebe46c20b9ca47a38a" - , "5222b26e79f7c3b7066d581185b1a1f6376796f3d67f59d025dd2a7b1886d258" - , "d11512457bf3b92d1b1c0923989911f58f74e136b1436f00bad440dd1d6f1209" - , "54d9ea7d40b7255ef3d0ab16ea9fdf29b9a281920962b5c72d97b0e371b9d816" - , "601cef261da8864f1e30196c827143e4c363d3fa865b808e9450b13e251d47fa" - , "e9847cefea3b88062ea63f92dc9e96767ce9202a6e049c98dc1dcbc6d707687bd0e98ed2cc215780c454936292e44a7c6856d664581220b8c8ca1d413a2b81120380bfd0da5ff2bf737b602727709523745c2ced8daef6f47d1e93ef9bc141a135674cba23045e1f99aa78f8cead12eeffff20de2008878b1f806a2652db565a" - ], - -- COUNT = 5 - [ "6a868ce39a3adcd189bd704348ba732936628f083de8208640dbd42731447d4e" - , "efdde4e22b376e5e7385e79024350699" - , "f7285cd5647ff0e2c71a9b54b57f04392641a4bde4a4024fa11c859fecaad713" - , "0174f7f456ac06c1d789facc071701f8b60e9accebced73a634a6ad0e1a697d4" - , "5463bb2241d10c970b68c3abc356c0fe5ef87439fc6457c5ee94be0a3fb89834" - , "3ab62cdbc638c1b2b50533d28f31b1758c3b8435fe24bb6d4740005a73e54ce6" - , "2dbf4c9123e97177969139f5d06466c272f60d067fefadf326ccc47971115469" - , "8afce49dccc4ff64c65a83d8c0638bd8e3b7c13c52c3c59d110a8198753e96da512c7e03aeed30918706f3ad3b819e6571cfa87369c179fb9c9bbc88110baa490032a9d41f9931434e80c40ae0051400b7498810d769fb42dddbc7aa19bdf79603172efe9c0f5d1a65372b463a31178cbae581fa287f39c4fbf8434051b7419f" - ], - -- COUNT = 6 - [ "bb6b339eae26072487084ec9e4b53f2f1d4267d205042e74c77fb9ca0591ba50" - , "c0e7bf6eb07feccbc494af4098e59d30" - , "34aeec7ed0cae83701b6477709c8654a1114212401dc91cbe7de39d71f0c06e1" - , "f47fc60afbeb807236f7974d837335bc0b22288ef09ddfcb684e16b4c36a050b" - , "e8071ccd84ac4527e5c6e85b0709ed867776f25ae0e04180dcb7105ecd3e3490" - , "fbac45b5952200ad7c4232500f2417a1c14723bdd1cc078821bc2fe138b86597" - , "c4292d7dbef3ba7c18bf46bcf26776add22ab8ee206d6c722665dec6576b1bc0" - , "228aa2a314fcbfe63089ce953ac457093deaa39dd9ce2a4ece56a6028a476a98129be516d6979eff5587c032cdf4739d7ac712970f600fa781a8e542e399661183e34e4b90c59ec5dc5cad86f91083529d41c77b8f36c5a8e28ba1a548223a02eaed8426f6fe9f349ebec11bc743e767482e3472ec2799c1f530ebdc6c03bc4b" - ], - -- COUNT = 7 - [ "be658e56f80436039e2a9c0a62952dd7d70842244b5ab10f3b8a87d36104e629" - , "33c9627455dfde91865aee93e5071147" - , "d3a6eb29b180b791984deb056d72c0608a2c9044237aecf100ccb03700064c5e" - , "bef24dc9a5aa23003d3825f9b2b00e7dab571ea6ad86415dbd30c0bbdce7b972" - , "047c29e4d1584fa70cb66e2aa148a2aa29837c5eee64dcac60fdba356cdf90bb" - , "41c4792161b1b00d410cb79cd56bd311a714fb78dc3471c25bdd7479f2e9a952" - , "cd4936d7bc3ea0e7201bcbefbc908215a97680ca6ce8672360aea600b6564308" - , "2c25557f6db07db057f56ad5b6dc0427d1a0e825c48c19a526f9a65087c6d1ead7c78363a61616c84f1022653af65173a3f9ec3275f2b0a0d0bc750194673c0eaa6c623cd88abb0c8979baee4cd85bfce2e4a20bfebf2c3be61676563767dfe229e0b7be67ad6fcd116dd0b460708b1b0e5c3d60f3dd8138030404d197375d75" - ], - -- COUNT = 8 - [ "ae537f31a28ca14500e759716bc207983bfeab60b25079fa30b77b8d41244cb9" - , "fca9e27d8ab84cf9b9ce491ec5d8cb67" - , "8c9cb2b19aa3abe83c8fe7da96e9c11648252653a29dcd5bf0ac334ac587f032" - , "1eb52777be480f05115ae6370f30159a94d50ffcc64454678ab1d1ac6f166fa7" - , "9cdf6f1a2bc07acd4b0f43b5f2b892a1153e2669f237d257923636094fb40b54" - , "692d512722de6ba720fd23c8994ac63179b5f7e611addf9cfacd60e06e144a6a" - , "bbeea7b2bea821f339f494947c0b4bae8056119db69a3cbef21914953729cdef" - , "c0c4fb7080c0fbe425c1b756fb3a090cb0d08c7027d1bb82ed3b07613e2a757f83a78d42f9d8653954b489f800a5e058ebc4f5a1747526541d8448cb72e2232db20569dc96342c36672c4be625b363b4587f44557e58cedb4597cb57d006fda27e027818ae89e15b4c6382b9e7a4453290ea43163b4f9cae38b1023de6a47f7b" - ], - -- COUNT = 9 - [ "2f8994c949e08862db0204008f55d3561f3e0362df13b9d9a70fda39938f2d33" - , "1bf3e94ea858160b832fe85d301256f5" - , "b46671cf7fa142e7012ed261e1fe86714711c246c7d1c0330fa692141e86d5d1" - , "5ecdb1e8fe12260b9bfe12d6e6f161474fa2311e12e39b0beb0fcd92a6737b73" - , "3ce9a29f0207d079e6dc81fb830356e555f96a23ea71424972ea9308965786d3" - , "db950000c0776cc0e049929ce021020adc42d29cd9b5d8f7117fbe6bde3e594f" - , "fc18ee6dd3dac2306774f0ac36cd789e33462d72a8c75df9057123db33e5f7bc" - , "8546362cc8af9b78dd6e8eb2c37db96e70708852bfd9380abedc7f324575a167bea18f632f3e19d099cfbf310773f9719eec036d2e09f393a023add8ebdc4fb87af43b2fe6c7eaa4d39f8022ce247aa45fdc84d1b92cacce6eae8252a03ec2ec5330c01f56d113fd2ec3d0240af0afcf13ddde205bb5e7c2d912dcb4aee5dcf3" - ], - -- COUNT = 10 - [ "0c85e31487de1d7ba4a7b998ac56dc42c6dc0eae7bf5c8aaf1e4e78875f5fb47" - , "de878f728f73f83dc2a2f550b96c8b97" - , "9aac37bce1a6a81dc7934e23747991e3cf48c55ffe5a57781c41768a35220a01" - , "2d5ca8af1a70cfdccd015ee3bf0665dd1941fc6a7317b9d0d06658f5744cfbd9" - , "db881e6d0dc3b62793d7da5fe5a18e33be9b93f4a63a00a878dfbecf0d383bd2" - , "f743ce1b72f3de4c901369eed581c626ed3081ca707e6634fdaff46721ce0878" - , "cd52da3ec8a839c537dacdea8506a3eeee879de388ff5e513322d6d1bb3ff694" - , "a5bdd57cb8fde6298e7c5e563afcca60dd472eca484bd8c3cc17f3307be09b601744dd3ab9e8a44107c5868824575f850c0f399b280cf198006f83ede8c0b537e9be227fa140b65995ad9dfa1f2303d560c3b7f59bedd93c1282ea263924469411c2653f87fd814c74cb91c148430481d64bad0fec3cbb3dd1f39aa55c36f81b" - ], - -- COUNT = 11 - [ "93161b2dc08cb0fd50171141c865a841ca935cfdd2b5907d6ff8ab0348c4ceb0" - , "5cb9f6e5912b90c3349a50ab881b35a1" - , "0dceb4a36326c4df1685df43fddeecb5d0c76f00eb44826694f27e610290f6e1" - , "d8e9be44b5f293482548d4787762ebfb03c73c40e45385e8b98907cd66f493dd" - , "105a8f85d6959f3e043ef508cfea21d52123f03b7aea8034c4eec761eaba1fee" - , "bf781f7e489d9b4b5aa5ee6d1796468af672a8d25f311edf3c4b4dbf433d703f" - , "c81d6bcf1e5bf37e39dda1735c6f193df115b1a854a12e7cafe060afe4589335" - , "4306628124d0100fade7eaaf5edf227d50771f9e5f2e1e983800eef9a39fde0b0c280e63c8728d836b5b93ea794a32c1c04cfc54bd5300e3febb5fe2e1023eded8d7cd180279a598f76823e8d5a7dffcc93a09deec5d1f80838e938fba4de9f47e94b99382ae55f116df9c3b3ddf7e50516e203645852a415796f03a86418107" - ], - -- COUNT = 12 - [ "1ae12a5e4e9a4a5bfa79da30a9e6c62ffc639572ef1254194d129a16eb53c716" - , "5399b3481fdf24d373222267790a0fec" - , "8280cfdcd7a575816e0199e115da0ea77cae9d30b49c891a6c225e9037ba67e2" - , "681554ff702658122e91ba017450cfdfc8e3f4911153f7bcc428403e9c7b9d68" - , "226732b7a457cf0ac0ef09fd4f81296573b49a68de5e7ac3070e148c95e8e323" - , "45942b5e9a1a128e85e12c34596374ddc85fd7502e5633c7390fc6e6f1e5ef56" - , "6fc59929b41e77072886aff45f737b449b105ed7eacbd74c7cbfedf533dbeaa1" - , "b7547332e1509663fcfea2128f7f3a3df484cd8df034b00199157d35d61e35f1a9d481c7d2e81305616d70fc371ee459b0b2267d627e928590edcac3231898b24ef378aa9c3d381619f665379be76c7c1bd535505c563db3725f034786e35bdd90429305fd71d7bf680e8cdd6d4c348d97078f5cf5e89dee2dc410fad4f2a30f" - ], - -- COUNT = 13 - [ "29e20d724dfa459960df21c6ec76b1e6cabd23a9e9456d6c591d7e4529da0ef8" - , "95df1f837eba47a1687aa5c4ddcf8aaf" - , "3713b601e164b1a51dda1ca9242ff477514648e90d311a06e10ce5aa15da5d7f" - , "2a2a312626ca3e20034fc4f28033c7d573f66ef61ab2ea0c7bf0411a9d247264" - , "ec68be33ac8ff3dd127e051604898c0f9a501271859376653a0516336180993d" - , "9935499661d699a00c622a875441b4df5204958fe95892c8ce67f7dfb2be3e4a" - , "256a4ba9e8f439d5487fa5eb45efcf1bc1120491724db3abe328d951f2739fc9" - , "73114cb3624d687d4cd49a6e769dfc7a3f8901dc41f6ad1df4ce480536fa82e52ae958d0528640d92b8bb981b755058e32c4733682e5c4c0df41f3505a1643a0dd49cfdeaf7a18adffca88256c6d2cceb838af6c92a64bc21cb7a760a0391291bfe3575e014fc156323f8eb5e86518c669dad8d29ad5fd4ef6e296f4a0764c26" - ], - -- COUNT = 14 - [ "1353f3543eb1134980e061fc4382394975dbc74f1f1ea5ecc02780a813ac5ee6" - , "cf584db2447afbe2c8fa0c15575ee391" - , "345b0cc016f2765a8c33fc24f1dcfa182cbe29d7eacbcdc9bcda988521458fc2" - , "ba60219332a67b95d90ec9de6b8453d4c8af991ae9277461ff3af1b92fc985d3" - , "6964b9b9842aec9c7ec2aad926d701f30eec76fe699265ae2a7765d716958069" - , "6a03c28a9365c558c33d3fdc7e5ebf0b4d32caac70df71403fd70ced09757528" - , "a58546c72a0b4d47c9bd6c19e7cf4ab73b2d7ba36c6c6dc08606f608795ebd29" - , "5b029ef68b6799868b04dc28dbea26bc2fa9fcc8c2b2795aafeed0127b7297fa19a4ef2ba60c42ff8259d5a759f92bd90fdfb27145e82d798bb3ab7fd60bfaefb7aefb116ca2a4fa8b01d96a03c47c8d987fdd33c460e560b138891278313bb619d0c3c6f9d7c5a37e88fce83e94943705c6ff68e00484e74ad4097b0c9e5f10" - ] - ] diff --git a/test/Network/Haskoin/Crypto/SignatureSpec.hs b/test/Network/Haskoin/Crypto/SignatureSpec.hs deleted file mode 100644 --- a/test/Network/Haskoin/Crypto/SignatureSpec.hs +++ /dev/null @@ -1,165 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Network.Haskoin.Crypto.SignatureSpec (spec) where - -import Data.Bits (testBit) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS (index, length) -import Data.Serialize as S -import Data.Text (Text) -import Network.Haskoin.Crypto (SecKey, Sig, decodeStrictSig, - derivePubKey, exportSig, - importCompactSig, isCanonicalHalfOrder, - sha256, signHash, verifyHashSig) -import Network.Haskoin.Test (arbitrarySignature) -import Network.Haskoin.Util (decodeHex, eitherToMaybe, lst3) -import Test.Hspec (Spec, describe, it) -import Test.Hspec.QuickCheck (prop) -import Test.HUnit (Assertion, assertBool) -import Test.QuickCheck (forAll) - -spec :: Spec -spec = do - describe "signatures" $ do - prop "verify signature" $ - forAll arbitrarySignature $ \(msg, key, sig) -> - verifyHashSig msg sig (derivePubKey key) - prop "s component less than half order" $ - forAll arbitrarySignature $ isCanonicalHalfOrder . lst3 - prop "encoded signature is canonical" $ - forAll arbitrarySignature $ testIsCanonical . lst3 - prop "encode signature and decode strictly" $ - forAll arbitrarySignature $ - (\s -> decodeStrictSig (exportSig s) == Just s) . lst3 - prop "encodes and decodes signature" $ - forAll arbitrarySignature $ - (\s -> decodeStrictSig (exportSig s) == Just s) . lst3 - describe "trezor rfc6979 test vectors" $ do - it "rfc6979 test vector 1" (testSigning $ head detVec) - it "rfc6979 test vector 2" (testSigning $ detVec !! 1) - it "rfc6979 test vector 3" (testSigning $ detVec !! 2) - it "rfc6979 test vector 4" (testSigning $ detVec !! 3) - it "rfc6979 test vector 5" (testSigning $ detVec !! 4) - it "rfc6979 test vector 6" (testSigning $ detVec !! 5) - it "rfc6979 test vector 7" (testSigning $ detVec !! 6) - it "rfc6979 test vector 8" (testSigning $ detVec !! 7) - it "rfc6979 test vector 9" (testSigning $ detVec !! 8) - it "rfc6979 test vector 10" (testSigning $ detVec !! 9) - it "rfc6979 test vector 11" (testSigning $ detVec !! 10) - it "rfc6979 test vector 12" (testSigning $ detVec !! 11) - --- No longer validating that generated signature is exactly equal to provided --- one. Fedora includes libsecp256k1 from Bitcoin ABC that computes --- deterministic signatures using a slightly different nonce generation --- algorithm. -testSigning :: (SecKey, ByteString, Text) -> Assertion -testSigning (prv, msg, str) = do - assertBool "my sig valid" $ verifyHashSig msg' g (derivePubKey prv) - assertBool "valid sig" $ verifyHashSig msg' g' (derivePubKey prv) - where - Just g' = importCompactSig =<< eitherToMaybe . decode =<< decodeHex str - g = signHash prv msg' - msg' = sha256 msg - - -{- ECDSA Canonical -} - --- github.com/bitcoin/bitcoin/blob/master/src/script.cpp --- from function IsCanonicalSignature -testIsCanonical :: Sig -> Bool -testIsCanonical sig = not $ - -- Non-canonical signature: too short - (len < 8) || - -- Non-canonical signature: too long - (len > 72) || - -- Non-canonical signature: wrong type - (BS.index s 0 /= 0x30) || - -- Non-canonical signature: wrong length marker - (BS.index s 1 /= len - 2) || - -- Non-canonical signature: S length misplaced - (5 + rlen >= len) || - -- Non-canonical signature: R+S length mismatch - (rlen + slen + 6 /= len) || - -- Non-canonical signature: R value type mismatch - (BS.index s 2 /= 0x02) || - -- Non-canonical signature: R length is zero - (rlen == 0) || - -- Non-canonical signature: R value negative - testBit (BS.index s 4) 7 || - -- Non-canonical signature: R value excessively padded - ( rlen > 1 - && BS.index s 4 == 0 - && not (testBit (BS.index s 5) 7) - ) || - -- Non-canonical signature: S value type mismatch - (BS.index s (fromIntegral rlen + 4) /= 0x02) || - -- Non-canonical signature: S length is zero - (slen == 0) || - -- Non-canonical signature: S value negative - testBit (BS.index s (fromIntegral rlen+6)) 7 || - -- Non-canonical signature: S value excessively padded - ( slen > 1 - && BS.index s (fromIntegral rlen + 6) == 0 - && not (testBit (BS.index s (fromIntegral rlen + 7)) 7) - ) - where - s = exportSig sig - len = fromIntegral $ BS.length s - rlen = BS.index s 3 - slen = BS.index s (fromIntegral rlen + 5) - - -{- Trezor RFC 6979 Test Vectors -} --- github.com/trezor/python-ecdsa/blob/master/ecdsa/test_pyecdsa.py - -detVec :: [(SecKey, ByteString, Text)] -detVec = - [ - ( "0000000000000000000000000000000000000000000000000000000000000001" - , "Satoshi Nakamoto" - , "934b1ea10a4b3c1757e2b0c017d0b6143ce3c9a7e6a4a49860d7a6ab210ee3d82442ce9d2b916064108014783e923ec36b49743e2ffa1c4496f01a512aafd9e5" - ) - , ( "0000000000000000000000000000000000000000000000000000000000000001" - , "All those moments will be lost in time, like tears in rain. Time to die..." - , "8600dbd41e348fe5c9465ab92d23e3db8b98b873beecd930736488696438cb6b547fe64427496db33bf66019dacbf0039c04199abb0122918601db38a72cfc21" - ) - , ( "fffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364140" - , "Satoshi Nakamoto" - , "fd567d121db66e382991534ada77a6bd3106f0a1098c231e47993447cd6af2d06b39cd0eb1bc8603e159ef5c20a5c8ad685a45b06ce9bebed3f153d10d93bed5" - ) - , ( "f8b8af8ce3c7cca5e300d33939540c10d45ce001b8f252bfbc57ba0342904181" - , "Alan Turing" - , "7063ae83e7f62bbb171798131b4a0564b956930092b33b07b395615d9ec7e15c58dfcc1e00a35e1572f366ffe34ba0fc47db1e7189759b9fb233c5b05ab388ea" - ) - , ( "e91671c46231f833a6406ccbea0e3e392c76c167bac1cb013f6f1013980455c2" - , "There is a computer disease that anybody who works with computers knows about. It's a very serious disease and it interferes completely with the work. The trouble with computers is that you 'play' with them!" - , "b552edd27580141f3b2a5463048cb7cd3e047b97c9f98076c32dbdf85a68718b279fa72dd19bfae05577e06c7c0c1900c371fcd5893f7e1d56a37d30174671f6" - ) - , ( "0000000000000000000000000000000000000000000000000000000000000001" - , "Everything should be made as simple as possible, but not simpler." - , "33a69cd2065432a30f3d1ce4eb0d59b8ab58c74f27c41a7fdb5696ad4e6108c96f807982866f785d3f6418d24163ddae117b7db4d5fdf0071de069fa54342262" - ) - , ( "fffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364140" - , "Equations are more important to me, because politics is for the present, but an equation is something for eternity." - , "54c4a33c6423d689378f160a7ff8b61330444abb58fb470f96ea16d99d4a2fed07082304410efa6b2943111b6a4e0aaa7b7db55a07e9861d1fb3cb1f421044a5" - ) - , ( "fffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364140" - , "Not only is the Universe stranger than we think, it is stranger than we can think." - , "ff466a9f1b7b273e2f4c3ffe032eb2e814121ed18ef84665d0f515360dab3dd06fc95f5132e5ecfdc8e5e6e616cc77151455d46ed48f5589b7db7771a332b283" - ) - , ( "0000000000000000000000000000000000000000000000000000000000000001" - , "How wonderful that we have met with a paradox. Now we have some hope of making progress." - , "c0dafec8251f1d5010289d210232220b03202cba34ec11fec58b3e93a85b91d375afdc06b7d6322a590955bf264e7aaa155847f614d80078a90292fe205064d3" - ) - , ( "69ec59eaa1f4f2e36b639716b7c30ca86d9a5375c7b38d8918bd9c0ebc80ba64" - , "Computer science is no more about computers than astronomy is about telescopes." - , "7186363571d65e084e7f02b0b77c3ec44fb1b257dee26274c38c928986fea45d0de0b38e06807e46bda1f1e293f4f6323e854c86d58abdd00c46c16441085df6" - ) - , ( "00000000000000000000000000007246174ab1e92e9149c6e446fe194d072637" - , "...if you aren't, at any given time, scandalized by code you wrote five or even three years ago, you're not learning anywhere near enough" - , "fbfe5076a15860ba8ed00e75e9bd22e05d230f02a936b653eb55b61c99dda4870e68880ebb0050fe4312b1b1eb0899e1b82da89baa5b895f612619edf34cbd37" - ) - , ( "000000000000000000000000000000000000000000056916d0f9b31dc9b637f3" - , "The question of whether computers can think is like the question of whether submarines can swim." - , "cde1302d83f8dd835d89aef803c74a119f561fbaef3eb9129e45f30de86abbf906ce643f5049ee1f27890467b77a6a8e11ec4661cc38cd8badf90115fbd03cef" - ) - ] diff --git a/test/Network/Haskoin/CryptoSpec.hs b/test/Network/Haskoin/CryptoSpec.hs deleted file mode 100644 --- a/test/Network/Haskoin/CryptoSpec.hs +++ /dev/null @@ -1,165 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Network.Haskoin.CryptoSpec (spec) where - -import Control.Monad -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as C (pack) -import Data.Maybe (fromMaybe, isJust, isNothing) -import Data.Text (Text) -import Network.Haskoin.Address -import Network.Haskoin.Constants -import Network.Haskoin.Crypto -import Network.Haskoin.Keys -import Network.Haskoin.Util -import Test.Hspec -import Test.HUnit (Assertion, assertBool) - --- Unit tests copied from bitcoind implementation --- https://github.com/bitcoin/bitcoin/blob/master/src/test/key_tests.cpp - -strSecret1 :: Text -strSecret1 = "5HxWvvfubhXpYYpS3tJkw6fq9jE9j18THftkZjHHfmFiWtmAbrj" - -strSecret2 :: Text -strSecret2 = "5KC4ejrDjv152FGwP386VD1i2NYc5KkfSMyv1nGy1VGDxGHqVY3" - -strSecret1C :: Text -strSecret1C = "Kwr371tjA9u2rFSMZjTNun2PXXP3WPZu2afRHTcta6KxEUdm1vEw" - -strSecret2C :: Text -strSecret2C = "L3Hq7a8FEQwJkW1M2GNKDW28546Vp5miewcCzSqUD9kCAXrJdS3g" - -addr1 :: Text -addr1 = "1QFqqMUD55ZV3PJEJZtaKCsQmjLT6JkjvJ" - -addr2 :: Text -addr2 = "1F5y5E5FMc5YzdJtB9hLaUe43GDxEKXENJ" - -addr1C :: Text -addr1C = "1NoJrossxPBKfCHuJXT4HadJrXRE9Fxiqs" - -addr2C :: Text -addr2C = "1CRj2HyM1CXWzHAXLQtiGLyggNT9WQqsDs" - -strAddressBad :: Text -strAddressBad = "1HV9Lc3sNHZxwj4Zk6fB38tEmBryq2cBiF" - -sigMsg :: [ByteString] -sigMsg = - [ mconcat ["Very secret message ", C.pack (show (i :: Int)), ": 11"] - | i <- [0..15] - ] - -sec1 :: SecKeyI -sec1 = - fromMaybe (error "Could not decode WIF secret 1") (fromWif btc strSecret1) - -sec2 :: SecKeyI -sec2 = - fromMaybe (error "Could not decode WIF secret 2") (fromWif btc strSecret2) - -sec1C :: SecKeyI -sec1C = - fromMaybe - (error "Could not decode WIF compressed secret 1") - (fromWif btc strSecret1C) - -sec2C :: SecKeyI -sec2C = - fromMaybe - (error "Could not decode WIF compressed secret 2") - (fromWif btc strSecret2C) - -pub1 :: PubKeyI -pub1 = derivePubKeyI sec1 - -pub2 :: PubKeyI -pub2 = derivePubKeyI sec2 - -pub1C :: PubKeyI -pub1C = derivePubKeyI sec1C - -pub2C :: PubKeyI -pub2C = derivePubKeyI sec2C - -spec :: Spec -spec = - describe "bitcoind /src/test/key_tests.cpp" $ do - it "decode valid wif" checkPrivkey - it "decode invalid wif" checkInvalidKey - it "decode minikey format" checkMiniKey - it "check private key compression" checkPrvKeyCompressed - it "check public key compression" checkKeyCompressed - it "check matching address" checkMatchingAddress - it "check various signatures" sigCheck - -sigCheck :: Assertion -sigCheck = forM_ sigMsg $ checkSignatures . doubleSHA256 - -{- bitcoind /src/test/key_tests.cpp -} - -checkPrivkey :: Assertion -checkPrivkey = do - assertBool "Key 1" $ isJust $ fromWif btc strSecret1 - assertBool "Key 2" $ isJust $ fromWif btc strSecret2 - assertBool "Key 1C" $ isJust $ fromWif btc strSecret1C - assertBool "Key 2C" $ isJust $ fromWif btc strSecret2C - -checkInvalidKey :: Assertion -checkInvalidKey = - assertBool "Bad key" $ isNothing $ fromWif btc strAddressBad - -checkMiniKey :: Assertion -checkMiniKey = - assertBool "Bad mini key" $ - isJust res && fromMiniKey "S6c56bnXQiBjk9mqSYE7ykVQ7NzrRy" == res - where - res = do - bs <- - decodeHex - "4C7A9640C72DC2099F23715D0C8A0D8A35F8906E3CAB61DD3F78B67BF887C9AB" - wrapSecKey False <$> secKey bs - -checkPrvKeyCompressed :: Assertion -checkPrvKeyCompressed = do - assertBool "Key 1" $ not $ secKeyCompressed sec1 - assertBool "Key 2" $ not $ secKeyCompressed sec2 - assertBool "Key 1C" $ secKeyCompressed sec1C - assertBool "Key 2C" $ secKeyCompressed sec2C - -checkKeyCompressed :: Assertion -checkKeyCompressed = do - assertBool "Key 1" $ not $ pubKeyCompressed pub1 - assertBool "Key 2" $ not $ pubKeyCompressed pub2 - assertBool "Key 1C" $ pubKeyCompressed pub1C - assertBool "Key 2C" $ pubKeyCompressed pub2C - -checkMatchingAddress :: Assertion -checkMatchingAddress = do - assertBool "Key 1" $ Just addr1 == addrToString btc (pubKeyAddr pub1) - assertBool "Key 2" $ Just addr2 == addrToString btc (pubKeyAddr pub2) - assertBool "Key 1C" $ Just addr1C == addrToString btc (pubKeyAddr pub1C) - assertBool "Key 2C" $ Just addr2C == addrToString btc (pubKeyAddr pub2C) - -checkSignatures :: Hash256 -> Assertion -checkSignatures h = do - let sign1 = signHash (secKeyData sec1) h - sign2 = signHash (secKeyData sec2) h - sign1C = signHash (secKeyData sec1C) h - sign2C = signHash (secKeyData sec2C) h - assertBool "Key 1, Sign1" $ verifyHashSig h sign1 (pubKeyPoint pub1) - assertBool "Key 1, Sign2" $ not $ verifyHashSig h sign2 (pubKeyPoint pub1) - assertBool "Key 1, Sign1C" $ verifyHashSig h sign1C (pubKeyPoint pub1) - assertBool "Key 1, Sign2C" $ not $ verifyHashSig h sign2C (pubKeyPoint pub1) - assertBool "Key 2, Sign1" $ not $ verifyHashSig h sign1 (pubKeyPoint pub2) - assertBool "Key 2, Sign2" $ verifyHashSig h sign2 (pubKeyPoint pub2) - assertBool "Key 2, Sign1C" $ not $ verifyHashSig h sign1C (pubKeyPoint pub2) - assertBool "Key 2, Sign2C" $ verifyHashSig h sign2C (pubKeyPoint pub2) - assertBool "Key 1C, Sign1" $ verifyHashSig h sign1 (pubKeyPoint pub1C) - assertBool "Key 1C, Sign2" $ not $ verifyHashSig h sign2 (pubKeyPoint pub1C) - assertBool "Key 1C, Sign1C" $ verifyHashSig h sign1C (pubKeyPoint pub1C) - assertBool "Key 1C, Sign2C" $ not $ verifyHashSig h sign2C (pubKeyPoint pub1C) - assertBool "Key 2C, Sign1" $ not $ verifyHashSig h sign1 (pubKeyPoint pub2C) - assertBool "Key 2C, Sign2" $ verifyHashSig h sign2 (pubKeyPoint pub2C) - assertBool "Key 2C, Sign1C" $ not $ verifyHashSig h sign1C (pubKeyPoint pub2C) - assertBool "Key 2C, Sign2C" $ verifyHashSig h sign2C (pubKeyPoint pub2C) diff --git a/test/Network/Haskoin/Keys/ExtendedSpec.hs b/test/Network/Haskoin/Keys/ExtendedSpec.hs deleted file mode 100644 --- a/test/Network/Haskoin/Keys/ExtendedSpec.hs +++ /dev/null @@ -1,521 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Network.Haskoin.Keys.ExtendedSpec (spec) where - -import Data.Aeson as A -import Data.Aeson.Types as A -import Data.Bits ((.&.)) -import qualified Data.ByteString.Lazy.Char8 as B8 -import Data.Either (isLeft) -import Data.Map.Strict (singleton) -import Data.Maybe (fromJust, isJust, isNothing) -import Data.Serialize as S -import Data.String (fromString) -import Data.String.Conversions (cs) -import Data.Text (Text) -import Data.Word (Word32) -import Network.Haskoin.Address -import Network.Haskoin.Constants -import Network.Haskoin.Keys -import Network.Haskoin.Test -import Network.Haskoin.Util -import Test.Hspec -import Test.HUnit (Assertion, assertBool, assertEqual) -import Test.QuickCheck hiding ((.&.)) - -spec :: Spec -spec = do - describe "bip32 derivation vector 1" $ do - it "chain m" $ runXKeyVec (head xKeyVec) - it "chain m/0'" $ runXKeyVec (xKeyVec !! 1) - it "chain m/0'/1" $ runXKeyVec (xKeyVec !! 2) - it "chain m/0'/1/2'" $ runXKeyVec (xKeyVec !! 3) - it "chain m/0'/1/2'/2" $ runXKeyVec (xKeyVec !! 4) - it "chain m/0'/1/2'/2/1000000000" $ runXKeyVec (xKeyVec !! 5) - describe "bip32 subkey derivation vector 2" $ do - it "chain m" $ runXKeyVec (head xKeyVec2) - it "chain m/0" $ runXKeyVec (xKeyVec2 !! 1) - it "chain m/0/2147483647'" $ runXKeyVec (xKeyVec2 !! 2) - it "chain m/0/2147483647'/1" $ runXKeyVec (xKeyVec2 !! 3) - it "chain m/0/2147483647'/1/2147483646'" $ runXKeyVec (xKeyVec2 !! 4) - it "Chain m/0/2147483647'/1/2147483646'/2" $ runXKeyVec (xKeyVec2 !! 5) - describe "bip32 subkey derivation using string path" $ do - it "either derivations" testApplyPath - it "either derivations" testBadApplyPath - it "dublic derivations" testDerivePubPath - it "private derivations" testDerivePrvPath - it "path parsing" testParsePath - it "from json" testFromJsonPath - it "to json" testToJsonPath - describe "extended keys" $ do - let net = btc - it "computes pubkey of a subkey is subkey of the pubkey" $ - property $ forAll arbitraryXPrvKey pubKeyOfSubKeyIsSubKeyOfPubKey - it "exports and imports extended private key" $ - property $ - forAll arbitraryXPrvKey $ \k -> - xPrvImport net (xPrvExport net k) == Just k - it "exports and imports extended public key" $ - property $ - forAll arbitraryXPubKey $ \(_, k) -> - xPubImport net (xPubExport net k) == Just k - it "show and read derivation path" $ - property $ forAll arbitraryDerivPath $ \p -> read (show p) == p - it "show and read hard derivation path" $ - property $ forAll arbitraryHardPath $ \p -> read (show p) == p - it "show and read soft derivation path" $ - property $ forAll arbitrarySoftPath $ \p -> read (show p) == p - it "from string derivation path" $ - property $ - forAll arbitraryDerivPath $ \p -> fromString (cs $ pathToStr p) == p - it "from string hard derivation path" $ - property $ - forAll arbitraryHardPath $ \p -> fromString (cs $ pathToStr p) == p - it "from string soft derivation path" $ - property $ - forAll arbitrarySoftPath $ \p -> fromString (cs $ pathToStr p) == p - it "from and to lists of derivation paths" $ - property $ - forAll arbitraryDerivPath $ \p -> listToPath (pathToList p) == p - it "from and to lists of hard derivation paths" $ - property $ - forAll arbitraryHardPath $ \p -> - toHard (listToPath $ pathToList p) == Just p - it "from and to lists of soft derivation paths" $ - property $ - forAll arbitrarySoftPath $ \p -> - toSoft (listToPath $ pathToList p) == Just p - it "read and show parsed path" $ - property $ forAll arbitraryParsedPath $ \p -> read (show p) == p - it "encodes and decodes extended private key" $ - forAll - arbitraryXPrvKey - (testCustom (xPrvFromJSON net) (xPrvToJSON net)) - it "encodes and decodes extended public key" $ - forAll - arbitraryXPubKey - (testCustom (xPubFromJSON net) (xPubToJSON net) . snd) - it "encodes and decodes derivation path" $ - forAll arbitraryDerivPath testID - it "encodes and decodes parsed derivation path" $ - forAll arbitraryParsedPath testID - it "encodes and decodes extended private key" $ - property $ - forAll arbitraryXPrvKey $ - testPutGet (getXPrvKey net) (putXPrvKey net) - it "shows and reads extended private key" $ - property $ - forAll arbitraryXPrvKey $ \k -> read (show k) `shouldBe` k - it "shows and reads extended private key" $ - property $ - forAll arbitraryXPubKey $ \(prv, pub) -> - read (show (prv, pub)) `shouldBe` (prv, pub) - -testFromJsonPath :: Assertion -testFromJsonPath = - sequence_ $ do - path <- jsonPathVectors - return $ - assertEqual - path - (Just [fromString path :: DerivPath]) - (A.decode $ B8.pack $ "[\"" ++ path ++ "\"]") - -testToJsonPath :: Assertion -testToJsonPath = - sequence_ $ do - path <- jsonPathVectors - return $ - assertEqual - path - (B8.pack $ "[\"" ++ path ++ "\"]") - (A.encode [fromString path :: ParsedPath]) - -jsonPathVectors :: [String] -jsonPathVectors = - [ "m" - , "m/0" - , "m/0'" - , "M/0'" - , "m/2147483647" - , "M/2147483647" - , "m/1/2/3/4/5/6/7/8" - , "M/1/2/3/4/5/6/7/8" - , "m/1'/2'/3/4" - , "M/1'/2'/3/4" - ] - -testParsePath :: Assertion -testParsePath = - sequence_ $ do - (path, t) <- parsePathVectors - return $ assertBool path (t $ parsePath path) - -parsePathVectors :: [(String, Maybe ParsedPath -> Bool)] -parsePathVectors = - [ ("m", isJust) - , ("m/0'", isJust) - , ("M/0'", isJust) - , ("m/2147483648", isNothing) - , ("m/2147483647", isJust) - , ("M/2147483648", isNothing) - , ("M/2147483647", isJust) - , ("M/-1", isNothing) - , ("M/-2147483648", isNothing) - , ("m/1/2/3/4/5/6/7/8", isJust) - , ("M/1/2/3/4/5/6/7/8", isJust) - , ("m/1'/2'/3/4", isJust) - , ("M/1'/2'/3/4", isJust) - , ("m/1/2'/3/4'", isJust) - , ("M/1/2'/3/4'", isJust) - , ("meh", isNothing) - , ("infinity", isNothing) - , ("NaN", isNothing) - ] - -testApplyPath :: Assertion -testApplyPath = - sequence_ $ do - (key, path, final) <- applyPathVectors - return $ - assertEqual path final $ applyPath (fromJust $ parsePath path) key - -testBadApplyPath :: Assertion -testBadApplyPath = - sequence_ $ do - (key, path) <- badApplyPathVectors - return $ - assertBool path $ isLeft $ applyPath (fromJust $ parsePath path) key - -testDerivePubPath :: Assertion -testDerivePubPath = - sequence_ $ do - (key, path, final) <- derivePubPathVectors - return $ - assertEqual path final $ - derivePubPath (fromString path :: SoftPath) key - -testDerivePrvPath :: Assertion -testDerivePrvPath = - sequence_ $ do - (key, path, final) <- derivePrvPathVectors - return $ - assertEqual path final $ - derivePath (fromString path :: DerivPath) key - -derivePubPathVectors :: [(XPubKey, String, XPubKey)] -derivePubPathVectors = - [ ( xpub, "M", xpub ) - , ( xpub, "M/8", pubSubKey xpub 8 ) - , ( xpub, "M/8/30/1", foldl pubSubKey xpub [8,30,1] ) - ] - where - xprv = fromJust $ xPrvImport btc - "xprv9s21ZrQH143K46iDVRSyFfGfMgQjzC4BV3ZUfNbG7PHQrJjE53ofAn5gYkp6KQ\ - \WzGmb8oageSRxBY8s4rjr9VXPVp2HQDbwPt4H31Gg4LpB" - xpub = deriveXPubKey xprv - -derivePrvPathVectors :: [(XPrvKey, String, XPrvKey)] -derivePrvPathVectors = - [ ( xprv, "m", xprv ) - , ( xprv, "M", xprv ) - , ( xprv, "m/8'", hardSubKey xprv 8 ) - , ( xprv, "M/8'", hardSubKey xprv 8 ) - , ( xprv, "m/8'/30/1" - , foldl prvSubKey (hardSubKey xprv 8) [30,1] - ) - , ( xprv, "M/8'/30/1" - , foldl prvSubKey (hardSubKey xprv 8) [30,1] - ) - , ( xprv, "m/3/20" - , foldl prvSubKey xprv [3,20] - ) - , ( xprv, "M/3/20" - , foldl prvSubKey xprv [3,20] - ) - ] - where - xprv = fromJust $ xPrvImport btc - "xprv9s21ZrQH143K46iDVRSyFfGfMgQjzC4BV3ZUfNbG7PHQrJjE53ofAn5gYkp6KQ\ - \WzGmb8oageSRxBY8s4rjr9VXPVp2HQDbwPt4H31Gg4LpB" - -applyPathVectors :: [(XKey, String, Either String XKey)] -applyPathVectors = - [ (XPrv xprv btc, "m", Right (XPrv xprv btc)) - , (XPrv xprv btc, "M", Right (XPub xpub btc)) - , (XPrv xprv btc, "m/8'", Right (XPrv (hardSubKey xprv 8) btc)) - , ( XPrv xprv btc - , "M/8'" - , Right (XPub (deriveXPubKey (hardSubKey xprv 8)) btc)) - , ( XPrv xprv btc - , "m/8'/30/1" - , Right (XPrv (foldl prvSubKey (hardSubKey xprv 8) [30, 1]) btc)) - , ( XPrv xprv btc - , "M/8'/30/1" - , Right - (XPub - (deriveXPubKey (foldl prvSubKey (hardSubKey xprv 8) [30, 1])) - btc)) - , (XPrv xprv btc, "m/3/20", Right (XPrv (foldl prvSubKey xprv [3, 20]) btc)) - , ( XPrv xprv btc - , "M/3/20" - , Right (XPub (deriveXPubKey (foldl prvSubKey xprv [3, 20])) btc)) - , ( XPub xpub btc - , "M/3/20" - , Right (XPub (deriveXPubKey (foldl prvSubKey xprv [3, 20])) btc)) - ] - where - xprv = - fromJust $ - xPrvImport - btc - "xprv9s21ZrQH143K46iDVRSyFfGfMgQjzC4BV3ZUfNbG7PHQrJjE53ofAn5gYkp6KQ\ - \WzGmb8oageSRxBY8s4rjr9VXPVp2HQDbwPt4H31Gg4LpB" - xpub = deriveXPubKey xprv - -badApplyPathVectors :: [(XKey, String)] -badApplyPathVectors = - [ (XPub xpub btc, "m/8'") - , (XPub xpub btc, "M/8'") - , (XPub xpub btc, "M/1/2/3'/4/5") - ] - where - xprv = - fromJust $ - xPrvImport - btc - "xprv9s21ZrQH143K46iDVRSyFfGfMgQjzC4BV3ZUfNbG7PHQrJjE53ofAn5gYkp6KQ\ - \WzGmb8oageSRxBY8s4rjr9VXPVp2HQDbwPt4H31Gg4LpB" - xpub = deriveXPubKey xprv - - -runXKeyVec :: ([Text], XPrvKey) -> Assertion -runXKeyVec (v, m) = do - assertBool "xPrvID" $ encodeHex (S.encode $ xPrvID m) == head v - assertBool "xPrvFP" $ encodeHex (S.encode $ xPrvFP m) == v !! 1 - assertBool "xPrvAddr" $ - addrToString btc (xPubAddr $ deriveXPubKey m) == Just (v !! 2) - assertBool "prvKey" $ encodeHex (getSecKey $ xPrvKey m) == v !! 3 - assertBool "xPrvWIF" $ xPrvWif btc m == v !! 4 - assertBool "pubKey" $ - encodeHex (exportPubKey True $ xPubKey $ deriveXPubKey m) == v !! 5 - assertBool "chain code" $ encodeHex (S.encode $ xPrvChain m) == v !! 6 - assertBool "Hex PubKey" $ - encodeHex (runPut $ putXPubKey btc $ deriveXPubKey m) == v !! 7 - assertBool "Hex PrvKey" $ encodeHex (runPut (putXPrvKey btc m)) == v !! 8 - assertBool "Base58 PubKey" $ xPubExport btc (deriveXPubKey m) == v !! 9 - assertBool "Base58 PrvKey" $ xPrvExport btc m == v !! 10 - --- BIP 0032 Test Vectors --- https://en.bitcoin.it/wiki/BIP_0032_TestVectors - -xKeyVec :: [([Text], XPrvKey)] -xKeyVec = zip xKeyResVec $ foldl f [m] der - where f acc d = acc ++ [d $ last acc] - m = makeXPrvKey $ fromJust $ decodeHex m0 - der = [ flip hardSubKey 0 - , flip prvSubKey 1 - , flip hardSubKey 2 - , flip prvSubKey 2 - , flip prvSubKey 1000000000 - ] - -xKeyVec2 :: [([Text], XPrvKey)] -xKeyVec2 = zip xKeyResVec2 $ foldl f [m] der - where f acc d = acc ++ [d $ last acc] - m = makeXPrvKey $ fromJust $ decodeHex m1 - der = [ flip prvSubKey 0 - , flip hardSubKey 2147483647 - , flip prvSubKey 1 - , flip hardSubKey 2147483646 - , flip prvSubKey 2 - ] - -m0 :: Text -m0 = "000102030405060708090a0b0c0d0e0f" - -xKeyResVec :: [[Text]] -xKeyResVec = - [ - -- m - [ "3442193e1bb70916e914552172cd4e2dbc9df811" - , "3442193e" - , "15mKKb2eos1hWa6tisdPwwDC1a5J1y9nma" - , "e8f32e723decf4051aefac8e2c93c9c5b214313817cdb01a1494b917c8436b35" - , "L52XzL2cMkHxqxBXRyEpnPQZGUs3uKiL3R11XbAdHigRzDozKZeW" - , "0339a36013301597daef41fbe593a02cc513d0b55527ec2df1050e2e8ff49c85c2" - , "873dff81c02f525623fd1fe5167eac3a55a049de3d314bb42ee227ffed37d508" - , "0488b21e000000000000000000873dff81c02f525623fd1fe5167eac3a55a049de3d314bb42ee227ffed37d5080339a36013301597daef41fbe593a02cc513d0b55527ec2df1050e2e8ff49c85c2" - , "0488ade4000000000000000000873dff81c02f525623fd1fe5167eac3a55a049de3d314bb42ee227ffed37d50800e8f32e723decf4051aefac8e2c93c9c5b214313817cdb01a1494b917c8436b35" - , "xpub661MyMwAqRbcFtXgS5sYJABqqG9YLmC4Q1Rdap9gSE8NqtwybGhePY2gZ29ESFjqJoCu1Rupje8YtGqsefD265TMg7usUDFdp6W1EGMcet8" - , "xprv9s21ZrQH143K3QTDL4LXw2F7HEK3wJUD2nW2nRk4stbPy6cq3jPPqjiChkVvvNKmPGJxWUtg6LnF5kejMRNNU3TGtRBeJgk33yuGBxrMPHi" - ] - -- m/0' - , [ "5c1bd648ed23aa5fd50ba52b2457c11e9e80a6a7" - , "5c1bd648" - , "19Q2WoS5hSS6T8GjhK8KZLMgmWaq4neXrh" - , "edb2e14f9ee77d26dd93b4ecede8d16ed408ce149b6cd80b0715a2d911a0afea" - , "L5BmPijJjrKbiUfG4zbiFKNqkvuJ8usooJmzuD7Z8dkRoTThYnAT" - , "035a784662a4a20a65bf6aab9ae98a6c068a81c52e4b032c0fb5400c706cfccc56" - , "47fdacbd0f1097043b78c63c20c34ef4ed9a111d980047ad16282c7ae6236141" - , "0488b21e013442193e8000000047fdacbd0f1097043b78c63c20c34ef4ed9a111d980047ad16282c7ae6236141035a784662a4a20a65bf6aab9ae98a6c068a81c52e4b032c0fb5400c706cfccc56" - , "0488ade4013442193e8000000047fdacbd0f1097043b78c63c20c34ef4ed9a111d980047ad16282c7ae623614100edb2e14f9ee77d26dd93b4ecede8d16ed408ce149b6cd80b0715a2d911a0afea" - , "xpub68Gmy5EdvgibQVfPdqkBBCHxA5htiqg55crXYuXoQRKfDBFA1WEjWgP6LHhwBZeNK1VTsfTFUHCdrfp1bgwQ9xv5ski8PX9rL2dZXvgGDnw" - , "xprv9uHRZZhk6KAJC1avXpDAp4MDc3sQKNxDiPvvkX8Br5ngLNv1TxvUxt4cV1rGL5hj6KCesnDYUhd7oWgT11eZG7XnxHrnYeSvkzY7d2bhkJ7" - ] - -- m/0'/1 - , [ "bef5a2f9a56a94aab12459f72ad9cf8cf19c7bbe" - , "bef5a2f9" - , "1JQheacLPdM5ySCkrZkV66G2ApAXe1mqLj" - , "3c6cb8d0f6a264c91ea8b5030fadaa8e538b020f0a387421a12de9319dc93368" - , "KyFAjQ5rgrKvhXvNMtFB5PCSKUYD1yyPEe3xr3T34TZSUHycXtMM" - , "03501e454bf00751f24b1b489aa925215d66af2234e3891c3b21a52bedb3cd711c" - , "2a7857631386ba23dacac34180dd1983734e444fdbf774041578e9b6adb37c19" - , "0488b21e025c1bd648000000012a7857631386ba23dacac34180dd1983734e444fdbf774041578e9b6adb37c1903501e454bf00751f24b1b489aa925215d66af2234e3891c3b21a52bedb3cd711c" - , "0488ade4025c1bd648000000012a7857631386ba23dacac34180dd1983734e444fdbf774041578e9b6adb37c19003c6cb8d0f6a264c91ea8b5030fadaa8e538b020f0a387421a12de9319dc93368" - , "xpub6ASuArnXKPbfEwhqN6e3mwBcDTgzisQN1wXN9BJcM47sSikHjJf3UFHKkNAWbWMiGj7Wf5uMash7SyYq527Hqck2AxYysAA7xmALppuCkwQ" - , "xprv9wTYmMFdV23N2TdNG573QoEsfRrWKQgWeibmLntzniatZvR9BmLnvSxqu53Kw1UmYPxLgboyZQaXwTCg8MSY3H2EU4pWcQDnRnrVA1xe8fs" - ] - -- m/0'/1/2' - , [ "ee7ab90cde56a8c0e2bb086ac49748b8db9dce72" - , "ee7ab90c" - , "1NjxqbA9aZWnh17q1UW3rB4EPu79wDXj7x" - , "cbce0d719ecf7431d88e6a89fa1483e02e35092af60c042b1df2ff59fa424dca" - , "L43t3od1Gh7Lj55Bzjj1xDAgJDcL7YFo2nEcNaMGiyRZS1CidBVU" - , "0357bfe1e341d01c69fe5654309956cbea516822fba8a601743a012a7896ee8dc2" - , "04466b9cc8e161e966409ca52986c584f07e9dc81f735db683c3ff6ec7b1503f" - , "0488b21e03bef5a2f98000000204466b9cc8e161e966409ca52986c584f07e9dc81f735db683c3ff6ec7b1503f0357bfe1e341d01c69fe5654309956cbea516822fba8a601743a012a7896ee8dc2" - , "0488ade403bef5a2f98000000204466b9cc8e161e966409ca52986c584f07e9dc81f735db683c3ff6ec7b1503f00cbce0d719ecf7431d88e6a89fa1483e02e35092af60c042b1df2ff59fa424dca" - , "xpub6D4BDPcP2GT577Vvch3R8wDkScZWzQzMMUm3PWbmWvVJrZwQY4VUNgqFJPMM3No2dFDFGTsxxpG5uJh7n7epu4trkrX7x7DogT5Uv6fcLW5" - , "xprv9z4pot5VBttmtdRTWfWQmoH1taj2axGVzFqSb8C9xaxKymcFzXBDptWmT7FwuEzG3ryjH4ktypQSAewRiNMjANTtpgP4mLTj34bhnZX7UiM" - ] - -- m/0'/1/2'/2 - , [ "d880d7d893848509a62d8fb74e32148dac68412f" - , "d880d7d8" - , "1LjmJcdPnDHhNTUgrWyhLGnRDKxQjoxAgt" - , "0f479245fb19a38a1954c5c7c0ebab2f9bdfd96a17563ef28a6a4b1a2a764ef4" - , "KwjQsVuMjbCP2Zmr3VaFaStav7NvevwjvvkqrWd5Qmh1XVnCteBR" - , "02e8445082a72f29b75ca48748a914df60622a609cacfce8ed0e35804560741d29" - , "cfb71883f01676f587d023cc53a35bc7f88f724b1f8c2892ac1275ac822a3edd" - , "0488b21e04ee7ab90c00000002cfb71883f01676f587d023cc53a35bc7f88f724b1f8c2892ac1275ac822a3edd02e8445082a72f29b75ca48748a914df60622a609cacfce8ed0e35804560741d29" - , "0488ade404ee7ab90c00000002cfb71883f01676f587d023cc53a35bc7f88f724b1f8c2892ac1275ac822a3edd000f479245fb19a38a1954c5c7c0ebab2f9bdfd96a17563ef28a6a4b1a2a764ef4" - , "xpub6FHa3pjLCk84BayeJxFW2SP4XRrFd1JYnxeLeU8EqN3vDfZmbqBqaGJAyiLjTAwm6ZLRQUMv1ZACTj37sR62cfN7fe5JnJ7dh8zL4fiyLHV" - , "xprvA2JDeKCSNNZky6uBCviVfJSKyQ1mDYahRjijr5idH2WwLsEd4Hsb2Tyh8RfQMuPh7f7RtyzTtdrbdqqsunu5Mm3wDvUAKRHSC34sJ7in334" - ] - -- m/0'/1/2'/2/1000000000 - , [ "d69aa102255fed74378278c7812701ea641fdf32" - , "d69aa102" - , "1LZiqrop2HGR4qrH1ULZPyBpU6AUP49Uam" - , "471b76e389e528d6de6d816857e012c5455051cad6660850e58372a6c3e6e7c8" - , "Kybw8izYevo5xMh1TK7aUr7jHFCxXS1zv8p3oqFz3o2zFbhRXHYs" - , "022a471424da5e657499d1ff51cb43c47481a03b1e77f951fe64cec9f5a48f7011" - , "c783e67b921d2beb8f6b389cc646d7263b4145701dadd2161548a8b078e65e9e" - , "0488b21e05d880d7d83b9aca00c783e67b921d2beb8f6b389cc646d7263b4145701dadd2161548a8b078e65e9e022a471424da5e657499d1ff51cb43c47481a03b1e77f951fe64cec9f5a48f7011" - , "0488ade405d880d7d83b9aca00c783e67b921d2beb8f6b389cc646d7263b4145701dadd2161548a8b078e65e9e00471b76e389e528d6de6d816857e012c5455051cad6660850e58372a6c3e6e7c8" - , "xpub6H1LXWLaKsWFhvm6RVpEL9P4KfRZSW7abD2ttkWP3SSQvnyA8FSVqNTEcYFgJS2UaFcxupHiYkro49S8yGasTvXEYBVPamhGW6cFJodrTHy" - , "xprvA41z7zogVVwxVSgdKUHDy1SKmdb533PjDz7J6N6mV6uS3ze1ai8FHa8kmHScGpWmj4WggLyQjgPie1rFSruoUihUZREPSL39UNdE3BBDu76" - ] - ] - -m1 :: Text -m1 = "fffcf9f6f3f0edeae7e4e1dedbd8d5d2cfccc9c6c3c0bdbab7b4b1aeaba8a5a29f9c999693908d8a8784817e7b7875726f6c696663605d5a5754514e4b484542" - -xKeyResVec2 :: [[Text]] -xKeyResVec2 = - [ - -- m - [ "bd16bee53961a47d6ad888e29545434a89bdfe95" - , "bd16bee5" - , "1JEoxevbLLG8cVqeoGKQiAwoWbNYSUyYjg" - , "4b03d6fc340455b363f51020ad3ecca4f0850280cf436c70c727923f6db46c3e" - , "KyjXhyHF9wTphBkfpxjL8hkDXDUSbE3tKANT94kXSyh6vn6nKaoy" - , "03cbcaa9c98c877a26977d00825c956a238e8dddfbd322cce4f74b0b5bd6ace4a7" - , "60499f801b896d83179a4374aeb7822aaeaceaa0db1f85ee3e904c4defbd9689" - , "0488b21e00000000000000000060499f801b896d83179a4374aeb7822aaeaceaa0db1f85ee3e904c4defbd968903cbcaa9c98c877a26977d00825c956a238e8dddfbd322cce4f74b0b5bd6ace4a7" - , "0488ade400000000000000000060499f801b896d83179a4374aeb7822aaeaceaa0db1f85ee3e904c4defbd9689004b03d6fc340455b363f51020ad3ecca4f0850280cf436c70c727923f6db46c3e" - , "xpub661MyMwAqRbcFW31YEwpkMuc5THy2PSt5bDMsktWQcFF8syAmRUapSCGu8ED9W6oDMSgv6Zz8idoc4a6mr8BDzTJY47LJhkJ8UB7WEGuduB" - , "xprv9s21ZrQH143K31xYSDQpPDxsXRTUcvj2iNHm5NUtrGiGG5e2DtALGdso3pGz6ssrdK4PFmM8NSpSBHNqPqm55Qn3LqFtT2emdEXVYsCzC2U" - ] - -- m/0 - , [ "5a61ff8eb7aaca3010db97ebda76121610b78096" - , "5a61ff8e" - , "19EuDJdgfRkwCmRzbzVBHZWQG9QNWhftbZ" - , "abe74a98f6c7eabee0428f53798f0ab8aa1bd37873999041703c742f15ac7e1e" - , "L2ysLrR6KMSAtx7uPqmYpoTeiRzydXBattRXjXz5GDFPrdfPzKbj" - , "02fc9e5af0ac8d9b3cecfe2a888e2117ba3d089d8585886c9c826b6b22a98d12ea" - , "f0909affaa7ee7abe5dd4e100598d4dc53cd709d5a5c2cac40e7412f232f7c9c" - , "0488b21e01bd16bee500000000f0909affaa7ee7abe5dd4e100598d4dc53cd709d5a5c2cac40e7412f232f7c9c02fc9e5af0ac8d9b3cecfe2a888e2117ba3d089d8585886c9c826b6b22a98d12ea" - , "0488ade401bd16bee500000000f0909affaa7ee7abe5dd4e100598d4dc53cd709d5a5c2cac40e7412f232f7c9c00abe74a98f6c7eabee0428f53798f0ab8aa1bd37873999041703c742f15ac7e1e" - , "xpub69H7F5d8KSRgmmdJg2KhpAK8SR3DjMwAdkxj3ZuxV27CprR9LgpeyGmXUbC6wb7ERfvrnKZjXoUmmDznezpbZb7ap6r1D3tgFxHmwMkQTPH" - , "xprv9vHkqa6EV4sPZHYqZznhT2NPtPCjKuDKGY38FBWLvgaDx45zo9WQRUT3dKYnjwih2yJD9mkrocEZXo1ex8G81dwSM1fwqWpWkeS3v86pgKt" - ] - -- m/0/2147483647' - , [ "d8ab493736da02f11ed682f88339e720fb0379d1" - , "d8ab4937" - , "1Lke9bXGhn5VPrBuXgN12uGUphrttUErmk" - , "877c779ad9687164e9c2f4f0f4ff0340814392330693ce95a58fe18fd52e6e93" - , "L1m5VpbXmMp57P3knskwhoMTLdhAAaXiHvnGLMribbfwzVRpz2Sr" - , "03c01e7425647bdefa82b12d9bad5e3e6865bee0502694b94ca58b666abc0a5c3b" - , "be17a268474a6bb9c61e1d720cf6215e2a88c5406c4aee7b38547f585c9a37d9" - , "0488b21e025a61ff8effffffffbe17a268474a6bb9c61e1d720cf6215e2a88c5406c4aee7b38547f585c9a37d903c01e7425647bdefa82b12d9bad5e3e6865bee0502694b94ca58b666abc0a5c3b" - , "0488ade4025a61ff8effffffffbe17a268474a6bb9c61e1d720cf6215e2a88c5406c4aee7b38547f585c9a37d900877c779ad9687164e9c2f4f0f4ff0340814392330693ce95a58fe18fd52e6e93" - , "xpub6ASAVgeehLbnwdqV6UKMHVzgqAG8Gr6riv3Fxxpj8ksbH9ebxaEyBLZ85ySDhKiLDBrQSARLq1uNRts8RuJiHjaDMBU4Zn9h8LZNnBC5y4a" - , "xprv9wSp6B7kry3Vj9m1zSnLvN3xH8RdsPP1Mh7fAaR7aRLcQMKTR2vidYEeEg2mUCTAwCd6vnxVrcjfy2kRgVsFawNzmjuHc2YmYRmagcEPdU9" - ] - -- m/0/2147483647'/1 - , [ "78412e3a2296a40de124307b6485bd19833e2e34" - , "78412e3a" - , "1BxrAr2pHpeBheusmd6fHDP2tSLAUa3qsW" - , "704addf544a06e5ee4bea37098463c23613da32020d604506da8c0518e1da4b7" - , "KzyzXnznxSv249b4KuNkBwowaN3akiNeEHy5FWoPCJpStZbEKXN2" - , "03a7d1d856deb74c508e05031f9895dab54626251b3806e16b4bd12e781a7df5b9" - , "f366f48f1ea9f2d1d3fe958c95ca84ea18e4c4ddb9366c336c927eb246fb38cb" - , "0488b21e03d8ab493700000001f366f48f1ea9f2d1d3fe958c95ca84ea18e4c4ddb9366c336c927eb246fb38cb03a7d1d856deb74c508e05031f9895dab54626251b3806e16b4bd12e781a7df5b9" - , "0488ade403d8ab493700000001f366f48f1ea9f2d1d3fe958c95ca84ea18e4c4ddb9366c336c927eb246fb38cb00704addf544a06e5ee4bea37098463c23613da32020d604506da8c0518e1da4b7" - , "xpub6DF8uhdarytz3FWdA8TvFSvvAh8dP3283MY7p2V4SeE2wyWmG5mg5EwVvmdMVCQcoNJxGoWaU9DCWh89LojfZ537wTfunKau47EL2dhHKon" - , "xprv9zFnWC6h2cLgpmSA46vutJzBcfJ8yaJGg8cX1e5StJh45BBciYTRXSd25UEPVuesF9yog62tGAQtHjXajPPdbRCHuWS6T8XA2ECKADdw4Ef" - ] - -- m/0/2147483647'/1/2147483646' - , [ "31a507b815593dfc51ffc7245ae7e5aee304246e" - , "31a507b8" - , "15XVotxCAV7sRx1PSCkQNsGw3W9jT9A94R" - , "f1c7c871a54a804afe328b4c83a1c33b8e5ff48f5087273f04efa83b247d6a2d" - , "L5KhaMvPYRW1ZoFmRjUtxxPypQ94m6BcDrPhqArhggdaTbbAFJEF" - , "02d2b36900396c9282fa14628566582f206a5dd0bcc8d5e892611806cafb0301f0" - , "637807030d55d01f9a0cb3a7839515d796bd07706386a6eddf06cc29a65a0e29" - , "0488b21e0478412e3afffffffe637807030d55d01f9a0cb3a7839515d796bd07706386a6eddf06cc29a65a0e2902d2b36900396c9282fa14628566582f206a5dd0bcc8d5e892611806cafb0301f0" - , "0488ade40478412e3afffffffe637807030d55d01f9a0cb3a7839515d796bd07706386a6eddf06cc29a65a0e2900f1c7c871a54a804afe328b4c83a1c33b8e5ff48f5087273f04efa83b247d6a2d" - , "xpub6ERApfZwUNrhLCkDtcHTcxd75RbzS1ed54G1LkBUHQVHQKqhMkhgbmJbZRkrgZw4koxb5JaHWkY4ALHY2grBGRjaDMzQLcgJvLJuZZvRcEL" - , "xprvA1RpRA33e1JQ7ifknakTFpgNXPmW2YvmhqLQYMmrj4xJXXWYpDPS3xz7iAxn8L39njGVyuoseXzU6rcxFLJ8HFsTjSyQbLYnMpCqE2VbFWc" - ] - -- m/0/2147483647'/1/2147483646'/2 - , [ "26132fdbe7bf89cbc64cf8dafa3f9f88b8666220" - , "26132fdb" - , "14UKfRV9ZPUp6ZC9PLhqbRtxdihW9em3xt" - , "bb7d39bdb83ecf58f2fd82b6d918341cbef428661ef01ab97c28a4842125ac23" - , "L3WAYNAZPxx1fr7KCz7GN9nD5qMBnNiqEJNJMU1z9MMaannAt4aK" - , "024d902e1a2fc7a8755ab5b694c575fce742c48d9ff192e63df5193e4c7afe1f9c" - , "9452b549be8cea3ecb7a84bec10dcfd94afe4d129ebfd3b3cb58eedf394ed271" - , "0488b21e0531a507b8000000029452b549be8cea3ecb7a84bec10dcfd94afe4d129ebfd3b3cb58eedf394ed271024d902e1a2fc7a8755ab5b694c575fce742c48d9ff192e63df5193e4c7afe1f9c" - , "0488ade40531a507b8000000029452b549be8cea3ecb7a84bec10dcfd94afe4d129ebfd3b3cb58eedf394ed27100bb7d39bdb83ecf58f2fd82b6d918341cbef428661ef01ab97c28a4842125ac23" - , "xpub6FnCn6nSzZAw5Tw7cgR9bi15UV96gLZhjDstkXXxvCLsUXBGXPdSnLFbdpq8p9HmGsApME5hQTZ3emM2rnY5agb9rXpVGyy3bdW6EEgAtqt" - , "xprvA2nrNbFZABcdryreWet9Ea4LvTJcGsqrMzxHx98MMrotbir7yrKCEXw7nadnHM8Dq38EGfSh6dqA9QWTyefMLEcBYJUuekgW4BYPJcr9E7j" - ] - ] - -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 - - -testID :: (FromJSON a, ToJSON a, Eq a) => a -> Bool -testID x = - (A.decode . A.encode) (singleton ("object" :: String) x) == - Just (singleton ("object" :: String) x) - -testCustom :: Eq a => (Value -> Parser a) -> (a -> Value) -> a -> Bool -testCustom f g x = parseMaybe f (g x) == Just x - -testPutGet :: Eq a => Get a -> Putter a -> a -> Bool -testPutGet g p a = runGet g (runPut (p a)) == Right a diff --git a/test/Network/Haskoin/Keys/MnemonicSpec.hs b/test/Network/Haskoin/Keys/MnemonicSpec.hs deleted file mode 100644 --- a/test/Network/Haskoin/Keys/MnemonicSpec.hs +++ /dev/null @@ -1,494 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Network.Haskoin.Keys.MnemonicSpec (spec) where - -import Control.Monad (zipWithM_) -import Data.Bits (shiftR, (.&.)) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as C -import Data.Either (fromRight) -import Data.List (isPrefixOf) -import Data.Maybe (fromJust) -import Data.Serialize (Serialize, encode) -import Data.String.Conversions (cs) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Word (Word32, Word64) -import Network.Haskoin.Crypto -import Network.Haskoin.Keys -import Network.Haskoin.Test -import Network.Haskoin.Util -import Test.Hspec -import Test.HUnit -import Test.QuickCheck hiding ((.&.)) - -spec :: Spec -spec = - describe "mnemonic" $ do - it "entropy to mnemonic sentence" toMnemonicTest - it "mnemonic sentence to entropy" fromMnemonicTest - it "mnemonic sentence to seed" mnemonicToSeedTest - it "mnemonic sentence with invalid checksum" fromMnemonicInvalidTest - it "empty mnemonic sentence is invalid" $ sequence_ [emptyMnemonicTest] - it "generate 12 words" $ property toMnemonic128 - it "generate 18 words" $ property toMnemonic160 - it "generate 24 words" $ property toMnemonic256 - it "generate 48 words" $ property toMnemonic512 - it "generate any number of words" $ property toMnemonicVar - it "encode and decode 128-bit entropy" $ property fromToMnemonic128 - it "encode and decode 160-bit entropy" $ property fromToMnemonic160 - it "encode and decode 256-bit entropy" $ property fromToMnemonic256 - it "encode and decode 512-bit entropy" $ property fromToMnemonic512 - it "encode and decode n-bit entropy" $ property fromToMnemonicVar - it "convert 128-bit mnemonic to seed" $ property mnemonicToSeed128 - it "convert 160-bit mnemonic to seed" $ property mnemonicToSeed160 - it "convert 256-bit mnemonic to seed" $ property mnemonicToSeed256 - it "convert 512-bit mnemonic to seed" $ property mnemonicToSeed512 - it "convert n-bit mnemonic to seed" $ property mnemonicToSeedVar - it "get bits" $ property getBitsByteCount - it "get end bits" $ property getBitsEndBits - -toMnemonicTest :: Assertion -toMnemonicTest = zipWithM_ f ents mss - where - f e m = assertEqual "" m . h $ e - h = - fromRight (error "Could not decode mnemonic sentence") . - toMnemonic . fromJust . decodeHex - -fromMnemonicTest :: Assertion -fromMnemonicTest = zipWithM_ f ents mss - where - f e = assertEqual "" e . h - h = - encodeHex . - fromRight (error "Could not decode mnemonic sentence") . fromMnemonic - -mnemonicToSeedTest :: Assertion -mnemonicToSeedTest = zipWithM_ f mss seeds - where - f m s = assertEqual "" s . h $ m - h = - encodeHex . - fromRight (error "Could not decode mnemonic seed") . - mnemonicToSeed "TREZOR" - -fromMnemonicInvalidTest :: Assertion -fromMnemonicInvalidTest = mapM_ f invalidMss - where - f = assertBool "" . h - h m = case fromMnemonic m of - Right _ -> False - Left err -> "fromMnemonic: checksum failed:" `isPrefixOf` err - -emptyMnemonicTest :: Assertion -emptyMnemonicTest = - assertBool "" $ - case fromMnemonic "" of - Right _ -> False - Left err -> "fromMnemonic: empty mnemonic" `isPrefixOf` err - -ents :: [Text] -ents = - [ "00000000000000000000000000000000" - , "7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f" - , "80808080808080808080808080808080" - , "ffffffffffffffffffffffffffffffff" - , "000000000000000000000000000000000000000000000000" - , "7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f" - , "808080808080808080808080808080808080808080808080" - , "ffffffffffffffffffffffffffffffffffffffffffffffff" - , "0000000000000000000000000000000000000000000000000000000000000000" - , "7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f7f" - , "8080808080808080808080808080808080808080808080808080808080808080" - , "ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff" - , "77c2b00716cec7213839159e404db50d" - , "b63a9c59a6e641f288ebc103017f1da9f8290b3da6bdef7b" - , "3e141609b97933b66a060dcddc71fad1d91677db872031e85f4c015c5e7e8982" - , "0460ef47585604c5660618db2e6a7e7f" - , "72f60ebac5dd8add8d2a25a797102c3ce21bc029c200076f" - , "2c85efc7f24ee4573d2b81a6ec66cee209b2dcbd09d8eddc51e0215b0b68e416" - , "eaebabb2383351fd31d703840b32e9e2" - , "7ac45cfe7722ee6c7ba84fbc2d5bd61b45cb2fe5eb65aa78" - , "4fa1a8bc3e6d80ee1316050e862c1812031493212b7ec3f3bb1b08f168cabeef" - , "18ab19a9f54a9274f03e5209a2ac8a91" - , "18a2e1d81b8ecfb2a333adcb0c17a5b9eb76cc5d05db91a4" - , "15da872c95a13dd738fbf50e427583ad61f18fd99f628c417a61cf8343c90419" - ] - -mss :: [Mnemonic] -mss = - [ "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ - \ abandon abandon about" - , "legal winner thank year wave sausage worth useful legal winner thank\ - \ yellow" - , "letter advice cage absurd amount doctor acoustic avoid letter advice\ - \ cage above" - , "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo wrong" - , "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ - \ abandon abandon abandon abandon abandon abandon abandon abandon agent" - , "legal winner thank year wave sausage worth useful legal winner thank\ - \ year wave sausage worth useful legal will" - , "letter advice cage absurd amount doctor acoustic avoid letter advice\ - \ cage absurd amount doctor acoustic avoid letter always" - , "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo\ - \ when" - , "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ - \ abandon abandon abandon abandon abandon abandon abandon abandon abandon\ - \ abandon abandon abandon abandon abandon art" - , "legal winner thank year wave sausage worth useful legal winner thank\ - \ year wave sausage worth useful legal winner thank year wave sausage\ - \ worth title" - , "letter advice cage absurd amount doctor acoustic avoid letter advice\ - \ cage absurd amount doctor acoustic avoid letter advice cage absurd\ - \ amount doctor acoustic bless" - , "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo\ - \ zoo zoo zoo zoo zoo vote" - , "jelly better achieve collect unaware mountain thought cargo oxygen act\ - \ hood bridge" - , "renew stay biology evidence goat welcome casual join adapt armor shuffle\ - \ fault little machine walk stumble urge swap" - , "dignity pass list indicate nasty swamp pool script soccer toe leaf photo\ - \ multiply desk host tomato cradle drill spread actor shine dismiss\ - \ champion exotic" - , "afford alter spike radar gate glance object seek swamp infant panel\ - \ yellow" - , "indicate race push merry suffer human cruise dwarf pole review arch keep\ - \ canvas theme poem divorce alter left" - , "clutch control vehicle tonight unusual clog visa ice plunge glimpse\ - \ recipe series open hour vintage deposit universe tip job dress radar\ - \ refuse motion taste" - , "turtle front uncle idea crush write shrug there lottery flower risk\ - \ shell" - , "kiss carry display unusual confirm curtain upgrade antique rotate hello\ - \ void custom frequent obey nut hole price segment" - , "exile ask congress lamp submit jacket era scheme attend cousin alcohol\ - \ catch course end lucky hurt sentence oven short ball bird grab wing top" - , "board flee heavy tunnel powder denial science ski answer betray cargo\ - \ cat" - , "board blade invite damage undo sun mimic interest slam gaze truly\ - \ inherit resist great inject rocket museum chief" - , "beyond stage sleep clip because twist token leaf atom beauty genius food\ - \ business side grid unable middle armed observe pair crouch tonight away\ - \ coconut" - ] - -seeds :: [Text] -seeds = - [ "c55257c360c07c72029aebc1b53c05ed0362ada38ead3e3e9efa3708e53495531f09a69\ - \87599d18264c1e1c92f2cf141630c7a3c4ab7c81b2f001698e7463b04" - , "2e8905819b8723fe2c1d161860e5ee1830318dbf49a83bd451cfb8440c28bd6fa457fe1\ - \296106559a3c80937a1c1069be3a3a5bd381ee6260e8d9739fce1f607" - , "d71de856f81a8acc65e6fc851a38d4d7ec216fd0796d0a6827a3ad6ed5511a30fa280f1\ - \2eb2e47ed2ac03b5c462a0358d18d69fe4f985ec81778c1b370b652a8" - , "ac27495480225222079d7be181583751e86f571027b0497b5b5d11218e0a8a133325729\ - \17f0f8e5a589620c6f15b11c61dee327651a14c34e18231052e48c069" - , "035895f2f481b1b0f01fcf8c289c794660b289981a78f8106447707fdd9666ca06da5a9\ - \a565181599b79f53b844d8a71dd9f439c52a3d7b3e8a79c906ac845fa" - , "f2b94508732bcbacbcc020faefecfc89feafa6649a5491b8c952cede496c214a0c7b3c3\ - \92d168748f2d4a612bada0753b52a1c7ac53c1e93abd5c6320b9e95dd" - , "107d7c02a5aa6f38c58083ff74f04c607c2d2c0ecc55501dadd72d025b751bc27fe913f\ - \fb796f841c49b1d33b610cf0e91d3aa239027f5e99fe4ce9e5088cd65" - , "0cd6e5d827bb62eb8fc1e262254223817fd068a74b5b449cc2f667c3f1f985a76379b43\ - \348d952e2265b4cd129090758b3e3c2c49103b5051aac2eaeb890a528" - , "bda85446c68413707090a52022edd26a1c9462295029f2e60cd7c4f2bbd3097170af7a4\ - \d73245cafa9c3cca8d561a7c3de6f5d4a10be8ed2a5e608d68f92fcc8" - , "bc09fca1804f7e69da93c2f2028eb238c227f2e9dda30cd63699232578480a4021b146a\ - \d717fbb7e451ce9eb835f43620bf5c514db0f8add49f5d121449d3e87" - , "c0c519bd0e91a2ed54357d9d1ebef6f5af218a153624cf4f2da911a0ed8f7a09e2ef61a\ - \f0aca007096df430022f7a2b6fb91661a9589097069720d015e4e982f" - , "dd48c104698c30cfe2b6142103248622fb7bb0ff692eebb00089b32d22484e1613912f0\ - \a5b694407be899ffd31ed3992c456cdf60f5d4564b8ba3f05a69890ad" - , "b5b6d0127db1a9d2226af0c3346031d77af31e918dba64287a1b44b8ebf63cdd52676f6\ - \72a290aae502472cf2d602c051f3e6f18055e84e4c43897fc4e51a6ff" - , "9248d83e06f4cd98debf5b6f010542760df925ce46cf38a1bdb4e4de7d21f5c39366941\ - \c69e1bdbf2966e0f6e6dbece898a0e2f0a4c2b3e640953dfe8b7bbdc5" - , "ff7f3184df8696d8bef94b6c03114dbee0ef89ff938712301d27ed8336ca89ef9635da2\ - \0af07d4175f2bf5f3de130f39c9d9e8dd0472489c19b1a020a940da67" - , "65f93a9f36b6c85cbe634ffc1f99f2b82cbb10b31edc7f087b4f6cb9e976e9faf76ff41\ - \f8f27c99afdf38f7a303ba1136ee48a4c1e7fcd3dba7aa876113a36e4" - , "3bbf9daa0dfad8229786ace5ddb4e00fa98a044ae4c4975ffd5e094dba9e0bb289349db\ - \e2091761f30f382d4e35c4a670ee8ab50758d2c55881be69e327117ba" - , "fe908f96f46668b2d5b37d82f558c77ed0d69dd0e7e043a5b0511c48c2f1064694a956f\ - \86360c93dd04052a8899497ce9e985ebe0c8c52b955e6ae86d4ff4449" - , "bdfb76a0759f301b0b899a1e3985227e53b3f51e67e3f2a65363caedf3e32fde42a66c4\ - \04f18d7b05818c95ef3ca1e5146646856c461c073169467511680876c" - , "ed56ff6c833c07982eb7119a8f48fd363c4a9b1601cd2de736b01045c5eb8ab4f57b079\ - \403485d1c4924f0790dc10a971763337cb9f9c62226f64fff26397c79" - , "095ee6f817b4c2cb30a5a797360a81a40ab0f9a4e25ecd672a3f58a0b5ba0687c096a6b\ - \14d2c0deb3bdefce4f61d01ae07417d502429352e27695163f7447a8c" - , "6eff1bb21562918509c73cb990260db07c0ce34ff0e3cc4a8cb3276129fbcb300bddfe0\ - \05831350efd633909f476c45c88253276d9fd0df6ef48609e8bb7dca8" - , "f84521c777a13b61564234bf8f8b62b3afce27fc4062b51bb5e62bdfecb23864ee6ecf0\ - \7c1d5a97c0834307c5c852d8ceb88e7c97923c0a3b496bedd4e5f88a9" - , "b15509eaa2d09d3efd3e006ef42151b30367dc6e3aa5e44caba3fe4d3e352e65101fbdb\ - \86a96776b91946ff06f8eac594dc6ee1d3e82a42dfe1b40fef6bcc3fd" - ] - -invalidMss :: [Mnemonic] -invalidMss = - [ "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ - \ abandon abandon abandon" - , "legal winner thank year wave sausage worth useful legal winner thank\ - \ thank" - , "letter advice cage absurd amount doctor acoustic avoid letter advice\ - \ cage sausage" - , "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo" - , "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ - \ abandon abandon abandon abandon abandon abandon abandon abandon abandon" - , "legal winner thank year wave sausage worth useful legal winner thank\ - \ year wave sausage worth useful legal letter" - , "letter advice cage absurd amount doctor acoustic avoid letter advice\ - \ cage absurd amount doctor acoustic avoid letter abandon" - , "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo\ - \ zoo" - , "abandon abandon abandon abandon abandon abandon abandon abandon abandon\ - \ abandon abandon abandon abandon abandon abandon abandon abandon abandon\ - \ abandon abandon abandon abandon abandon abandon" - , "legal winner thank year wave sausage worth useful legal winner thank\ - \ year wave sausage worth useful legal winner thank year wave sausage\ - \ worth letter" - , "letter advice cage absurd amount doctor acoustic avoid letter advice\ - \ cage absurd amount doctor acoustic avoid letter advice cage absurd\ - \ amount doctor acoustic letter" - , "zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo zoo\ - \ zoo zoo zoo zoo zoo zoo" - , "jelly better achieve collect unaware mountain thought cargo oxygen act\ - \ hood zoo" - , "renew stay biology evidence goat welcome casual join adapt armor shuffle\ - \ fault little machine walk stumble urge zoo" - , "dignity pass list indicate nasty swamp pool script soccer toe leaf photo\ - \ multiply desk host tomato cradle drill spread actor shine dismiss\ - \ champion zoo" - , "afford alter spike radar gate glance object seek swamp infant panel\ - \ zoo" - , "indicate race push merry suffer human cruise dwarf pole review arch keep\ - \ canvas theme poem divorce alter zoo" - , "clutch control vehicle tonight unusual clog visa ice plunge glimpse\ - \ recipe series open hour vintage deposit universe tip job dress radar\ - \ refuse motion zoo" - , "turtle front uncle idea crush write shrug there lottery flower risk\ - \ zoo" - , "kiss carry display unusual confirm curtain upgrade antique rotate hello\ - \ void custom frequent obey nut hole price zoo" - , "exile ask congress lamp submit jacket era scheme attend cousin alcohol\ - \ catch course end lucky hurt sentence oven short ball bird grab wing zoo" - , "board flee heavy tunnel powder denial science ski answer betray cargo\ - \ zoo" - , "board blade invite damage undo sun mimic interest slam gaze truly\ - \ inherit resist great inject rocket museum zoo" - , "beyond stage sleep clip because twist token leaf atom beauty genius food\ - \ business side grid unable middle armed observe pair crouch tonight away\ - \ zoo" - ] - -binWordsToBS :: Serialize a => [a] -> BS.ByteString -binWordsToBS = foldr f BS.empty - where - f b a = a `BS.append` encode b - -{- Encode mnemonic -} - -toMnemonic128 :: (Word64, Word64) -> Bool -toMnemonic128 (a, b) = l == 12 - where - bs = encode a `BS.append` encode b - l = - length . - T.words . fromRight (error "Could not decode mnemonic senttence") $ - toMnemonic bs - -toMnemonic160 :: (Word32, Word64, Word64) -> Bool -toMnemonic160 (a, b, c) = l == 15 - where - bs = BS.concat [encode a, encode b, encode c] - l = - length . - T.words . fromRight (error "Could not decode mnemonic sentence") $ - toMnemonic bs - -toMnemonic256 :: (Word64, Word64, Word64, Word64) -> Bool -toMnemonic256 (a, b, c, d) = l == 24 - where - bs = BS.concat [encode a, encode b, encode c, encode d] - l = - length . - T.words . fromRight (error "Could not decode mnemonic sentence") $ - toMnemonic bs - -toMnemonic512 :: - ((Word64, Word64, Word64, Word64), (Word64, Word64, Word64, Word64)) -> Bool -toMnemonic512 ((a, b, c, d), (e, f, g, h)) = l == 48 - where - bs = - BS.concat - [ encode a - , encode b - , encode c - , encode d - , encode e - , encode f - , encode g - , encode h - ] - l = - length . - T.words . fromRight (error "Could not decode mnemonic sentence") $ - toMnemonic bs - -toMnemonicVar :: [Word32] -> Property -toMnemonicVar ls = not (null ls) && length ls <= 8 ==> l == wc - where - bs = binWordsToBS ls - bl = BS.length bs - cb = bl `div` 4 - wc = (cb + bl * 8) `div` 11 - l = - length . T.words . - fromRight (error "Could not decode mnemonic sentence") $ - toMnemonic bs - -{- Encode/Decode -} - -fromToMnemonic128 :: (Word64, Word64) -> Bool -fromToMnemonic128 (a, b) = bs == bs' - where - bs = encode a `BS.append` encode b - bs' = - fromRight - (error "Could not decode mnemonic entropy") - (fromMnemonic =<< toMnemonic bs) - -fromToMnemonic160 :: (Word32, Word64, Word64) -> Bool -fromToMnemonic160 (a, b, c) = bs == bs' - where - bs = BS.concat [encode a, encode b, encode c] - bs' = - fromRight - (error "Could not decode mnemonic entropy") - (fromMnemonic =<< toMnemonic bs) - -fromToMnemonic256 :: (Word64, Word64, Word64, Word64) -> Bool -fromToMnemonic256 (a, b, c, d) = bs == bs' - where - bs = BS.concat [encode a, encode b, encode c, encode d] - bs' = - fromRight - (error "Could not decode mnemonic entropy") - (fromMnemonic =<< toMnemonic bs) - -fromToMnemonic512 :: - ((Word64, Word64, Word64, Word64), (Word64, Word64, Word64, Word64)) -> Bool -fromToMnemonic512 ((a, b, c, d), (e, f, g, h)) = bs == bs' - where - bs = - BS.concat - [ encode a - , encode b - , encode c - , encode d - , encode e - , encode f - , encode g - , encode h - ] - bs' = - fromRight - (error "Could not decode mnemonic entropy") - (fromMnemonic =<< toMnemonic bs) - -fromToMnemonicVar :: [Word32] -> Property -fromToMnemonicVar ls = not (null ls) && length ls <= 8 ==> bs == bs' - where - bs = binWordsToBS ls - bs' = - fromRight - (error "Could not decode mnemonic entropy") - (fromMnemonic =<< toMnemonic bs) - -{- Mnemonic to seed -} - -mnemonicToSeed128 :: (Word64, Word64) -> Bool -mnemonicToSeed128 (a, b) = l == 64 - where - bs = encode a `BS.append` encode b - seed = - fromRight - (error "Could not decode mnemonic seed") - (mnemonicToSeed "" =<< toMnemonic bs) - l = BS.length seed - -mnemonicToSeed160 :: (Word32, Word64, Word64) -> Bool -mnemonicToSeed160 (a, b, c) = l == 64 - where - bs = BS.concat [encode a, encode b, encode c] - seed = - fromRight - (error "Could not decode mnemonic seed") - (mnemonicToSeed "" =<< toMnemonic bs) - l = BS.length seed - -mnemonicToSeed256 :: (Word64, Word64, Word64, Word64) -> Bool -mnemonicToSeed256 (a, b, c, d) = l == 64 - where - bs = BS.concat [encode a, encode b, encode c, encode d] - seed = - fromRight - (error "Could not decode mnemonic seed") - (mnemonicToSeed "" =<< toMnemonic bs) - l = BS.length seed - -mnemonicToSeed512 :: - ((Word64, Word64, Word64, Word64), (Word64, Word64, Word64, Word64)) -> Bool -mnemonicToSeed512 ((a, b, c, d), (e, f, g, h)) = l == 64 - where - bs = - BS.concat - [ encode a - , encode b - , encode c - , encode d - , encode e - , encode f - , encode g - , encode h - ] - seed = - fromRight - (error "Could not decode mnemonic seed") - (mnemonicToSeed "" =<< toMnemonic bs) - l = BS.length seed - -mnemonicToSeedVar :: [Word32] -> Property -mnemonicToSeedVar ls = not (null ls) && length ls <= 16 ==> l == 64 - where - bs = binWordsToBS ls - seed = - fromRight - (error "Could not decode mnemonic seed") - (mnemonicToSeed "" =<< toMnemonic bs) - l = BS.length seed - -{- Get bits from ByteString -} - -data ByteCountGen = ByteCountGen BS.ByteString Int deriving Show - -instance Arbitrary ByteCountGen where - arbitrary = do - bs <- arbitraryBS - i <- choose (0, BS.length bs * 8) - return $ ByteCountGen bs i - -getBitsByteCount :: ByteCountGen -> Bool -getBitsByteCount (ByteCountGen bs i) = BS.length bits == l - where - (q, r) = i `quotRem` 8 - bits = getBits i bs - l = if r == 0 then q else q + 1 - -getBitsEndBits :: ByteCountGen -> Bool -getBitsEndBits (ByteCountGen bs i) = - (r == 0) || (BS.last bits .&. (0xff `shiftR` r) == 0x00) - where - r = i `mod` 8 - bits = getBits i bs diff --git a/test/Network/Haskoin/KeysSpec.hs b/test/Network/Haskoin/KeysSpec.hs deleted file mode 100644 --- a/test/Network/Haskoin/KeysSpec.hs +++ /dev/null @@ -1,72 +0,0 @@ -module Network.Haskoin.KeysSpec (spec) where - -import Data.Aeson as A -import qualified Data.ByteString as BS -import Data.Map.Strict (singleton) -import Data.Serialize as S -import Data.String (fromString) -import Data.String.Conversions (cs) -import Network.Haskoin.Address -import Network.Haskoin.Constants -import Network.Haskoin.Crypto -import Network.Haskoin.Keys -import Network.Haskoin.Test -import Network.Haskoin.Util -import Test.Hspec -import Test.QuickCheck - -spec :: Spec -spec = - describe "keys" $ do - let net = btc - it "is public key canonical" $ - property $ forAll arbitraryKeyPair (isCanonicalPubKey . snd) - it "encode and decode wif private keys" $ - property $ - forAll arbitraryKeyPair $ \(pk, _) -> - fromWif net (toWif net pk) == Just pk - it "encode and decode serialized private key" $ - property $ forAll arbitrary binaryPrvKey - it "read and show public key" $ - property $ forAll arbitraryKeyPair $ \(_, k) -> read (show k) == k - it "read and show private key" $ - property $ forAll arbitrarySecKeyI $ \k -> read (show k) == k - it "from string public key" $ - property $ - forAll arbitraryKeyPair $ \(_, k) -> - fromString (cs . encodeHex $ S.encode k) == k - it "encode and decode json public key" $ - property $ forAll arbitraryKeyPair (testID . snd) - it "encodes and decodes serialized public key" $ - property $ forAll arbitraryKeyPair $ cerealID . snd - - --- github.com/bitcoin/bitcoin/blob/master/src/script.cpp --- from function IsCanonicalPubKey -isCanonicalPubKey :: PubKeyI -> Bool -isCanonicalPubKey p = not $ - -- Non-canonical public key: too short - (BS.length bs < 33) || - -- Non-canonical public key: invalid length for uncompressed key - (BS.index bs 0 == 4 && BS.length bs /= 65) || - -- Non-canonical public key: invalid length for compressed key - (BS.index bs 0 `elem` [2,3] && BS.length bs /= 33) || - -- Non-canonical public key: compressed nor uncompressed - (BS.index bs 0 `notElem` [2,3,4]) - where - bs = S.encode p - -{- Key formats -} - -binaryPrvKey :: SecKey -> Bool -binaryPrvKey k = - Right k == runGet secKeyGet (runPut (secKeyPut k)) && - Just k == secKey (getSecKey k) - -testID :: (FromJSON a, ToJSON a, Eq a) => a -> Bool -testID x = - (A.decode . A.encode) (singleton ("object" :: String) x) == - Just (singleton ("object" :: String) x) - -cerealID :: (Serialize a, Eq a) => a -> Bool -cerealID x = S.decode (S.encode x) == Right x diff --git a/test/Network/Haskoin/NetworkSpec.hs b/test/Network/Haskoin/NetworkSpec.hs deleted file mode 100644 --- a/test/Network/Haskoin/NetworkSpec.hs +++ /dev/null @@ -1,187 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Network.Haskoin.NetworkSpec (spec) where - -import Data.Maybe (fromJust) -import Data.Serialize as S -import Data.Text (Text) -import Data.Word (Word32) -import Network.Haskoin.Address -import Network.Haskoin.Constants -import Network.Haskoin.Keys -import Network.Haskoin.Network -import Network.Haskoin.Test -import Network.Haskoin.Transaction -import Network.Haskoin.Util -import Test.Hspec -import Test.HUnit (Assertion, assertBool, - assertEqual) -import Test.QuickCheck - -spec :: Spec -spec = do - let net = btc - describe "bloom filters" $ do - it "bloom filter vector 1" bloomFilter1 - it "bloom filter vector 2" bloomFilter2 - it "bloom filter vector 3" bloomFilter3 - describe "relevant bloom filter update" $ do - it "Relevant Update" relevantOutputUpdated - it "Irrelevant Update" irrelevantOutputNotUpdated - describe "serialization of protocol types" $ do - it "encodes and decodes varint" $ - property $ forAll arbitraryVarInt cerealID - it "encodes and decodes varstring" $ - property $ forAll arbitraryVarString cerealID - it "encodes and decodes network address" $ - property $ forAll arbitraryNetworkAddress cerealID - it "encodes and decodes invtype" $ - property $ forAll arbitraryInvType cerealID - it "encodes and decodes invvector" $ - property $ forAll arbitraryInvVector cerealID - it "encodes and decodes inv" $ property $ forAll arbitraryInv1 cerealID - it "encodes and decodes version" $ - property $ forAll arbitraryVersion cerealID - it "encodes and decodes addr" $ property $ forAll arbitraryAddr1 cerealID - it "encodes and decodes alert" $ property $ forAll arbitraryAlert cerealID - it "encodes and decodes reject" $ - property $ forAll arbitraryReject cerealID - it "encodes and decodes getdata" $ - property $ forAll arbitraryGetData cerealID - it "encodes and decodes notfound" $ - property $ forAll arbitraryNotFound cerealID - it "encodes and decodes ping" $ property $ forAll arbitraryPing cerealID - it "encodes and decodes pong" $ property $ forAll arbitraryPong cerealID - it "encodes and decodes message command" $ - property $ forAll arbitraryMessageCommand cerealID - it "encodes and decodes message header" $ - property $ forAll arbitraryMessageHeader cerealID - it "encodes and decodes message" $ - property $ - forAll (arbitraryMessage net) $ - testPutGet (getMessage net) (putMessage net) - describe "serialization of bloom types" $ do - it "encodes and decodes bloom flags" $ - property $ forAll arbitraryBloomFlags cerealID - it "encodes and decodes bloom filter" $ - property $ forAll arbitraryBloomFilter $ cerealID . lst3 - it "encodes and decodes filterload" $ - property $ forAll arbitraryFilterLoad cerealID - it "encodes and decodes filteradd" $ - property $ forAll arbitraryFilterAdd cerealID - -bloomFilter :: Word32 -> Text -> Assertion -bloomFilter n x = do - assertBool "Bloom filter doesn't contain vector 1" $ bloomContains f1 v1 - assertBool "Bloom filter contains something it should not" $ - not $ bloomContains f1 v2 - assertBool "Bloom filter doesn't contain vector 3" $ bloomContains f3 v3 - assertBool "Bloom filter doesn't contain vector 4" $ bloomContains f4 v4 - assertBool "Bloom filter serialization is incorrect" $ - S.encode f4 == bs - where - f0 = bloomCreate 3 0.01 n BloomUpdateAll - f1 = bloomInsert f0 v1 - f3 = bloomInsert f1 v3 - f4 = bloomInsert f3 v4 - v1 = fromJust $ decodeHex "99108ad8ed9bb6274d3980bab5a85c048f0950c8" - v2 = fromJust $ decodeHex "19108ad8ed9bb6274d3980bab5a85c048f0950c8" - v3 = fromJust $ decodeHex "b5a2c786d9ef4658287ced5914b37a1b4aa32eee" - 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" $ - S.encode f2 == bs - where - f0 = bloomCreate 2 0.001 0 BloomUpdateAll - f1 = bloomInsert f0 $ S.encode p - f2 = bloomInsert f1 $ S.encode $ getAddrHash160 $ pubKeyAddr p - k = fromJust $ fromWif btc "5Kg1gnAjaLfKiwhhPpGS3QfRg2m6awQvaj98JCZBZQ5SuS2F15C" - p = derivePubKeyI k - bs = fromJust $ decodeHex "038fc16b080000000000000001" - -cerealID :: (Serialize a, Eq a) => a -> Bool -cerealID x = S.decode (S.encode x) == Right x - -testPutGet :: Eq a => Get a -> Putter a -> a -> Bool -testPutGet g p a = runGet g (runPut (p a)) == Right a - -relevantOutputUpdated :: Assertion -relevantOutputUpdated = assertBool "Bloom filter output updated" $ - any (bloomContains bf2) spendTxInput - where - bf0 = bloomCreate 10 0.000001 0 BloomUpdateAll - relevantOutputHash = fromJust $ decodeHex"03f47604ea2736334151081e13265b4fe38e6fa8" - bf1 = bloomInsert bf0 relevantOutputHash - bf2 = fromJust $ bloomRelevantUpdate bf1 relevantTx - spendTxInput = (encode .prevOutput) <$> txIn spendRelevantTx - -irrelevantOutputNotUpdated :: Assertion -irrelevantOutputNotUpdated = assertEqual "Bloom filter not updated" Nothing bf2 - where - bf0 = bloomCreate 10 0.000001 0 BloomUpdateAll - relevantOutputHash = fromJust $ decodeHex"03f47604ea2736334151081e13265b4fe38e6fa8" - bf1 = bloomInsert bf0 relevantOutputHash - bf2 = bloomRelevantUpdate bf1 unrelatedTx - spendTxInput = (encode .prevOutput) <$> txIn spendRelevantTx - --- Random transaction (57dc904f32ad4daab7b321dd469e8791ad09df784cdd273a73985150a4f225e9) -relevantTx :: Tx -relevantTx = Tx - { txVersion = 1 - , txIn = [ TxIn - { prevOutput = OutPoint "35fe9017b7e3af592920b56fa06ac02faf0c52cdb19dcb416129ac71c95d060e" 1 - , scriptInput = fromJust $ decodeHex "473044022032fc8eef299b7e94b9a986a6aa2dcb9733ab804bef80df995e443b9c1f8c604202203335df7a2e2b4789451cdb4b2b05a786a81c51519eb6a567fd6fe8cd7b2d33fe014104272502dc63a512dad1473cb82a71be9baf4f4303abd1ff6028fc8a78e1f3aec1218907119dec14f07354850758ff0948e88a904fa411c4df7d5444414ec64ad6" - , txInSequence = 4294967295 - } ] - , txOut = - [ TxOut { outValue = 100000000, scriptOutput = fromJust $ decodeHex "76a91403f47604ea2736334151081e13265b4fe38e6fa888ac" } - , TxOut { outValue = 107980000, scriptOutput = fromJust $ decodeHex "76a91481cc186a2f4a69f633ed4bf10ef4a78be13effdd88ac" } - ] - , txWitness = [] - , txLockTime = 0 - } - --- Transaction that spends above (fd6e3b693b844aa431fad46765c1aa019a6b13aebfa9dae916b3ffa43283a300) -spendRelevantTx :: Tx -spendRelevantTx = Tx - { txVersion = 1 - , txIn = [ TxIn - { prevOutput = OutPoint "57dc904f32ad4daab7b321dd469e8791ad09df784cdd273a73985150a4f225e9" 0 - , scriptInput = fromJust $ decodeHex "483045022100ecc334821e4e94cc2fdc841d5ad147d5bb942b993ba81460cc446e0410afa811022015fcbc542b734dbb61a05ec06012095096de5839c50808fe56f2b315e877c20d012103fb64e5792fa586172339b776b7017d3d529358cb73be6406a1fc994228d14f88" - , txInSequence = 4294967295 - }, TxIn - { prevOutput = OutPoint "cfee6a8d6e68e8fd16df6fff010afffcd19d7e075aa7b707dd1bae6adc420042" 0 - , scriptInput = fromJust $ decodeHex "47304402200e6bb95fa606f254d17089d83c4ceeb19c5d1699b4faddcd4f1f1568286e6b650220087fb8439f31e1b30e47710d095422405f601d6151f2f93e125e1a08a6e29ad4012103b49252e8fc6d5b49c8d14ee71fab45591df4a126a6c453c724f3d356e38f0cee" - , txInSequence = 4294967295 - } ] - , txOut = - [ TxOut { outValue = 3851100, scriptOutput = fromJust $ decodeHex "76a914a297cae82a9a3b932bf023ae274fe2585295c9ca88ac" } - , TxOut { outValue = 111000000, scriptOutput = fromJust $ decodeHex "76a9148f952c38600a61385974acc30a64f74407f9801488ac" } - ] - , txWitness = [] - , txLockTime = 0 - } - --- This random transaction is unrelated to the others -unrelatedTx :: Tx -unrelatedTx = Tx - { txVersion = 1 - , txIn = [ TxIn - { prevOutput = OutPoint "3ec3a71431c68e5d978a5fb4a0a1081d8bee8384d8aa4c06b1fbaf9413e2214f" 20 - , scriptInput = fromJust $ decodeHex "483045022100ec9c202c9d3140b973aca9d7f21a82138aa4cfa43fddc5419098ac5e26a6f152022010848fd688f290ae010fb5cb493410caa03145fc12445900ec1ad2bde33aecd9012102c7445e72d723f99a0064526c28269d07f47c8fd81531a94a8d3bf5ebd5e23ef1" - , txInSequence = 4294967295 - }] - , txOut = - [ TxOut { outValue = 12600000, scriptOutput = fromJust $ decodeHex "76a9148fef3b7051de8cc44e966159e7ea37f4520187e888ac" } - ] - , txWitness = [] - , txLockTime = 0 - } diff --git a/test/Network/Haskoin/ScriptSpec.hs b/test/Network/Haskoin/ScriptSpec.hs deleted file mode 100644 --- a/test/Network/Haskoin/ScriptSpec.hs +++ /dev/null @@ -1,406 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Network.Haskoin.ScriptSpec (spec) where - -import Control.Monad -import Data.Aeson as A -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.Either -import Data.List -import Data.Map.Strict (singleton) -import Data.Maybe -import Data.Monoid ((<>)) -import Data.Serialize as S -import Data.String -import Data.String.Conversions (cs) -import Data.Text (Text) -import Data.Word -import Network.Haskoin.Address -import Network.Haskoin.Constants -import Network.Haskoin.Keys -import Network.Haskoin.Script -import Network.Haskoin.Test -import Network.Haskoin.Transaction -import Network.Haskoin.Util -import Test.Hspec -import Test.HUnit as HUnit -import Test.QuickCheck -import Text.Read - -spec :: Spec -spec = do - let net = btc - describe "btc scripts" $ props btc - describe "bch scripts" $ props bch - describe "multi signatures" $ - zipWithM_ (curry mapMulSigVector) mulSigVectors [0 ..] - describe "signature decoding" $ - zipWithM_ (curry (sigDecodeMap net)) scriptSigSignatures [0 ..] - describe "json serialization" $ do - it "encodes and decodes script output" $ - forAll (arbitraryScriptOutput net) testID - it "encodes and decodes outpoint" $ forAll arbitraryOutPoint testID - it "encodes and decodes sighash" $ forAll arbitrarySigHash testID - it "encodes and decodes siginput" $ - forAll (arbitrarySigInput net) (testID . fst) - describe "script serialization" $ do - it "encodes and decodes script op" $ - property $ forAll arbitraryScriptOp cerealID - it "encodes and decodes script" $ - property $ forAll arbitraryScript cerealID - -props :: Network -> Spec -props net = do - standardSpec net - strictSigSpec net - scriptSpec net - txSigHashForkIdSpec net - forkIdScriptSpec net - sigHashSpec net - txSigHashSpec net - -cerealID :: (Serialize a, Eq a) => a -> Bool -cerealID x = S.decode (S.encode x) == Right x - -standardSpec :: Network -> Spec -standardSpec net = do - it "has intToScriptOp . scriptOpToInt identity" $ - property $ - forAll arbitraryIntScriptOp $ \i -> - intToScriptOp <$> scriptOpToInt i `shouldBe` Right i - it "has decodeOutput . encodeOutput identity" $ - property $ - forAll (arbitraryScriptOutput net) $ \so -> - decodeOutput (encodeOutput so) `shouldBe` Right so - it "has decodeInput . encodeOutput identity" $ - property $ - forAll (arbitraryScriptInput net) $ \si -> - decodeInput net (encodeInput si) `shouldBe` Right si - it "can sort multisig scripts" $ - forAll arbitraryMSOutput $ \out -> - map S.encode (getOutputMulSigKeys (sortMulSig out)) `shouldSatisfy` \xs -> - xs == sort xs - it "can decode inputs with empty signatures" $ do - decodeInput net (Script [OP_0]) `shouldBe` - Right (RegularInput (SpendPK TxSignatureEmpty)) - decodeInput net (Script [opPushData ""]) `shouldBe` - Right (RegularInput (SpendPK TxSignatureEmpty)) - let pk = - derivePubKeyI $ - wrapSecKey True $ fromJust $ secKey $ B.replicate 32 1 - decodeInput net (Script [OP_0, opPushData $ S.encode pk]) `shouldBe` - Right (RegularInput (SpendPKHash TxSignatureEmpty pk)) - decodeInput net (Script [OP_0, OP_0]) `shouldBe` - Right (RegularInput (SpendMulSig [TxSignatureEmpty])) - decodeInput net (Script [OP_0, OP_0, OP_0, OP_0]) `shouldBe` - Right (RegularInput (SpendMulSig $ replicate 3 TxSignatureEmpty)) - -scriptSpec :: Network -> Spec -scriptSpec net = - when (getNetworkName net == "btc") $ - it "can verify standard scripts from script_tests.json file" $ do - xs <- readTestFile "script_tests" :: IO [A.Value] - let vectorsA = - mapMaybe (A.decode . A.encode) xs :: [( String - , String - , String - , String - , String)] - vectorsB = - mapMaybe (A.decode . A.encode) xs :: [( [Word64] - , String - , String - , String - , String - , String)] - vectors = - map (\(a, b, c, d, e) -> ([0], a, b, c, d, e)) vectorsA <> - vectorsB - length vectors `shouldBe` 86 - forM_ vectors $ \([val], siStr, soStr, flags, res, desc) - -- We can disable specific tests by adding a DISABLED flag in the data - -> - unless ("DISABLED" `isInfixOf` flags) $ do - let _strict = - "DERSIG" `isInfixOf` flags || - "STRICTENC" `isInfixOf` flags || - "NULLDUMMY" `isInfixOf` flags - scriptSig = parseScript siStr - scriptPubKey = parseScript soStr - decodedOutput = decodeOutputBS scriptPubKey - ver = either (const False) $ \so -> - verifyStdInput - net - (spendTx scriptPubKey 0 scriptSig) - 0 - so - (val * 100000000) - case res of - "OK" -> assertBool desc $ ver decodedOutput - _ -> assertBool desc (not $ ver decodedOutput) - -forkIdScriptSpec :: Network -> Spec -forkIdScriptSpec net = - when (isJust (getSigHashForkId net)) $ - it "can verify scripts from forkid_script_tests.json file" $ do - xs <- readTestFile "forkid_script_tests" :: 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 = - Tx 1 [txI] [txO] [] 0 - where - txO = TxOut {outValue = val, scriptOutput = scriptPubKey} - txI = - TxIn - { prevOutput = nullOutPoint - , scriptInput = S.encode $ Script [OP_0, OP_0] - , txInSequence = maxBound - } - -spendTx :: ByteString -> Word64 -> ByteString -> Tx -spendTx scriptPubKey val scriptSig = - Tx 1 [txI] [txO] [] 0 - where - txO = TxOut {outValue = val, scriptOutput = B.empty} - txI = - TxIn - { prevOutput = OutPoint (txHash $ creditTx scriptPubKey val) 0 - , scriptInput = scriptSig - , txInSequence = maxBound - } - -parseScript :: String -> ByteString -parseScript str = - B.concat $ fromMaybe err $ mapM f $ words str - where - f = decodeHex . cs . dropHex . replaceToken - dropHex ('0':'x':xs) = xs - 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 $ S.encode (opcode :: ScriptOp)) - _ -> str - -strictSigSpec :: Network -> Spec -strictSigSpec net = - when (getNetworkName net == "btc") $ do - it "can decode strict signatures" $ do - xs <- readTestFile "sig_strict" - let vectors = mapMaybe decodeHex xs - length vectors `shouldBe` 3 - forM_ vectors $ \sig -> - decodeTxSig net sig `shouldSatisfy` isRight - it "can detect non-strict signatures" $ do - xs <- readTestFile "sig_nonstrict" - let vectors = mapMaybe decodeHex xs - length vectors `shouldBe` 17 - forM_ vectors $ \sig -> - decodeTxSig net sig `shouldSatisfy` isLeft - -txSigHashSpec :: Network -> Spec -txSigHashSpec net = - when (getNetworkName net == "btc") $ - it "can produce valid sighashes from sighash.json test vectors" $ do - xs <- readTestFile "sighash" :: IO [A.Value] - let vectors = - mapMaybe (A.decode . A.encode) xs :: [( String - , String - , Int - , Integer - , String)] - length vectors `shouldBe` 500 - forM_ vectors $ \(txStr, scpStr, i, shI, resStr) -> do - let tx = fromString txStr - s = - fromMaybe (error $ "Could not decode script: " <> cs scpStr) $ - eitherToMaybe . S.decode =<< decodeHex (cs scpStr) - sh = fromIntegral shI - res = - eitherToMaybe . S.decode . B.reverse =<< - decodeHex (cs resStr) - Just (txSigHash net tx s 0 i sh) `shouldBe` res - -txSigHashForkIdSpec :: Network -> Spec -txSigHashForkIdSpec net = - when (getNetworkName net == "btc") $ - it "can produce valid sighashes from forkid_sighash.json test vectors" $ do - xs <- readTestFile "forkid_sighash" :: 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 . S.decode =<< decodeHex (cs scpStr) - sh = fromIntegral shI - res = eitherToMaybe . S.decode =<< decodeHex (cs resStr) - Just (txSigHashForkId net tx s val i sh) `shouldBe` res - -sigHashSpec :: Network -> Spec -sigHashSpec net = do - it "can read . show" $ - property $ forAll arbitrarySigHash $ \sh -> read (show sh) `shouldBe` sh - it "can correctly show" $ do - show (0x00 :: SigHash) `shouldBe` "SigHash " <> show (0x00 :: Word32) - show (0x01 :: SigHash) `shouldBe` "SigHash " <> show (0x01 :: Word32) - show (0xff :: SigHash) `shouldBe` "SigHash " <> show (0xff :: Word32) - show (0xabac3344 :: SigHash) `shouldBe` "SigHash " <> - show (0xabac3344 :: Word32) - it "can add a forkid" $ do - 0x00 `sigHashAddForkId` 0x00 `shouldBe` 0x00 - 0xff `sigHashAddForkId` 0x00ffffff `shouldBe` 0xffffffff - 0xffff `sigHashAddForkId` 0x00aaaaaa `shouldBe` 0xaaaaaaff - 0xffff `sigHashAddForkId` 0xaaaaaaaa `shouldBe` 0xaaaaaaff - 0xffff `sigHashAddForkId` 0x00004444 `shouldBe` 0x004444ff - 0xff01 `sigHashAddForkId` 0x44440000 `shouldBe` 0x44000001 - 0xff03 `sigHashAddForkId` 0x00550000 `shouldBe` 0x55000003 - it "can extract a forkid" $ do - sigHashGetForkId 0x00000000 `shouldBe` 0x00000000 - sigHashGetForkId 0x80000000 `shouldBe` 0x00800000 - sigHashGetForkId 0xffffffff `shouldBe` 0x00ffffff - sigHashGetForkId 0xabac3403 `shouldBe` 0x00abac34 - it "can build some vectors" $ do - sigHashAll `shouldBe` 0x01 - sigHashNone `shouldBe` 0x02 - sigHashSingle `shouldBe` 0x03 - setForkIdFlag sigHashAll `shouldBe` 0x41 - setAnyoneCanPayFlag sigHashAll `shouldBe` 0x81 - setAnyoneCanPayFlag (setForkIdFlag sigHashAll) `shouldBe` 0xc1 - it "can test flags" $ do - hasForkIdFlag sigHashAll `shouldBe` False - hasForkIdFlag (setForkIdFlag sigHashAll) `shouldBe` True - hasAnyoneCanPayFlag sigHashAll `shouldBe` False - hasAnyoneCanPayFlag (setAnyoneCanPayFlag sigHashAll) `shouldBe` True - isSigHashAll sigHashNone `shouldBe` False - isSigHashAll sigHashAll `shouldBe` True - isSigHashNone sigHashSingle `shouldBe` False - isSigHashNone sigHashNone `shouldBe` True - isSigHashSingle sigHashAll `shouldBe` False - isSigHashSingle sigHashSingle `shouldBe` True - isSigHashUnknown sigHashAll `shouldBe` False - isSigHashUnknown sigHashNone `shouldBe` False - isSigHashUnknown sigHashSingle `shouldBe` False - isSigHashUnknown 0x00 `shouldBe` True - isSigHashUnknown 0x04 `shouldBe` True - it "can decodeTxSig . encode a TxSignature" $ - property $ - forAll (arbitraryTxSignature net) $ \(_, _, ts) -> - decodeTxSig net (encodeTxSig ts) `shouldBe` Right ts - it "can produce the sighash one" $ - property $ - forAll (arbitraryTx net) $ forAll arbitraryScript . testSigHashOne net - -testSigHashOne :: Network -> Tx -> Script -> Word64 -> Bool -> Property -testSigHashOne net tx s val acp = - not (null $ txIn tx) ==> - if length (txIn tx) > length (txOut tx) - then res `shouldBe` one - else res `shouldNotBe` one - where - res = txSigHash net tx s val (length (txIn tx) - 1) (f sigHashSingle) - one = "0100000000000000000000000000000000000000000000000000000000000000" - f = - if acp - then setAnyoneCanPayFlag - else id - -{-- Test Utilities --} - -readTestFile :: A.FromJSON a => FilePath -> IO a -readTestFile fp = do - bs <- L.readFile $ "data/" <> fp <> ".json" - maybe (error $ "Could not read test file " <> fp) return $ A.decode bs - -{- Parse tests from bitcoin-qt repository -} - -mapMulSigVector :: ((Text, Text), Int) -> Spec -mapMulSigVector (v, i) = - it name $ runMulSigVector v - where - name = "check multisig vector " <> show i - -runMulSigVector :: (Text, Text) -> Assertion -runMulSigVector (a, ops) = assertBool "multisig vector" $ Just a == b - where - s = do - s' <- decodeHex ops - eitherToMaybe $ S.decode s' - b = do - o <- s - d <- eitherToMaybe $ decodeOutput o - addrToString 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 - eitherSig = decodeTxSig net bs - in assertBool - (unwords - [ "Decode failed:" - , fromLeft (error "Decode did not fail") eitherSig - ]) $ - isRight eitherSig - -mulSigVectors :: [(Text, Text)] -mulSigVectors = - [ ( "3QJmV3qfvL9SuYo34YihAf3sRCW3qSinyC" - , "52410491bba2510912a5bd37da1fb5b1673010e43d2c6d812c514e91bfa9f2eb129e1c183329db55bd868e209aac2fbc02cb33d98fe74bf23f0c235d6126b1d8334f864104865c40293a680cb9c020e7b1e106d8c1916d3cef99aa431a56d253e69256dac09ef122b1a986818a7cb624532f062c1d1f8722084861c5c3291ccffef4ec687441048d2455d2403e08708fc1f556002f1b6cd83f992d085097f9974ab08a28838f07896fbab08f39495e15fa6fad6edbfb1e754e35fa1c7844c41f322a1863d4621353ae" - ) - ] - -scriptSigSignatures :: [Text] -scriptSigSignatures = - -- Signature in input of txid 1983a69265920c24f89aac81942b1a59f7eb30821a8b3fb258f88882b6336053 - [ "304402205ca6249f43538908151fe67b26d020306c0e59fa206cf9f3ccf641f33357119d02206c82f244d04ac0a48024fb9cc246b66e58598acf206139bdb7b75a2941a2b1e401" - -- Signature in input of txid - -- fb0a1d8d34fa5537e461ac384bac761125e1bfa7fec286fa72511240fa66864d. - -- Strange DER sizes, but in Blockchain. Now invalid as Haskoin can only - -- decode strict signatures. - -- "3048022200002b83d59c1d23c08efd82ee0662fec23309c3adbcbd1f0b8695378db4b14e736602220000334a96676e58b1bb01784cb7c556dd8ce1c220171904da22e18fe1e7d1510db501" - ] - - -testID :: (FromJSON a, ToJSON a, Eq a) => a -> Bool -testID x = - (A.decode . A.encode) (singleton ("object" :: String) x) == - Just (singleton ("object" :: String) x) diff --git a/test/Network/Haskoin/Test.hs b/test/Network/Haskoin/Test.hs deleted file mode 100644 --- a/test/Network/Haskoin/Test.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-| -Module : Network.Haskoin.Test -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Arbitrary instances for testing. --} -module Network.Haskoin.Test - ( module X - ) where - -import Network.Haskoin.Test.Address as X -import Network.Haskoin.Test.Block as X -import Network.Haskoin.Test.Crypto as X -import Network.Haskoin.Test.Keys as X -import Network.Haskoin.Test.Message as X -import Network.Haskoin.Test.Network as X -import Network.Haskoin.Test.Script as X -import Network.Haskoin.Test.Transaction as X -import Network.Haskoin.Test.Util as X diff --git a/test/Network/Haskoin/Test/Address.hs b/test/Network/Haskoin/Test/Address.hs deleted file mode 100644 --- a/test/Network/Haskoin/Test/Address.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-| -Module : Network.Haskoin.Test.Address -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} -module Network.Haskoin.Test.Address where - -import Network.Haskoin.Address -import Network.Haskoin.Test.Crypto -import Test.QuickCheck - --- | Arbitrary pay-to-public-key-hash or pay-to-script-hash address. -arbitraryAddress :: Gen Address -arbitraryAddress = oneof [arbitraryPubKeyAddress, arbitraryScriptAddress] - --- | Arbitrary pay-to-public-key-hash address. -arbitraryPubKeyAddress :: Gen Address -arbitraryPubKeyAddress = p2pkhAddr <$> arbitraryHash160 - --- | Arbitrary pay-to-script-hash address. -arbitraryScriptAddress :: Gen Address -arbitraryScriptAddress = p2shAddr <$> arbitraryHash160 diff --git a/test/Network/Haskoin/Test/Block.hs b/test/Network/Haskoin/Test/Block.hs deleted file mode 100644 --- a/test/Network/Haskoin/Test/Block.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-| -Module : Network.Haskoin.Test.Block -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} -module Network.Haskoin.Test.Block where - -import Network.Haskoin.Block.Merkle -import Network.Haskoin.Block.Common -import Network.Haskoin.Constants -import Network.Haskoin.Test.Crypto -import Network.Haskoin.Test.Network -import Network.Haskoin.Test.Transaction -import Test.QuickCheck - --- | Block full or arbitrary transactions. -arbitraryBlock :: Network -> Gen Block -arbitraryBlock net = do - h <- arbitraryBlockHeader - c <- choose (0,10) - txs <- vectorOf c (arbitraryTx net) - return $ Block h txs - --- | Block header with random hash. -arbitraryBlockHeader :: Gen BlockHeader -arbitraryBlockHeader = - BlockHeader <$> arbitrary - <*> arbitraryBlockHash - <*> arbitraryHash256 - <*> arbitrary - <*> arbitrary - <*> arbitrary - --- | Arbitrary block hash. -arbitraryBlockHash :: Gen BlockHash -arbitraryBlockHash = BlockHash <$> arbitraryHash256 - --- | Arbitrary 'GetBlocks' object with at least one block hash. -arbitraryGetBlocks :: Gen GetBlocks -arbitraryGetBlocks = - GetBlocks <$> arbitrary - <*> listOf1 arbitraryBlockHash - <*> arbitraryBlockHash - --- | Arbitrary 'GetHeaders' object with at least one block header. -arbitraryGetHeaders :: Gen GetHeaders -arbitraryGetHeaders = - GetHeaders <$> arbitrary - <*> 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 - bh <- arbitraryBlockHeader - ntx <- arbitrary - hashes <- listOf1 arbitraryHash256 - c <- choose (1,10) - flags <- vectorOf (c*8) arbitrary - return $ MerkleBlock bh ntx hashes flags - diff --git a/test/Network/Haskoin/Test/Crypto.hs b/test/Network/Haskoin/Test/Crypto.hs deleted file mode 100644 --- a/test/Network/Haskoin/Test/Crypto.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-| -Module : Network.Haskoin.Test.Crypto -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} -module Network.Haskoin.Test.Crypto where - -import Network.Haskoin.Crypto.Hash -import Network.Haskoin.Test.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 = - checkSum32 <$> arbitraryBSn 4 diff --git a/test/Network/Haskoin/Test/Keys.hs b/test/Network/Haskoin/Test/Keys.hs deleted file mode 100644 --- a/test/Network/Haskoin/Test/Keys.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-| -Module : Network.Haskoin.Test.Keys -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} -module Network.Haskoin.Test.Keys where - -import Data.Bits (clearBit) -import Data.List (foldl') -import Data.Word (Word32) -import Network.Haskoin.Crypto -import Network.Haskoin.Keys.Common -import Network.Haskoin.Keys.Extended -import Network.Haskoin.Test.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) - --- | Arbitrary extended private key. -arbitraryXPrvKey :: Gen XPrvKey -arbitraryXPrvKey = - XPrvKey <$> arbitrary - <*> arbitrary - <*> 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 = - oneof [ Bip32SoftIndex <$> genIndex - , 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. -arbitraryParsedPath :: Gen ParsedPath -arbitraryParsedPath = - oneof [ ParsedPrv <$> arbitraryDerivPath - , ParsedPub <$> arbitraryDerivPath - , ParsedEmpty <$> arbitraryDerivPath - ] - --- | Arbitrary message hash, private key, nonce and corresponding signature. The --- signature is generated with a random message, random private key and a random --- nonce. -arbitrarySignature :: Gen (Hash256, SecKey, Sig) -arbitrarySignature = do - m <- arbitraryHash256 - key <- arbitrary - let sig = signHash key m - return (m, key, sig) diff --git a/test/Network/Haskoin/Test/Message.hs b/test/Network/Haskoin/Test/Message.hs deleted file mode 100644 --- a/test/Network/Haskoin/Test/Message.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-| -Module : Network.Haskoin.Test.Message -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} -module Network.Haskoin.Test.Message where - -import Network.Haskoin.Constants -import Network.Haskoin.Network.Message -import Network.Haskoin.Test.Block -import Network.Haskoin.Test.Crypto -import Network.Haskoin.Test.Network -import Network.Haskoin.Test.Transaction -import Test.QuickCheck - --- | Arbitrary 'MessageHeader'. -arbitraryMessageHeader :: Gen MessageHeader -arbitraryMessageHeader = - MessageHeader <$> arbitrary - <*> arbitraryMessageCommand - <*> arbitrary - <*> arbitraryCheckSum32 - --- | Arbitrary 'Message'. -arbitraryMessage :: Network -> Gen Message -arbitraryMessage net = - oneof - [ MVersion <$> arbitraryVersion - , return MVerAck - , MAddr <$> arbitraryAddr1 - , MInv <$> arbitraryInv1 - , MGetData <$> arbitraryGetData - , MNotFound <$> arbitraryNotFound - , MGetBlocks <$> arbitraryGetBlocks - , MGetHeaders <$> arbitraryGetHeaders - , MTx <$> arbitraryTx net - , MBlock <$> arbitraryBlock net - , MMerkleBlock <$> arbitraryMerkleBlock - , MHeaders <$> arbitraryHeaders - , return MGetAddr - , MFilterLoad <$> arbitraryFilterLoad - , MFilterAdd <$> arbitraryFilterAdd - , return MFilterClear - , MPing <$> arbitraryPing - , MPong <$> arbitraryPong - , MAlert <$> arbitraryAlert - , MReject <$> arbitraryReject - , return MSendHeaders - ] diff --git a/test/Network/Haskoin/Test/Network.hs b/test/Network/Haskoin/Test/Network.hs deleted file mode 100644 --- a/test/Network/Haskoin/Test/Network.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-| -Module : Network.Haskoin.Test.Network -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} -module Network.Haskoin.Test.Network where - -import qualified Data.ByteString as BS (empty, pack) -import qualified Data.ByteString.Char8 as C8 -import Data.Word (Word16, Word32) -import Network.Haskoin.Network -import Network.Haskoin.Test.Crypto -import Network.Haskoin.Test.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 - s <- arbitrary - a <- arbitrary - p <- arbitrary - d <- oneof - [ do - b <- arbitrary - c <- arbitrary - d <- arbitrary - return $ SockAddrInet6 (fromIntegral p) 0 (a,b,c,d) 0 - , return $ SockAddrInet (fromIntegral (p :: Word16)) a - ] - let n = sockToHostAddress d - return $ NetworkAddress s n - --- | Arbitrary 'NetworkAddressTime'. -arbitraryNetworkAddressTime :: Gen (Word32, NetworkAddress) -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 - <*> arbitrary - <*> arbitrary - <*> arbitraryNetworkAddress - <*> arbitraryNetworkAddress - <*> arbitrary - <*> arbitraryVarString - <*> arbitrary - <*> arbitrary - --- | Arbitrary non-empty 'Addr'. -arbitraryAddr1 :: Gen Addr -arbitraryAddr1 = Addr <$> listOf1 arbitraryNetworkAddressTime - --- | Arbitrary 'Alert' with random payload and signature. Signature is not --- valid. -arbitraryAlert :: Gen Alert -arbitraryAlert = Alert <$> arbitraryVarString <*> arbitraryVarString - --- | Arbitrary 'Reject'. -arbitraryReject :: Gen Reject -arbitraryReject = do - m <- arbitraryMessageCommand - c <- arbitraryRejectCode - s <- arbitraryVarString - d <- oneof [ return BS.empty - , BS.pack <$> vectorOf 32 arbitrary - ] - return $ Reject m c s d - --- | Arbitrary 'RejectCode'. -arbitraryRejectCode :: Gen RejectCode -arbitraryRejectCode = - elements - [ RejectMalformed - , RejectInvalid - , RejectInvalid - , RejectDuplicate - , RejectNonStandard - , RejectDust - , RejectInsufficientFee - , 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 = - elements - [ BloomUpdateNone - , BloomUpdateAll - , BloomUpdateP2PubKeyOnly - ] - --- | Arbitrary bloom filter with its corresponding number of elements --- and false positive rate. -arbitraryBloomFilter :: Gen (Int, Double, BloomFilter) -arbitraryBloomFilter = do - n <- choose (0,100000) - fp <- choose (1e-8,1) - tweak <- arbitrary - fl <- arbitraryBloomFlags - return (n, fp, bloomCreate n fp tweak fl) - --- | 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 - ASCIIString str <- arbitrary - elements - [ MCVersion - , MCVerAck - , MCAddr - , MCInv - , MCGetData - , MCNotFound - , MCGetBlocks - , MCGetHeaders - , MCTx - , MCBlock - , MCMerkleBlock - , MCHeaders - , MCGetAddr - , MCFilterLoad - , MCFilterAdd - , MCFilterClear - , MCPing - , MCPong - , MCAlert - , MCOther (C8.take 12 (C8.pack (filter (/= '\NUL') str))) - ] diff --git a/test/Network/Haskoin/Test/Script.hs b/test/Network/Haskoin/Test/Script.hs deleted file mode 100644 --- a/test/Network/Haskoin/Test/Script.hs +++ /dev/null @@ -1,374 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-| -Module : Network.Haskoin.Test.Script -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} -module Network.Haskoin.Test.Script where - -import Crypto.Secp256k1 -import Data.Maybe -import Data.Word -import Network.Haskoin.Address -import Network.Haskoin.Constants -import Network.Haskoin.Keys.Common -import Network.Haskoin.Script -import Network.Haskoin.Test.Address -import Network.Haskoin.Test.Crypto -import Network.Haskoin.Test.Keys -import Network.Haskoin.Test.Util -import Network.Haskoin.Transaction.Common -import Network.Haskoin.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 = - oneof - -- Pushing Data - [ opPushData <$> arbitraryBS1 - , return OP_0 - , return OP_1NEGATE - , return OP_RESERVED - , return OP_1 - , return OP_2 - , return OP_3 - , return OP_4 - , return OP_5 - , return OP_6 - , return OP_7 - , return OP_8 - , return OP_9 - , return OP_10 - , return OP_11 - , return OP_12 - , return OP_13 - , return OP_14 - , return OP_15 - , return OP_16 - -- Flow control - , return OP_NOP - , return OP_VER - , return OP_IF - , return OP_NOTIF - , return OP_VERIF - , return OP_VERNOTIF - , return OP_ELSE - , return OP_ENDIF - , return OP_VERIFY - , return OP_RETURN - -- Stack operations - , return OP_TOALTSTACK - , return OP_FROMALTSTACK - , return OP_IFDUP - , return OP_DEPTH - , return OP_DROP - , return OP_DUP - , return OP_NIP - , return OP_OVER - , return OP_PICK - , return OP_ROLL - , return OP_ROT - , return OP_SWAP - , return OP_TUCK - , return OP_2DROP - , return OP_2DUP - , return OP_3DUP - , return OP_2OVER - , return OP_2ROT - , return OP_2SWAP - -- Splice - , return OP_CAT - , return OP_SUBSTR - , return OP_LEFT - , return OP_RIGHT - , return OP_SIZE - -- Bitwise logic - , return OP_INVERT - , return OP_AND - , return OP_OR - , return OP_XOR - , return OP_EQUAL - , return OP_EQUALVERIFY - , return OP_RESERVED1 - , return OP_RESERVED2 - -- Arithmetic - , return OP_1ADD - , return OP_1SUB - , return OP_2MUL - , return OP_2DIV - , return OP_NEGATE - , return OP_ABS - , return OP_NOT - , return OP_0NOTEQUAL - , return OP_ADD - , return OP_SUB - , return OP_MUL - , return OP_DIV - , return OP_MOD - , return OP_LSHIFT - , return OP_RSHIFT - , return OP_BOOLAND - , return OP_BOOLOR - , return OP_NUMEQUAL - , return OP_NUMEQUALVERIFY - , return OP_NUMNOTEQUAL - , return OP_LESSTHAN - , return OP_GREATERTHAN - , return OP_LESSTHANOREQUAL - , return OP_GREATERTHANOREQUAL - , return OP_MIN - , return OP_MAX - , return OP_WITHIN - -- Crypto - , return OP_RIPEMD160 - , return OP_SHA1 - , return OP_SHA256 - , return OP_HASH160 - , return OP_HASH256 - , return OP_CODESEPARATOR - , return OP_CHECKSIG - , return OP_CHECKSIGVERIFY - , return OP_CHECKMULTISIG - , return OP_CHECKMULTISIGVERIFY - -- Expansion - , return OP_NOP1 - , return OP_NOP2 - , return OP_NOP3 - , return OP_NOP4 - , return OP_NOP5 - , return OP_NOP6 - , return OP_NOP7 - , return OP_NOP8 - , return OP_NOP9 - , return OP_NOP10 - -- Other - , return OP_PUBKEYHASH - , return OP_PUBKEY - , return $ OP_INVALIDOPCODE 0xff - ] - --- | Arbtirary 'ScriptOp' with a value in @[OP_1 .. OP_16]@. -arbitraryIntScriptOp :: Gen ScriptOp -arbitraryIntScriptOp = - elements - [ OP_1, OP_2, OP_3, OP_4 - , OP_5, OP_6, OP_7, OP_8 - , OP_9, OP_10, OP_11, OP_12 - , OP_13, OP_14, OP_15, OP_16 - ] - --- | 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 - --- | Arbitrary message hash, private key and corresponding 'TxSignature'. The --- signature is generated deterministically using a random message and a random --- private key. -arbitraryTxSignature :: Network -> Gen (TxHash, SecKey, TxSignature) -arbitraryTxSignature net = do - (m, key, sig) <- arbitrarySignature - sh <- (fromIntegral <$> (arbitrary :: Gen Word8)) `suchThat` filterBad - let txsig = TxSignature sig sh - return (TxHash m, key, txsig) - where - filterBad sh = not $ - isSigHashUnknown sh || - isNothing (getSigHashForkId net) && hasForkIdFlag sh - --- | Arbitrary transaction signature that could also be empty. -arbitraryTxSignatureEmpty :: Network -> Gen TxSignature -arbitraryTxSignatureEmpty net = - frequency [ (1, return TxSignatureEmpty) - , (10, lst3 <$> arbitraryTxSignature net) - ] - --- | Arbitrary m of n parameters. -arbitraryMSParam :: Gen (Int, Int) -arbitraryMSParam = do - m <- choose (1,16) - n <- choose (m,16) - return (m, n) - --- | Arbitrary 'ScriptOutput' (Can by any valid type). -arbitraryScriptOutput :: Network -> Gen ScriptOutput -arbitraryScriptOutput net = - oneof $ - [ arbitraryPKOutput - , arbitraryPKHashOutput - , arbitraryMSOutput - , arbitrarySHOutput - , arbitraryDCOutput - ] ++ - if getSegWit net - then [arbitraryWPKHashOutput, arbitraryWSHOutput] - else [] - --- | Arbitrary 'ScriptOutput' of type 'PayPK', 'PayPKHash' or 'PayMS' --- (Not 'PayScriptHash', 'DataCarrier', or SegWit) -arbitrarySimpleOutput :: Gen ScriptOutput -arbitrarySimpleOutput = - oneof - [ arbitraryPKOutput - , arbitraryPKHashOutput - , arbitraryMSOutput - ] - --- | Arbitrary 'ScriptOutput' of type 'PayPK' -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 - --- | Arbitrary 'ScriptOutput' of type 'PayMS'. -arbitraryMSOutput :: Gen ScriptOutput -arbitraryMSOutput = do - (m, n) <- arbitraryMSParam - keys <- map snd <$> vectorOf n arbitraryKeyPair - return $ PayMulSig keys m - --- | Arbitrary 'ScriptOutput' of type 'PayMS', only using compressed keys. -arbitraryMSOutputC :: Gen ScriptOutput -arbitraryMSOutputC = do - (m, n) <- arbitraryMSParam - keys <- - map snd <$> - vectorOf n (arbitraryKeyPair `suchThat` (pubKeyCompressed . snd)) - return $ PayMulSig keys m - --- | 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 = - oneof - [ arbitraryPKInput net - , arbitraryPKHashInput net - , arbitraryMSInput net - , arbitrarySHInput net - ] - --- | Arbitrary 'ScriptInput' of type 'SpendPK', 'SpendPKHash' or 'SpendMulSig' --- (not 'ScriptHashInput') -arbitrarySimpleInput :: Network -> Gen ScriptInput -arbitrarySimpleInput net = - oneof - [ arbitraryPKInput net - , arbitraryPKHashInput net - , arbitraryMSInput net - ] - --- | Arbitrary 'ScriptInput' of type 'SpendPK'. -arbitraryPKInput :: Network -> Gen ScriptInput -arbitraryPKInput net = RegularInput . SpendPK <$> arbitraryTxSignatureEmpty net - --- | Arbitrary 'ScriptInput' of type 'SpendPK'. -arbitraryPKHashInput :: Network -> Gen ScriptInput -arbitraryPKHashInput net = do - sig <- arbitraryTxSignatureEmpty net - key <- snd <$> arbitraryKeyPair - return $ RegularInput $ SpendPKHash sig key - --- | Like 'arbitraryPKHashInput' without empty signatures. -arbitraryPKHashInputFull :: Network -> Gen ScriptInput -arbitraryPKHashInputFull net = do - sig <- lst3 <$> arbitraryTxSignature net - key <- snd <$> arbitraryKeyPair - return $ RegularInput $ SpendPKHash sig key - --- | Like above but only compressed. -arbitraryPKHashInputFullC :: Network -> Gen ScriptInput -arbitraryPKHashInputFullC net = do - sig <- lst3 <$> arbitraryTxSignature net - key <- fmap snd $ arbitraryKeyPair `suchThat` (pubKeyCompressed . snd) - return $ RegularInput $ SpendPKHash sig key - --- | Arbitrary 'ScriptInput' of type 'SpendMulSig'. -arbitraryMSInput :: Network -> Gen ScriptInput -arbitraryMSInput net = do - m <- fst <$> arbitraryMSParam - 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'. -arbitraryMulSigSHInput :: Network -> Gen ScriptInput -arbitraryMulSigSHInput net = - arbitraryMSOutput >>= \case - rdm@(PayMulSig _ m) -> do - sigs <- vectorOf m (arbitraryTxSignatureEmpty net) - return $ ScriptHashInput (SpendMulSig sigs) rdm - _ -> undefined - --- | Arbitrary 'ScriptInput' of type 'ScriptHashInput' containing a --- 'RedeemScript' of type 'PayMulSig' and an input of type 'SpendMulSig'. -arbitraryMulSigSHInputC :: Network -> Gen ScriptInput -arbitraryMulSigSHInputC net = - arbitraryMSOutputC >>= \case - rdm@(PayMulSig _ m) -> do - sigs <- vectorOf m (arbitraryTxSignatureEmpty net) - return $ ScriptHashInput (SpendMulSig sigs) rdm - _ -> undefined - --- | Like 'arbitraryMulSigSHCInput' with no empty signatures. -arbitraryMulSigSHInputFull :: Network -> Gen ScriptInput -arbitraryMulSigSHInputFull net = - arbitraryMSOutput >>= \case - rdm@(PayMulSig _ m) -> do - sigs <- map lst3 <$> vectorOf m (arbitraryTxSignature net) - return $ ScriptHashInput (SpendMulSig sigs) rdm - _ -> undefined - --- | Like 'arbitraryMulSigSHCInput' with no empty signatures. -arbitraryMulSigSHInputFullC :: Network -> Gen ScriptInput -arbitraryMulSigSHInputFullC net = - arbitraryMSOutputC >>= \case - rdm@(PayMulSig _ m) -> do - sigs <- map lst3 <$> vectorOf m (arbitraryTxSignature net) - return $ ScriptHashInput (SpendMulSig sigs) rdm - _ -> undefined diff --git a/test/Network/Haskoin/Test/Transaction.hs b/test/Network/Haskoin/Test/Transaction.hs deleted file mode 100644 --- a/test/Network/Haskoin/Test/Transaction.hs +++ /dev/null @@ -1,275 +0,0 @@ -{-| -Module : Network.Haskoin.Test.Transaction -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} -module Network.Haskoin.Test.Transaction where - -import Control.Monad -import qualified Data.ByteString as BS -import Data.Either (fromRight) -import Data.List (nub, nubBy, permutations) -import Data.Word (Word64) -import Network.Haskoin.Address -import Network.Haskoin.Constants -import Network.Haskoin.Keys.Common -import Network.Haskoin.Script -import Network.Haskoin.Test.Crypto -import Network.Haskoin.Test.Keys -import Network.Haskoin.Test.Script -import Network.Haskoin.Test.Util -import Network.Haskoin.Transaction -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) - <*> (encodeOutputBS <$> arbitraryScriptOutput net) - --- | Arbitrary 'TxIn'. -arbitraryTxIn :: Network -> Gen TxIn -arbitraryTxIn net = - 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 - ni <- choose (0, 5) - no <- - if wit - then choose (0, 5) - else choose - ( if ni == 0 - then 2 - else 0 - , 5 -- avoid witness case - ) - inps <- vectorOf ni (arbitraryTxIn net) - outs <- vectorOf no (arbitraryTxOut net) - let uniqueInps = nubBy (\a b -> prevOutput a == prevOutput b) inps - w <- if wit then vectorOf (length uniqueInps) (listOf arbitraryBS) else return [] - Tx <$> arbitrary <*> pure uniqueInps <*> pure outs <*> pure w <*> arbitrary - --- | 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 (0, 5) - no <- choose (0, 5) - inps <- vectorOf ni (arbitraryAddrOnlyTxIn net) - 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 - ni <- choose (0, 5) - no <- choose (0, 5) - inps <- vectorOf ni (arbitraryAddrOnlyTxInFull net) - 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. -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 - inp <- - 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 - v <- getTestCoin <$> arbitrarySatoshi net - out <- oneof [arbitraryPKHashOutput, arbitrarySHOutput] - return $ TxOut v $ encodeOutputBS out - --- | Arbitrary 'SigInput' with the corresponding private keys used --- to generate the 'ScriptOutput' or 'RedeemScript'. -arbitrarySigInput :: Network -> Gen (SigInput, [SecKeyI]) -arbitrarySigInput net = - oneof - [ wrapKey <$> arbitraryPKSigInput net - , wrapKey <$> arbitraryPKHashSigInput net - , arbitraryMSSigInput net - , arbitrarySHSigInput net - , wrapKey <$> arbitraryWPKHSigInput net - , arbitraryWSHSigInput net - ] - --- | Arbitrary 'SigInput' with 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 - (k, p) <- arbitraryKeyPair - let out | pkh = PayPKHash $ getAddrHash160 $ pubKeyAddr p - | otherwise = PayPK p - (val, op, sh) <- arbitraryInputStuff net - return (SigInput out val op sh Nothing, k) - --- | Arbitrary value, out point and sighash for an input. -arbitraryInputStuff :: Network -> Gen (Word64, OutPoint, SigHash) -arbitraryInputStuff net = do - val <- getTestCoin <$> arbitrarySatoshi net - op <- arbitraryOutPoint - sh <- arbitraryValidSigHash net - return (val, op, sh) - --- | Arbitrary 'SigInput' with a 'ScriptOutput' of type 'PayMulSig'. -arbitraryMSSigInput :: Network -> Gen (SigInput, [SecKeyI]) -arbitraryMSSigInput net = do - (m, n) <- arbitraryMSParam - ks <- vectorOf n arbitraryKeyPair - let out = PayMulSig (map snd ks) m - (val, op, sh) <- arbitraryInputStuff net - perm <- choose (0, n - 1) - let ksPerm = map fst $ take m $ permutations ks !! perm - return (SigInput out val op sh Nothing, ksPerm) - --- | Arbitrary 'SigInput' with 'ScriptOutput' of type 'PaySH' and a --- 'RedeemScript'. -arbitrarySHSigInput :: Network -> Gen (SigInput, [SecKeyI]) -arbitrarySHSigInput net = do - (SigInput rdm val op sh _, ks) <- oneof - [ wrapKey <$> arbitraryPKSigInput net - , wrapKey <$> arbitraryPKHashSigInput net - , arbitraryMSSigInput net - ] - let out = PayScriptHash $ getAddrHash160 $ payToScriptAddress rdm - return (SigInput out val op sh $ Just rdm, ks) - -arbitraryWPKHSigInput :: Network -> Gen (SigInput, SecKeyI) -arbitraryWPKHSigInput net = do - (k, p) <- arbitraryKeyPair - (val, op, sh) <- arbitraryInputStuff net - let out = PayWitnessPKHash . getAddrHash160 $ pubKeyAddr p - return (SigInput out val op sh Nothing, k) - -arbitraryWSHSigInput :: Network -> Gen (SigInput, [SecKeyI]) -arbitraryWSHSigInput net = do - (SigInput rdm val op sh _, ks) <- oneof - [ wrapKey <$> arbitraryPKSigInput net - , wrapKey <$> arbitraryPKHashSigInput net - , arbitraryMSSigInput net - ] - let out = PayWitnessScriptHash . getAddrHash256 $ payToWitnessScriptAddress rdm - return (SigInput out val op sh $ Just rdm, ks) - --- | Arbitrary 'Tx' (empty 'TxIn'), 'SigInputs' and private keys that can be --- passed to 'signTx' or 'detSignTx' to fully sign the 'Tx'. -arbitrarySigningData :: Network -> Gen (Tx, [SigInput], [SecKeyI]) -arbitrarySigningData net = do - v <- arbitrary - ni <- choose (1, 5) - no <- choose (1, 5) - sigis <- vectorOf ni (arbitrarySigInput net) - let uSigis = nubBy (\(a, _) (b, _) -> sigInputOP a == sigInputOP b) sigis - inps <- forM uSigis $ \(s, _) -> TxIn (sigInputOP s) BS.empty <$> arbitrary - outs <- vectorOf no (arbitraryTxOut net) - l <- arbitrary - perm <- choose (0, length inps - 1) - let tx = Tx v (permutations inps !! perm) outs [] l - keys = concatMap snd uSigis - return (tx, map fst uSigis, keys) - --- | Arbitrary transaction with empty inputs. -arbitraryEmptyTx :: Network -> Gen Tx -arbitraryEmptyTx net = do - v <- arbitrary - no <- choose (1,5) - ni <- choose (1,5) - outs <- vectorOf no (arbitraryTxOut net) - ops <- vectorOf ni arbitraryOutPoint - t <- arbitrary - s <- arbitrary - return $ Tx v (map (\op -> TxIn op BS.empty s) (nub ops)) outs [] t - --- | Arbitrary partially-signed transactions. -arbitraryPartialTxs :: - Network -> Gen ([Tx], [(ScriptOutput, Word64, OutPoint, Int, Int)]) -arbitraryPartialTxs net = do - tx <- arbitraryEmptyTx net - res <- - forM (map prevOutput $ txIn tx) $ \op -> do - (so, val, rdmM, prvs, m, n) <- arbitraryData - txs <- mapM (singleSig so val rdmM tx op . secKeyData) prvs - return (txs, (so, val, op, m, n)) - return (concatMap fst res, map snd res) - where - singleSig so val rdmM tx op prv = do - sh <- arbitraryValidSigHash net - let sigi = SigInput so val op sh rdmM - return . fromRight (error "Could not decode transaction") $ - signTx net tx [sigi] [prv] - arbitraryData = do - (m, n) <- arbitraryMSParam - val <- getTestCoin <$> arbitrarySatoshi net - nPrv <- choose (m, n) - keys <- vectorOf n arbitraryKeyPair - perm <- choose (0, length keys - 1) - let pubKeys = map snd keys - prvKeys = take nPrv $ permutations (map fst keys) !! perm - let so = PayMulSig pubKeys m - elements - [ (so, val, Nothing, prvKeys, m, n) - , ( PayScriptHash $ getAddrHash160 $ payToScriptAddress so - , val - , Just so - , prvKeys - , m - , n) - ] - -wrapKey :: (SigInput, SecKeyI) -> (SigInput, [SecKeyI]) -wrapKey (s, k) = (s, [k]) diff --git a/test/Network/Haskoin/Test/Util.hs b/test/Network/Haskoin/Test/Util.hs deleted file mode 100644 --- a/test/Network/Haskoin/Test/Util.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-| -Module : Network.Haskoin.Test.Util -Copyright : No rights reserved -License : UNLICENSE -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} -module Network.Haskoin.Test.Util where - -import Data.ByteString (ByteString, pack) -import Data.Time.Clock (UTCTime (..)) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Data.Word (Word32) -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 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 = frequency [ (1, return Nothing) - , (5, Just <$> g) - ] - diff --git a/test/Network/Haskoin/Transaction/PartialSpec.hs b/test/Network/Haskoin/Transaction/PartialSpec.hs deleted file mode 100644 --- a/test/Network/Haskoin/Transaction/PartialSpec.hs +++ /dev/null @@ -1,336 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Network.Haskoin.Transaction.PartialSpec (spec) where - -import Control.Monad.Fail (MonadFail) -import Data.ByteString (ByteString) -import Data.Either (fromRight, isLeft, - isRight) -import Data.HashMap.Strict (fromList, singleton) -import Data.Maybe (fromJust, isJust) -import Data.Serialize as S -import Data.Text (Text) -import Test.Hspec -import Test.HUnit (Assertion, assertBool, - assertEqual) -import Test.QuickCheck - -import Network.Haskoin.Address -import Network.Haskoin.Constants -import Network.Haskoin.Crypto -import Network.Haskoin.Keys -import Network.Haskoin.Script -import Network.Haskoin.Test -import Network.Haskoin.Transaction -import Network.Haskoin.Transaction.Partial -import Network.Haskoin.Util - -spec :: Spec -spec = describe "partially signed bitcoin transaction unit tests" $ do - it "encodes trivial psbt" $ - encodeHex (S.encode trivialPSBT) == trivialPSBTHex - it "decodes trivial psbt" $ - decodeHexPSBT trivialPSBTHex == Right trivialPSBT - it "encodes and decodes non-empty transactions" $ - S.decode (S.encode nonEmptyTransactionPSBT) == Right nonEmptyTransactionPSBT - it "does not decode invalid bip vectors" $ - mapM_ invalidVecTest invalidVec - it "encodes valid bip vecs" $ - mapM_ (uncurry encodeVecTest) validEncodeVec - it "decodes valid bip vecs" $ - mapM_ (uncurry decodeVecTest) $ zip [1..] validVec - it "decodes vector 2" vec2Test - it "decodes vector 3" vec3Test - it "decodes vector 4" vec4Test - it "decodes vector 5" vec5Test - it "decodes vector 6" vec6Test - it "signed and finalized p2pkh PSBTs verify" $ property $ - forAll arbitraryKeyPair $ verifyNonWitnessPSBT btc . unfinalizedPkhPSBT btc - it "signed and finalized multisig PSBTs verify" $ property $ - forAll arbitraryMultiSig $ verifyNonWitnessPSBT btc . unfinalizedMsPSBT btc - -vec2Test :: Assertion -vec2Test = do - psbt <- decodeHexPSBTM "Cannot parse validVec2" validVec2Hex - assertEqual "2 inputs" 2 (length $ inputs psbt) - assertEqual "2 outputs" 2 (length $ outputs psbt) - assertBool "final script sig" $ isJust (finalScriptSig . head $ inputs psbt) - - let rdmScript = fromJust . inputRedeemScript $ inputs psbt !! 1 - assertBool "p2wpkh" $ (isPayWitnessPKHash <$> decodeOutput rdmScript) == Right True - - let scrptPubKey = witnessScriptPubKey $ inputs psbt !! 1 - rdmScriptP2SH = toP2SH rdmScript - assertEqual "redeem script pubkey equal" rdmScriptP2SH scrptPubKey - assertEqual "expected redeem script" expectedOut rdmScriptP2SH - - mapM_ (assertEqual "outputs are empty" emptyOutput) (outputs psbt) - -vec3Test :: Assertion -vec3Test = do - psbt <- decodeHexPSBTM "Cannot parse validVec3" validVec3Hex - assertEqual "1 input" 1 (length $ inputs psbt) - assertEqual "2 outputs" 2 (length $ outputs psbt) - let txInput = head . txIn $ unsignedTransaction psbt - firstInput = head $ inputs psbt - Just utx = nonWitnessUtxo firstInput - OutPoint prevHash prevVOut = prevOutput txInput - assertEqual "txids of inputs match" prevHash (txHash utx) - let prevOutputKey = fromRight (error "Could not decode key") - . decodeOutputBS . scriptOutput $ txOut utx !! fromIntegral prevVOut - assertBool "p2pkh" $ isPayPKHash prevOutputKey - assertEqual "sighash type" sigHashAll (fromJust $ sigHashType firstInput) - -vec4Test :: Assertion -vec4Test = do - psbt <- decodeHexPSBTM "Cannot parse validVec4" validVec4Hex - assertEqual "2 inputs" 2 (length $ inputs psbt) - assertEqual "2 outputs" 2 (length $ outputs psbt) - let firstInput = head $ inputs psbt - secondInput = inputs psbt !! 1 - assertEqual "first input not final script sig" Nothing (finalScriptSig firstInput) - assertEqual "second input not final script sig" Nothing (finalScriptSig secondInput) - - let rdmScript = fromJust $ inputRedeemScript secondInput - assertBool "p2wpkh" $ (isPayWitnessPKHash <$> decodeOutput rdmScript) == Right True - - let scrptPubKey = witnessScriptPubKey secondInput - rdmScriptP2SH = toP2SH rdmScript - assertEqual "redeem script pubkey equal" rdmScriptP2SH scrptPubKey - assertEqual "expected redeem script" expectedOut rdmScriptP2SH - - assertBool "all non-empty outputs" $ emptyOutput `notElem` outputs psbt - -vec5Test :: Assertion -vec5Test = do - psbt <- decodeHexPSBTM "Cannot parse validVec5" validVec5Hex - assertEqual "1 input" 1 (length $ inputs psbt) - assertEqual "1 output" 1 (length $ outputs psbt) - let input = head $ inputs psbt - assertEqual "input not final script sig" Nothing (finalScriptSig input) - - let rdmScript = fromJust $ inputRedeemScript input - assertBool "p2wsh" $ (isPayWitnessScriptHash <$> decodeOutput rdmScript) == Right True - - let scrptPubKey = witnessScriptPubKey input - rdmScriptP2SH = toP2SH rdmScript - assertEqual "redeem script pubkey equal" rdmScriptP2SH scrptPubKey - assertEqual "expected redeem script" expectedOut2 rdmScriptP2SH - where - expectedOut2 = fromRight (error "could not decode expected output") - . decodeOutputBS . fromJust $ decodeHex "a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87" - -vec6Test :: Assertion -vec6Test = do - psbt <- decodeHexPSBTM "Cannot parse validVec6" validVec6Hex - assertEqual "1 input" 1 (length $ inputs psbt) - assertEqual "1 output" 1 (length $ outputs psbt) - - let tx = unsignedTransaction psbt - assertEqual "correct transaction" "75c5c9665a570569ad77dd1279e6fd4628a093c4dcbf8d41532614044c14c115" (txHash tx) - - assertEqual "correct unknowns" expectedUnknowns (inputUnknown . head $ inputs psbt) - where - expectedUnknowns = UnknownMap $ singleton - (Key 0x0f (fromJust $ decodeHex "010203040506070809")) - (fromJust $ decodeHex "0102030405060708090a0b0c0d0e0f") - -expectedOut :: ScriptOutput -expectedOut = fromRight (error "could not decode expected output") - . decodeOutputBS . fromJust $ decodeHex "a9143545e6e33b832c47050f24d3eeb93c9c03948bc787" - -witnessScriptPubKey :: Input -> ScriptOutput -witnessScriptPubKey = fromRight (error "could not decode witness utxo") - . decodeOutputBS . scriptOutput . 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 . S.decode . fromJust . decodeHex - where - encodeScript :: Script -> ByteString - encodeScript = S.encode - -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 - { unsignedTransaction = Tx { txVersion = 2, txIn = [], txOut = [], txWitness = [], txLockTime = 0 } - , globalUnknown = UnknownMap mempty - , inputs = [] - , outputs = [] - } - -trivialPSBTHex :: Text -trivialPSBTHex = "70736274ff01000a0200000000000000000000" - -nonEmptyTransactionPSBT :: PartiallySignedTransaction -nonEmptyTransactionPSBT = emptyPSBT testTx1 - -verifyNonWitnessPSBT :: Network -> PartiallySignedTransaction -> Bool -verifyNonWitnessPSBT net psbt = verifyStdTx net (finalTransaction (complete psbt)) sigData - where - sigData = inputSigData =<< zip (inputs psbt) (txIn $ unsignedTransaction psbt) - decodeOutScript = fromRight (error "Could not parse output script") . decodeOutputBS - inputSigData (input, txInput) = - map (\(TxOut val script) -> (decodeOutScript script, val, prevOutput txInput)) - (txOut . fromJust $ nonWitnessUtxo input) - -unfinalizedPkhPSBT :: Network -> (SecKeyI, PubKeyI) -> PartiallySignedTransaction -unfinalizedPkhPSBT net (prvKey, pubKey) = (emptyPSBT currTx) - { inputs = [ emptyInput { nonWitnessUtxo = Just prevTx, partialSigs = singleton pubKey sig } ] } - where - currTx = unfinalizedTx (txHash prevTx) - prevTx = testUtxo [prevOut] - prevOutScript = addressToScript (pubKeyAddr pubKey) - prevOut = TxOut { outValue = 200000000, scriptOutput = S.encode prevOutScript } - h = txSigHash net currTx prevOutScript (outValue prevOut) 0 sigHashAll - sig = encodeTxSig $ TxSignature (signHash (secKeyData prvKey) h) sigHashAll - -arbitraryMultiSig :: Gen ([(SecKeyI, PubKeyI)], Int) -arbitraryMultiSig = do - (m, n) <- arbitraryMSParam - keys <- vectorOf n arbitraryKeyPair - return (keys, m) - -unfinalizedMsPSBT :: Network -> ([(SecKeyI, PubKeyI)], Int) -> PartiallySignedTransaction -unfinalizedMsPSBT net (keys, m) = (emptyPSBT currTx) - { inputs = [ emptyInput { nonWitnessUtxo = Just prevTx, partialSigs = sigs - , inputRedeemScript = Just prevOutScript - } ] } - where - currTx = unfinalizedTx (txHash prevTx) - prevTx = testUtxo [prevOut] - prevOutScript = encodeOutput $ PayMulSig (map snd keys) m - prevOut = TxOut { outValue = 200000000, scriptOutput = encodeOutputBS (toP2SH prevOutScript) } - h = txSigHash net currTx prevOutScript (outValue prevOut) 0 sigHashAll - sigs = fromList $ map sig keys - sig (prvKey, pubKey) = (pubKey, encodeTxSig $ TxSignature (signHash (secKeyData prvKey) h) sigHashAll) - -unfinalizedTx :: TxHash -> Tx -unfinalizedTx prevHash = Tx - { txVersion = 2 - , txIn = [ TxIn - { prevOutput = OutPoint prevHash 0 - , scriptInput = "" - , txInSequence = 4294967294 - } ] - , txOut = - [ TxOut { outValue = 99999699, scriptOutput = hexScript "76a914d0c59903c5bac2868760e90fd521a4665aa7652088ac" } - , TxOut { outValue = 100000000, scriptOutput = hexScript "a9143545e6e33b832c47050f24d3eeb93c9c03948bc787" } - ] - , txWitness = [] - , txLockTime = 1257139 - } - -invalidVec :: [Text] -invalidVec = - [ "0200000001268171371edff285e937adeea4b37b78000c0566cbb3ad64641713ca42171bf6000000006a473044022070b2245123e6bf474d60c5b50c043d4c691a5d2435f09a34a7662a9dc251790a022001329ca9dacf280bdf30740ec0390422422c81cb45839457aeb76fc12edd95b3012102657d118d3357b8e0f4c2cd46db7b39f6d9c38d9a70abcb9b2de5dc8dbfe4ce31feffffff02d3dff505000000001976a914d0c59903c5bac2868760e90fd521a4665aa7652088ac00e1f5050000000017a9143545e6e33b832c47050f24d3eeb93c9c03948bc787b32e1300" - , "70736274ff0100750200000001268171371edff285e937adeea4b37b78000c0566cbb3ad64641713ca42171bf60000000000feffffff02d3dff505000000001976a914d0c59903c5bac2868760e90fd521a4665aa7652088ac00e1f5050000000017a9143545e6e33b832c47050f24d3eeb93c9c03948bc787b32e1300000100fda5010100000000010289a3c71eab4d20e0371bbba4cc698fa295c9463afa2e397f8533ccb62f9567e50100000017160014be18d152a9b012039daf3da7de4f53349eecb985ffffffff86f8aa43a71dff1448893a530a7237ef6b4608bbb2dd2d0171e63aec6a4890b40100000017160014fe3e9ef1a745e974d902c4355943abcb34bd5353ffffffff0200c2eb0b000000001976a91485cff1097fd9e008bb34af709c62197b38978a4888ac72fef84e2c00000017a914339725ba21efd62ac753a9bcd067d6c7a6a39d05870247304402202712be22e0270f394f568311dc7ca9a68970b8025fdd3b240229f07f8a5f3a240220018b38d7dcd314e734c9276bd6fb40f673325bc4baa144c800d2f2f02db2765c012103d2e15674941bad4a996372cb87e1856d3652606d98562fe39c5e9e7e413f210502483045022100d12b852d85dcd961d2f5f4ab660654df6eedcc794c0c33ce5cc309ffb5fce58d022067338a8e0e1725c197fb1a88af59f51e44e4255b20167c8684031c05d1f2592a01210223b72beef0965d10be0778efecd61fcac6f79a4ea169393380734464f84f2ab30000000000" - , "70736274ff0100fd0a010200000002ab0949a08c5af7c49b8212f417e2f15ab3f5c33dcf153821a8139f877a5b7be4000000006a47304402204759661797c01b036b25928948686218347d89864b719e1f7fcf57d1e511658702205309eabf56aa4d8891ffd111fdf1336f3a29da866d7f8486d75546ceedaf93190121035cdc61fc7ba971c0b501a646a2a83b102cb43881217ca682dc86e2d73fa88292feffffffab0949a08c5af7c49b8212f417e2f15ab3f5c33dcf153821a8139f877a5b7be40100000000feffffff02603bea0b000000001976a914768a40bbd740cbe81d988e71de2a4d5c71396b1d88ac8e240000000000001976a9146f4620b553fa095e721b9ee0efe9fa039cca459788ac00000000000001012000e1f5050000000017a9143545e6e33b832c47050f24d3eeb93c9c03948bc787010416001485d13537f2e265405a34dbafa9e3dda01fb82308000000" - , "70736274ff000100fda5010100000000010289a3c71eab4d20e0371bbba4cc698fa295c9463afa2e397f8533ccb62f9567e50100000017160014be18d152a9b012039daf3da7de4f53349eecb985ffffffff86f8aa43a71dff1448893a530a7237ef6b4608bbb2dd2d0171e63aec6a4890b40100000017160014fe3e9ef1a745e974d902c4355943abcb34bd5353ffffffff0200c2eb0b000000001976a91485cff1097fd9e008bb34af709c62197b38978a4888ac72fef84e2c00000017a914339725ba21efd62ac753a9bcd067d6c7a6a39d05870247304402202712be22e0270f394f568311dc7ca9a68970b8025fdd3b240229f07f8a5f3a240220018b38d7dcd314e734c9276bd6fb40f673325bc4baa144c800d2f2f02db2765c012103d2e15674941bad4a996372cb87e1856d3652606d98562fe39c5e9e7e413f210502483045022100d12b852d85dcd961d2f5f4ab660654df6eedcc794c0c33ce5cc309ffb5fce58d022067338a8e0e1725c197fb1a88af59f51e44e4255b20167c8684031c05d1f2592a01210223b72beef0965d10be0778efecd61fcac6f79a4ea169393380734464f84f2ab30000000000" - , "70736274ff0100750200000001268171371edff285e937adeea4b37b78000c0566cbb3ad64641713ca42171bf60000000000feffffff02d3dff505000000001976a914d0c59903c5bac2868760e90fd521a4665aa7652088ac00e1f5050000000017a9143545e6e33b832c47050f24d3eeb93c9c03948bc787b32e1300000100fda5010100000000010289a3c71eab4d20e0371bbba4cc698fa295c9463afa2e397f8533ccb62f9567e50100000017160014be18d152a9b012039daf3da7de4f53349eecb985ffffffff86f8aa43a71dff1448893a530a7237ef6b4608bbb2dd2d0171e63aec6a4890b40100000017160014fe3e9ef1a745e974d902c4355943abcb34bd5353ffffffff0200c2eb0b000000001976a91485cff1097fd9e008bb34af709c62197b38978a4888ac72fef84e2c00000017a914339725ba21efd62ac753a9bcd067d6c7a6a39d05870247304402202712be22e0270f394f568311dc7ca9a68970b8025fdd3b240229f07f8a5f3a240220018b38d7dcd314e734c9276bd6fb40f673325bc4baa144c800d2f2f02db2765c012103d2e15674941bad4a996372cb87e1856d3652606d98562fe39c5e9e7e413f210502483045022100d12b852d85dcd961d2f5f4ab660654df6eedcc794c0c33ce5cc309ffb5fce58d022067338a8e0e1725c197fb1a88af59f51e44e4255b20167c8684031c05d1f2592a01210223b72beef0965d10be0778efecd61fcac6f79a4ea169393380734464f84f2ab30000000001003f0200000001ffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff0000000000ffffffff010000000000000000036a010000000000000000" - , "70736274ff020001550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac0000000000010120955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87220203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4646304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a010104220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681010547522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae220603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4610b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000" - , "70736274ff0100550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac000000000002010020955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87220203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4646304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a010104220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681010547522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae220603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4610b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000" - , "70736274ff0100550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac0000000000010120955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87210203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd46304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a010104220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681010547522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae220603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4610b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000" - , "70736274ff0100550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac0000000000010120955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87220203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4646304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a01020400220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681010547522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae220603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4610b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000" - , "70736274ff0100550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac0000000000010120955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87220203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4646304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a010104220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d568102050047522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae220603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4610b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000" - , "70736274ff0100550200000001279a2323a5dfb51fc45f220fa58b0fc13e1e3342792a85d7e36cd6333b5cbc390000000000ffffffff01a05aea0b000000001976a914ffe9c0061097cc3b636f2cb0460fa4fc427d2b4588ac0000000000010120955eea0b0000000017a9146345200f68d189e1adc0df1c4d16ea8f14c0dbeb87220203b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd4646304302200424b58effaaa694e1559ea5c93bbfd4a89064224055cdf070b6771469442d07021f5c8eb0fea6516d60b8acb33ad64ede60e8785bfb3aa94b99bdf86151db9a9a010104220020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681010547522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae210603b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd10b4a6ba67000000800000008004000080220603de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd10b4a6ba670000008000000080050000800000" - , "70736274ff01009a020000000258e87a21b56daf0c23be8e7070456c336f7cbaa5c8757924f545887bb2abdd750000000000ffffffff838d0427d0ec650a68aa46bb0b098aea4422c071b2ca78352a077959d07cea1d0100000000ffffffff0270aaf00800000000160014d85c2b71d0060b09c9886aeb815e50991dda124d00e1f5050000000016001400aea9a2e5f0f876a588df5546e8742d1d87008f0000000000020000bb0200000001aad73931018bd25f84ae400b68848be09db706eac2ac18298babee71ab656f8b0000000048473044022058f6fc7c6a33e1b31548d481c826c015bd30135aad42cd67790dab66d2ad243b02204a1ced2604c6735b6393e5b41691dd78b00f0c5942fb9f751856faa938157dba01feffffff0280f0fa020000000017a9140fb9463421696b82c833af241c78c17ddbde493487d0f20a270100000017a91429ca74f8a08f81999428185c97b5d852e4063f6187650000000107da00473044022074018ad4180097b873323c0015720b3684cc8123891048e7dbcd9b55ad679c99022073d369b740e3eb53dcefa33823c8070514ca55a7dd9544f157c167913261118c01483045022100f61038b308dc1da865a34852746f015772934208c6d24454393cd99bdf2217770220056e675a675a6d0a02b85b14e5e29074d8a25a9b5760bea2816f661910a006ea01475221029583bf39ae0a609747ad199addd634fa6108559d6c5cd39b4c2183f1ab96e07f2102dab61ff49a14db6a7d02b0cd1fbb78fc4b18312b5b4e54dae4dba2fbfef536d752ae0001012000c2eb0b0000000017a914b7f5faf40e3d40a5a459b1db3535f2b72fa921e8870107232200208c2353173743b595dfb4a07b72ba8e42e3797da74e87fe7d9d7497e3b20289030108da0400473044022062eb7a556107a7c73f45ac4ab5a1dddf6f7075fb1275969a7f383efff784bcb202200c05dbb7470dbf2f08557dd356c7325c1ed30913e996cd3840945db12228da5f01473044022065f45ba5998b59a27ffe1a7bed016af1f1f90d54b3aa8f7450aa5f56a25103bd02207f724703ad1edb96680b284b56d4ffcb88f7fb759eabbe08aa30f29b851383d20147522103089dc10c7ac6db54f91329af617333db388cead0c231f723379d1b99030b02dc21023add904f3d6dcf59ddb906b0dee23529b7ffb9ed50e5e86151926860221f0e7352ae00220203a9a4c37f5996d3aa25dbac6b570af0650394492942460b354753ed9eeca5877110d90c6a4f000000800000008004000080002202027f6399757d2eff55a136ad02c684b1838b6556e5f1b6b34282a94b6b5005109610d90c6a4f00000080000000800500008000" - , "70736274ff01009a020000000258e87a21b56daf0c23be8e7070456c336f7cbaa5c8757924f545887bb2abdd750000000000ffffffff838d0427d0ec650a68aa46bb0b098aea4422c071b2ca78352a077959d07cea1d0100000000ffffffff0270aaf00800000000160014d85c2b71d0060b09c9886aeb815e50991dda124d00e1f5050000000016001400aea9a2e5f0f876a588df5546e8742d1d87008f00000000000100bb0200000001aad73931018bd25f84ae400b68848be09db706eac2ac18298babee71ab656f8b0000000048473044022058f6fc7c6a33e1b31548d481c826c015bd30135aad42cd67790dab66d2ad243b02204a1ced2604c6735b6393e5b41691dd78b00f0c5942fb9f751856faa938157dba01feffffff0280f0fa020000000017a9140fb9463421696b82c833af241c78c17ddbde493487d0f20a270100000017a91429ca74f8a08f81999428185c97b5d852e4063f618765000000020700da00473044022074018ad4180097b873323c0015720b3684cc8123891048e7dbcd9b55ad679c99022073d369b740e3eb53dcefa33823c8070514ca55a7dd9544f157c167913261118c01483045022100f61038b308dc1da865a34852746f015772934208c6d24454393cd99bdf2217770220056e675a675a6d0a02b85b14e5e29074d8a25a9b5760bea2816f661910a006ea01475221029583bf39ae0a609747ad199addd634fa6108559d6c5cd39b4c2183f1ab96e07f2102dab61ff49a14db6a7d02b0cd1fbb78fc4b18312b5b4e54dae4dba2fbfef536d752ae0001012000c2eb0b0000000017a914b7f5faf40e3d40a5a459b1db3535f2b72fa921e8870107232200208c2353173743b595dfb4a07b72ba8e42e3797da74e87fe7d9d7497e3b20289030108da0400473044022062eb7a556107a7c73f45ac4ab5a1dddf6f7075fb1275969a7f383efff784bcb202200c05dbb7470dbf2f08557dd356c7325c1ed30913e996cd3840945db12228da5f01473044022065f45ba5998b59a27ffe1a7bed016af1f1f90d54b3aa8f7450aa5f56a25103bd02207f724703ad1edb96680b284b56d4ffcb88f7fb759eabbe08aa30f29b851383d20147522103089dc10c7ac6db54f91329af617333db388cead0c231f723379d1b99030b02dc21023add904f3d6dcf59ddb906b0dee23529b7ffb9ed50e5e86151926860221f0e7352ae00220203a9a4c37f5996d3aa25dbac6b570af0650394492942460b354753ed9eeca5877110d90c6a4f000000800000008004000080002202027f6399757d2eff55a136ad02c684b1838b6556e5f1b6b34282a94b6b5005109610d90c6a4f00000080000000800500008000" - , "70736274ff01009a020000000258e87a21b56daf0c23be8e7070456c336f7cbaa5c8757924f545887bb2abdd750000000000ffffffff838d0427d0ec650a68aa46bb0b098aea4422c071b2ca78352a077959d07cea1d0100000000ffffffff0270aaf00800000000160014d85c2b71d0060b09c9886aeb815e50991dda124d00e1f5050000000016001400aea9a2e5f0f876a588df5546e8742d1d87008f00000000000100bb0200000001aad73931018bd25f84ae400b68848be09db706eac2ac18298babee71ab656f8b0000000048473044022058f6fc7c6a33e1b31548d481c826c015bd30135aad42cd67790dab66d2ad243b02204a1ced2604c6735b6393e5b41691dd78b00f0c5942fb9f751856faa938157dba01feffffff0280f0fa020000000017a9140fb9463421696b82c833af241c78c17ddbde493487d0f20a270100000017a91429ca74f8a08f81999428185c97b5d852e4063f6187650000000107da00473044022074018ad4180097b873323c0015720b3684cc8123891048e7dbcd9b55ad679c99022073d369b740e3eb53dcefa33823c8070514ca55a7dd9544f157c167913261118c01483045022100f61038b308dc1da865a34852746f015772934208c6d24454393cd99bdf2217770220056e675a675a6d0a02b85b14e5e29074d8a25a9b5760bea2816f661910a006ea01475221029583bf39ae0a609747ad199addd634fa6108559d6c5cd39b4c2183f1ab96e07f2102dab61ff49a14db6a7d02b0cd1fbb78fc4b18312b5b4e54dae4dba2fbfef536d752ae0001012000c2eb0b0000000017a914b7f5faf40e3d40a5a459b1db3535f2b72fa921e8870107232200208c2353173743b595dfb4a07b72ba8e42e3797da74e87fe7d9d7497e3b2028903020800da0400473044022062eb7a556107a7c73f45ac4ab5a1dddf6f7075fb1275969a7f383efff784bcb202200c05dbb7470dbf2f08557dd356c7325c1ed30913e996cd3840945db12228da5f01473044022065f45ba5998b59a27ffe1a7bed016af1f1f90d54b3aa8f7450aa5f56a25103bd02207f724703ad1edb96680b284b56d4ffcb88f7fb759eabbe08aa30f29b851383d20147522103089dc10c7ac6db54f91329af617333db388cead0c231f723379d1b99030b02dc21023add904f3d6dcf59ddb906b0dee23529b7ffb9ed50e5e86151926860221f0e7352ae00220203a9a4c37f5996d3aa25dbac6b570af0650394492942460b354753ed9eeca5877110d90c6a4f000000800000008004000080002202027f6399757d2eff55a136ad02c684b1838b6556e5f1b6b34282a94b6b5005109610d90c6a4f00000080000000800500008000" - , "70736274ff01009a020000000258e87a21b56daf0c23be8e7070456c336f7cbaa5c8757924f545887bb2abdd750000000000ffffffff838d0427d0ec650a68aa46bb0b098aea4422c071b2ca78352a077959d07cea1d0100000000ffffffff0270aaf00800000000160014d85c2b71d0060b09c9886aeb815e50991dda124d00e1f5050000000016001400aea9a2e5f0f876a588df5546e8742d1d87008f00000000000100bb0200000001aad73931018bd25f84ae400b68848be09db706eac2ac18298babee71ab656f8b0000000048473044022058f6fc7c6a33e1b31548d481c826c015bd30135aad42cd67790dab66d2ad243b02204a1ced2604c6735b6393e5b41691dd78b00f0c5942fb9f751856faa938157dba01feffffff0280f0fa020000000017a9140fb9463421696b82c833af241c78c17ddbde493487d0f20a270100000017a91429ca74f8a08f81999428185c97b5d852e4063f6187650000000107da00473044022074018ad4180097b873323c0015720b3684cc8123891048e7dbcd9b55ad679c99022073d369b740e3eb53dcefa33823c8070514ca55a7dd9544f157c167913261118c01483045022100f61038b308dc1da865a34852746f015772934208c6d24454393cd99bdf2217770220056e675a675a6d0a02b85b14e5e29074d8a25a9b5760bea2816f661910a006ea01475221029583bf39ae0a609747ad199addd634fa6108559d6c5cd39b4c2183f1ab96e07f2102dab61ff49a14db6a7d02b0cd1fbb78fc4b18312b5b4e54dae4dba2fbfef536d752ae0001012000c2eb0b0000000017a914b7f5faf40e3d40a5a459b1db3535f2b72fa921e8870107232200208c2353173743b595dfb4a07b72ba8e42e3797da74e87fe7d9d7497e3b20289030108da0400473044022062eb7a556107a7c73f45ac4ab5a1dddf6f7075fb1275969a7f383efff784bcb202200c05dbb7470dbf2f08557dd356c7325c1ed30913e996cd3840945db12228da5f01473044022065f45ba5998b59a27ffe1a7bed016af1f1f90d54b3aa8f7450aa5f56a25103bd02207f724703ad1edb96680b284b56d4ffcb88f7fb759eabbe08aa30f29b851383d20147522103089dc10c7ac6db54f91329af617333db388cead0c231f723379d1b99030b02dc21023add904f3d6dcf59ddb906b0dee23529b7ffb9ed50e5e86151926860221f0e7352ae00210203a9a4c37f5996d3aa25dbac6b570af0650394492942460b354753ed9eeca58710d90c6a4f000000800000008004000080002202027f6399757d2eff55a136ad02c684b1838b6556e5f1b6b34282a94b6b5005109610d90c6a4f00000080000000800500008000" - , "70736274ff0100730200000001301ae986e516a1ec8ac5b4bc6573d32f83b465e23ad76167d68b38e730b4dbdb0000000000ffffffff02747b01000000000017a91403aa17ae882b5d0d54b25d63104e4ffece7b9ea2876043993b0000000017a914b921b1ba6f722e4bfa83b6557a3139986a42ec8387000000000001011f00ca9a3b00000000160014d2d94b64ae08587eefc8eeb187c601e939f9037c0203000100000000010016001462e9e982fff34dd8239610316b090cd2a3b747cb000100220020876bad832f1d168015ed41232a9ea65a1815d9ef13c0ef8759f64b5b2b278a65010125512103b7ce23a01c5b4bf00a642537cdfabb315b668332867478ef51309d2bd57f8a8751ae00" - , "70736274ff0100730200000001301ae986e516a1ec8ac5b4bc6573d32f83b465e23ad76167d68b38e730b4dbdb0000000000ffffffff02747b01000000000017a91403aa17ae882b5d0d54b25d63104e4ffece7b9ea2876043993b0000000017a914b921b1ba6f722e4bfa83b6557a3139986a42ec8387000000000001011f00ca9a3b00000000160014d2d94b64ae08587eefc8eeb187c601e939f9037c0002000016001462e9e982fff34dd8239610316b090cd2a3b747cb000100220020876bad832f1d168015ed41232a9ea65a1815d9ef13c0ef8759f64b5b2b278a65010125512103b7ce23a01c5b4bf00a642537cdfabb315b668332867478ef51309d2bd57f8a8751ae00" - , "70736274ff0100730200000001301ae986e516a1ec8ac5b4bc6573d32f83b465e23ad76167d68b38e730b4dbdb0000000000ffffffff02747b01000000000017a91403aa17ae882b5d0d54b25d63104e4ffece7b9ea2876043993b0000000017a914b921b1ba6f722e4bfa83b6557a3139986a42ec8387000000000001011f00ca9a3b00000000160014d2d94b64ae08587eefc8eeb187c601e939f9037c00010016001462e9e982fff34dd8239610316b090cd2a3b747cb000100220020876bad832f1d168015ed41232a9ea65a1815d9ef13c0ef8759f64b5b2b278a6521010025512103b7ce23a01c5b4bf00a642537cdfabb315b668332867478ef51309d2bd57f8a8751ae00" - ] - - -validEncodeVec :: [(PartiallySignedTransaction, Text)] -validEncodeVec = [(validVec1, validVec1Hex)] - -testTx1 :: Tx -testTx1 = Tx - { txVersion = 2 - , txIn = [ TxIn - { prevOutput = OutPoint "f61b1742ca13176464adb3cb66050c00787bb3a4eead37e985f2df1e37718126" 0 - , scriptInput = "" - , txInSequence = 4294967294 - } ] - , txOut = - [ TxOut { outValue = 99999699, scriptOutput = hexScript "76a914d0c59903c5bac2868760e90fd521a4665aa7652088ac" } - , TxOut { outValue = 100000000, scriptOutput = hexScript "a9143545e6e33b832c47050f24d3eeb93c9c03948bc787" } - ] - , txWitness = [] - , txLockTime = 1257139 - } - -testUtxo :: [TxOut] -> Tx -testUtxo prevOuts = Tx - { txVersion = 1 - , txIn = - [ TxIn - { prevOutput = OutPoint "e567952fb6cc33857f392efa3a46c995a28f69cca4bb1b37e0204dab1ec7a389" 1 - , scriptInput = hexScript "160014be18d152a9b012039daf3da7de4f53349eecb985" - , txInSequence = 4294967295 - } - , TxIn - { prevOutput = OutPoint "b490486aec3ae671012dddb2bb08466bef37720a533a894814ff1da743aaf886" 1 - , scriptInput = hexScript "160014fe3e9ef1a745e974d902c4355943abcb34bd5353" - , txInSequence = 4294967295 - } - ] - , txOut = prevOuts - , txWitness = - [ - [ fromJust $ decodeHex "304402202712be22e0270f394f568311dc7ca9a68970b8025fdd3b240229f07f8a5f3a240220018b38d7dcd314e734c9276bd6fb40f673325bc4baa144c800d2f2f02db2765c01" - , fromJust $ decodeHex "03d2e15674941bad4a996372cb87e1856d3652606d98562fe39c5e9e7e413f2105" - ] - , [ fromJust $ decodeHex "3045022100d12b852d85dcd961d2f5f4ab660654df6eedcc794c0c33ce5cc309ffb5fce58d022067338a8e0e1725c197fb1a88af59f51e44e4255b20167c8684031c05d1f2592a01" - , fromJust $ decodeHex "0223b72beef0965d10be0778efecd61fcac6f79a4ea169393380734464f84f2ab3" - ] - ] - , txLockTime = 0 - } - -testUtxo1 :: Tx -testUtxo1 = testUtxo - [ TxOut { outValue = 200000000, scriptOutput = hexScript "76a91485cff1097fd9e008bb34af709c62197b38978a4888ac" } - , 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" diff --git a/test/Network/Haskoin/TransactionSpec.hs b/test/Network/Haskoin/TransactionSpec.hs deleted file mode 100644 --- a/test/Network/Haskoin/TransactionSpec.hs +++ /dev/null @@ -1,396 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Network.Haskoin.TransactionSpec (spec) where - -import Data.Aeson as A -import qualified Data.ByteString as B -import Data.Either -import Data.Map.Strict (singleton) -import Data.Maybe -import Data.Serialize as S -import Data.String (fromString) -import Data.String.Conversions -import Data.Text (Text) -import Data.Word (Word32, Word64) -import Network.Haskoin.Address -import Network.Haskoin.Constants -import Network.Haskoin.Keys -import Network.Haskoin.Script -import Network.Haskoin.Test -import Network.Haskoin.Transaction -import Network.Haskoin.Transaction.Segwit (isSegwit) -import Network.Haskoin.Util -import Safe (readMay) -import Test.Hspec -import Test.HUnit (Assertion, assertBool) -import Test.QuickCheck - -spec :: Spec -spec = do - let net = btc - describe "transaction unit tests" $ do - it "compute txid from tx" $ - mapM_ runTxIDVec txIDVec - it "build pkhash transaction (generated from bitcoind)" $ - mapM_ runPKHashVec pkHashVec - it "encode satoshi core script pubkey" tEncodeSatoshiCoreScriptPubKey - -- - -- These tests depend on signatures matching exactly those in the spec. - -- Fedora includes a version of libsecp256k1 that computes signatures - -- using a slighlty different deterministic nonce algorithm. - -- - -- it "agrees with BIP143 p2wpkh example" testBip143p2wpkh - -- it "agrees with BIP143 p2sh-p2wpkh example" testBip143p2shp2wpkh - -- it "builds a p2wsh multisig transaction" testP2WSHMulsig - -- it "agrees with BIP143 p2sh-p2wsh multisig example" testBip143p2shp2wpkhMulsig - describe "btc transaction" $ do - it "decode and encode txid" $ - property $ - forAll arbitraryTxHash $ \h -> hexToTxHash (txHashToHex h) == Just h - it "from string transaction id" $ - property $ - forAll arbitraryTxHash $ \h -> fromString (cs $ txHashToHex h) == h - it "building address tx" $ - property $ - forAll arbitraryAddress $ - forAll (arbitrarySatoshi net) . testBuildAddrTx net - it "guess transaction size" $ - property $ forAll (arbitraryAddrOnlyTxFull net) (testGuessSize net) - it "choose coins" $ - property $ forAll (listOf (arbitrarySatoshi net)) testChooseCoins - it "choose multisig coins" $ - property $ - forAll arbitraryMSParam $ - forAll (listOf (arbitrarySatoshi net)) . testChooseMSCoins - it "sign and validate transaction" $ - property $ forAll (arbitrarySigningData net) (testDetSignTx net) - it "sign and validate (nested) transaction" $ - property $ forAll (arbitrarySigningData net) (testDetSignNestedTx net) - it "merge partially signed transactions" $ - property $ forAll (arbitraryPartialTxs net) (testMergeTx net) - describe "json serialization" $ do - it "encodes and decodes transaction" $ - property $ forAll (arbitraryTx net) testID - it "encodes and decodes transaction hash" $ - property $ forAll arbitraryTxHash testID - describe "transaction serialization" $ do - it "encodes and decodes tx input" $ - property $ forAll (arbitraryTxIn net) cerealID - it "encodes and decodes tx output" $ - property $ forAll (arbitraryTxOut net) cerealID - it "encodes and decodes outpoint" $ - property $ forAll arbitraryOutPoint cerealID - it "encodes and decodes transaction" $ - property $ forAll (arbitraryTx net) cerealID - it "encodes and decodes witness transaction" $ - property $ forAll (arbitraryWitnessTx net) cerealID - it "encodes and decodes legacy transaction" $ - property $ forAll (arbitraryLegacyTx net) cerealID - -cerealID :: (Serialize a, Eq a) => a -> Bool -cerealID x = S.decode (S.encode x) == Right x - -runTxIDVec :: (Text, Text) -> Assertion -runTxIDVec (tid, tx) = assertBool "txid" $ txHashToHex (txHash txBS) == tid - where - txBS = fromJust $ either (const Nothing) return . S.decode =<< decodeHex tx - -txIDVec :: [(Text, Text)] -txIDVec = - [ ( "23b397edccd3740a74adb603c9756370fafcde9bcc4483eb271ecad09a94dd63" - , "0100000001b14bdcbc3e01bdaad36cc08e81e69c82e1060bc14e518db2b49aa43ad90ba26000000000490047304402203f16c6f40162ab686621ef3000b04e75418a0c0cb2d8aebeac894ae360ac1e780220ddc15ecdfc3507ac48e1681a33eb60996631bf6bf5bc0a0682c4db743ce7ca2b01ffffffff0140420f00000000001976a914660d4ef3a743e3e696ad990364e555c271ad504b88ac00000000" - ) - , ( "c99c49da4c38af669dea436d3e73780dfdb6c1ecf9958baa52960e8baee30e73" - , "01000000010276b76b07f4935c70acf54fbf1f438a4c397a9fb7e633873c4dd3bc062b6b40000000008c493046022100d23459d03ed7e9511a47d13292d3430a04627de6235b6e51a40f9cd386f2abe3022100e7d25b080f0bb8d8d5f878bba7d54ad2fda650ea8d158a33ee3cbd11768191fd004104b0e2c879e4daf7b9ab68350228c159766676a14f5815084ba166432aab46198d4cca98fa3e9981d0a90b2effc514b76279476550ba3663fdcaff94c38420e9d5000000000100093d00000000001976a9149a7b0f3b80c6baaeedce0a0842553800f832ba1f88ac00000000" - ) - , ( "f7fdd091fa6d8f5e7a8c2458f5c38faffff2d3f1406b6e4fe2c99dcc0d2d1cbb" - , "01000000023d6cf972d4dff9c519eff407ea800361dd0a121de1da8b6f4138a2f25de864b4000000008a4730440220ffda47bfc776bcd269da4832626ac332adfca6dd835e8ecd83cd1ebe7d709b0e022049cffa1cdc102a0b56e0e04913606c70af702a1149dc3b305ab9439288fee090014104266abb36d66eb4218a6dd31f09bb92cf3cfa803c7ea72c1fc80a50f919273e613f895b855fb7465ccbc8919ad1bd4a306c783f22cd3227327694c4fa4c1c439affffffff21ebc9ba20594737864352e95b727f1a565756f9d365083eb1a8596ec98c97b7010000008a4730440220503ff10e9f1e0de731407a4a245531c9ff17676eda461f8ceeb8c06049fa2c810220c008ac34694510298fa60b3f000df01caa244f165b727d4896eb84f81e46bcc4014104266abb36d66eb4218a6dd31f09bb92cf3cfa803c7ea72c1fc80a50f919273e613f895b855fb7465ccbc8919ad1bd4a306c783f22cd3227327694c4fa4c1c439affffffff01f0da5200000000001976a914857ccd42dded6df32949d4646dfa10a92458cfaa88ac00000000" - ) - , ( "afd9c17f8913577ec3509520bd6e5d63e9c0fd2a5f70c787993b097ba6ca9fae" - , "010000000370ac0a1ae588aaf284c308d67ca92c69a39e2db81337e563bf40c59da0a5cf63000000006a4730440220360d20baff382059040ba9be98947fd678fb08aab2bb0c172efa996fd8ece9b702201b4fb0de67f015c90e7ac8a193aeab486a1f587e0f54d0fb9552ef7f5ce6caec032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff7d815b6447e35fbea097e00e028fb7dfbad4f3f0987b4734676c84f3fcd0e804010000006b483045022100c714310be1e3a9ff1c5f7cacc65c2d8e781fc3a88ceb063c6153bf950650802102200b2d0979c76e12bb480da635f192cc8dc6f905380dd4ac1ff35a4f68f462fffd032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff3f1f097333e4d46d51f5e77b53264db8f7f5d2e18217e1099957d0f5af7713ee010000006c493046022100b663499ef73273a3788dea342717c2640ac43c5a1cf862c9e09b206fcb3f6bb8022100b09972e75972d9148f2bdd462e5cb69b57c1214b88fc55ca638676c07cfc10d8032103579ca2e6d107522f012cd00b52b9a65fb46f0c57b9b8b6e377c48f526a44741affffffff0380841e00000000001976a914bfb282c70c4191f45b5a6665cad1682f2c9cfdfb88ac80841e00000000001976a9149857cc07bed33a5cf12b9c5e0500b675d500c81188ace0fd1c00000000001976a91443c52850606c872403c0601e69fa34b26f62db4a88ac00000000" - ) - ] - -runPKHashVec :: ([(Text, Word32)], [(Text, Word64)], Text) -> Assertion -runPKHashVec (xs, ys, res) = - assertBool "Build PKHash Tx" $ encodeHex (S.encode tx) == res - where - tx = - fromRight (error "Could not decode transaction") $ - buildAddrTx btc (map f xs) ys - f (tid, ix) = OutPoint (fromJust $ hexToTxHash tid) ix - --- These test vectors have been generated from bitcoind raw transaction api - -pkHashVec :: [([(Text, Word32)], [(Text, Word64)], Text)] -pkHashVec = - [ - ( [("eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db",14)] - , [("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb",90000000)] - , "0100000001db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654a1eb29eb0e00000000ffffffff01804a5d05000000001976a91424aa604689cc582292b97668bedd91dd5bf9374c88ac00000000" - ) - , ( [ ("eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db",0) - , ("0001000000000000000000000000000000000000000000000000000000000000",2147483647) - ] - , [ ("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb",1) - , ("19VCgS642vzEA1sdByoSn6GsWBwraV8D4n",2100000000000000) - ] - , "0100000002db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654a1eb29eb0000000000ffffffff0000000000000000000000000000000000000000000000000000000000000100ffffff7f00ffffffff0201000000000000001976a91424aa604689cc582292b97668bedd91dd5bf9374c88ac0040075af07507001976a9145d16672f53981ff21c5f42b40d1954993cbca54f88ac00000000" - ) - , ( [ ("eb29eba154166f6541ebcc9cbdf5088756e026af051f123bcfb526df594549db",0) - , ("0001000000000000000000000000000000000000000000000000000000000000",2147483647) - ] - , [] - , "0100000002db494559df26b5cf3b121f05af26e0568708f5bd9ccceb41656f1654a1eb29eb0000000000ffffffff0000000000000000000000000000000000000000000000000000000000000100ffffff7f00ffffffff0000000000" - ) - , ( [] - , [ ("14LsRquZfURNFrzpcLVGdaHTfAPjjwiSPb",1) - , ("19VCgS642vzEA1sdByoSn6GsWBwraV8D4n",2100000000000000) - ] - , "01000000000201000000000000001976a91424aa604689cc582292b97668bedd91dd5bf9374c88ac0040075af07507001976a9145d16672f53981ff21c5f42b40d1954993cbca54f88ac00000000" - ) - ] - -tEncodeSatoshiCoreScriptPubKey :: Assertion -tEncodeSatoshiCoreScriptPubKey = assertBool "tEncodeSatoshiCoreScriptPubKey" $ - t1BsOutputScriptPubKey == encodeSatoshiCoreScriptPubKey t1SatoshiCoreJsonScriptPubKey - where - t1BsOutputScriptPubKey :: Text - t1BsOutputScriptPubKey = "514104cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef58bbfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d11fcdd0d348ac4410461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2fcfdeb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39f58b25c15342af52ae" - t1SatoshiCoreJsonScriptPubKey :: String - t1SatoshiCoreJsonScriptPubKey = "1 0x41 0x04cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef58bbfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d11fcdd0d348ac4 0x41 0x0461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2fcfdeb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39f58b25c15342af 2 OP_CHECKMULTISIG" - -encodeSatoshiCoreScriptPubKey :: String -> Text -encodeSatoshiCoreScriptPubKey = - mconcat . map encodeSatoshiCoreScriptPiece . words - where - encodeSatoshiCoreScriptPiece :: String -> Text - encodeSatoshiCoreScriptPiece s = case (readMay ("OP_" ++ s) :: Maybe ScriptOp) of - Just op -> encodeHex . S.encode $ op - Nothing -> case take 2 s of - "OP" -> encodeHex . S.encode . (read :: String -> ScriptOp) $ s - "0x" -> (fromString . drop 2 :: String -> Text) s - _ -> case (readMay s :: Maybe Int) of -- can we get rid of this case now? - Just i -> encodeHex . S.encode . intToScriptOp $ i - Nothing -> error $ "encodeSatoshiCoreScriptPubKey: " ++ s - --- --- Following tests depend on specific secp256k1 deterministic nonce computation. --- Fedora distributes the Bitcoin ABC fork of this library, which computes nonces differently. --- - --- -- Reproduce the P2WPKH example from BIP 143 --- testBip143p2wpkh :: Assertion --- testBip143p2wpkh = assertEqual "BIP143 p2wpkh" (Right exampleSignedTx) generatedSignedTx --- where --- exampleSignedTx = "01000000000102fff7f7881a8099afa6940d42d1e7f6362bec38171ea3edf433541db4e4ad969f00000000494830450221008b9d1dc26ba6a9cb62127b02742fa9d754cd3bebf337f7a55d114c8e5cdd30be022040529b194ba3f9281a99f2b1c0a19c0489bc22ede944ccf4ecbab4cc618ef3ed01eeffffffef51e1b804cc89d182d279655c3aa89e815b1b309fe287d9b2b55d57b90ec68a0100000000ffffffff02202cb206000000001976a9148280b37df378db99f66f85c95a783a76ac7a6d5988ac9093510d000000001976a9143bde42dbee7e4dbe6a21b2d50ce2f0167faa815988ac000247304402203609e17b84f6a7d30c80bfa610b5b4542f32a8a0d5447a12fb1366d7f01cc44a0220573a954c4518331561406f90300e8f3358f51928d43c212a8caed02de67eebee0121025476c2e83188368da1ff3e292e7acafcdb3566bb0ad253f62fc70f07aeee635711000000" - --- unsignedTx = "0100000002fff7f7881a8099afa6940d42d1e7f6362bec38171ea3edf433541db4e4ad969f0000000000eeffffffef51e1b804cc89d182d279655c3aa89e815b1b309fe287d9b2b55d57b90ec68a0100000000ffffffff02202cb206000000001976a9148280b37df378db99f66f85c95a783a76ac7a6d5988ac9093510d000000001976a9143bde42dbee7e4dbe6a21b2d50ce2f0167faa815988ac11000000" - --- Just key0 = secHexKey "bbc27228ddcb9209d7fd6f36b02f7dfa6252af40bb2f1cbc7a557da8027ff866" --- pubKey0 = toPubKey key0 - --- Just key1 = secHexKey "619c335025c7f4012e556c2a58b2506e30b8511b53ade95ea316fd8c3286feb9" - --- [op0, op1] = prevOutput <$> txIn unsignedTx - --- sigIn0 = SigInput (PayPK pubKey0) 625000000 op0 sigHashAll Nothing - --- WitnessPubKeyAddress h = pubKeyWitnessAddr $ toPubKey key1 --- 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 = assertEqual "BIP143 p2sh-p2wpkh" (Right exampleSignedTx) generatedSignedTx --- where --- exampleSignedTx = "01000000000101db6b1b20aa0fd7b23880be2ecbd4a98130974cf4748fb66092ac4d3ceb1a5477010000001716001479091972186c449eb1ded22b78e40d009bdf0089feffffff02b8b4eb0b000000001976a914a457b684d7f0d539a46a45bbc043f35b59d0d96388ac0008af2f000000001976a914fd270b1ee6abcaea97fea7ad0402e8bd8ad6d77c88ac02473044022047ac8e878352d3ebbde1c94ce3a10d057c24175747116f8288e5d794d12d482f0220217f36a485cae903c713331d877c1f64677e3622ad4010726870540656fe9dcb012103ad1d8e89212f0b92c74d23bb710c00662ad1470198ac48c43f7d6f93a2a2687392040000" - --- unsignedTx = "0100000001db6b1b20aa0fd7b23880be2ecbd4a98130974cf4748fb66092ac4d3ceb1a54770100000000feffffff02b8b4eb0b000000001976a914a457b684d7f0d539a46a45bbc043f35b59d0d96388ac0008af2f000000001976a914fd270b1ee6abcaea97fea7ad0402e8bd8ad6d77c88ac92040000" - --- Just key0 = secHexKey "eb696a065ef48a2192da5b28b694f87544b30fae8327c4510137a922f32c6dcf" - --- op0 = prevOutput . head $ txIn unsignedTx --- WitnessPubKeyAddress h = pubKeyWitnessAddr $ toPubKey key0 --- 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 = assertEqual "p2wsh multisig" (Right exampleSignedTx) generatedSignedTx --- where --- exampleSignedTx = "01000000000101d2e34df5d7ee565208eddd231548916b9b0e99f4f5071f896134a448c5fb07bf0100000000ffffffff01f0b9f505000000001976a9143d5a352cab583b12fbcb26d1269b4a2c951a33ad88ac0400483045022100fad4fedd2bb4c439c64637eb8e9150d9020a7212808b8dc0578d5ff5b4ad65fe0220714640f261b37eb3106310bf853f4b706e51436fb6b64c2ab00768814eb55b9801473044022100baff4e4ceea4022b9725a2e6f6d77997a554f858165b91ac8c16c9833008bee9021f5f70ebc3f8580dc0a5e96451e3697bdf1f1f5883944f0f33ab0cfb272354040169522102ba46d3bb8db74c77c6cf082db57fc0548058fcdea811549e186526e3d10caf6721038ac8aef2dd9cea5e7d66e2f6e23f177a6c21f69ea311fa0c85d81badb6b37ceb2103d96d2bfbbc040faaf93491d69e2bfe9695e2d8e007a7f26db96c2ee42db15dc953ae00000000" - --- unsignedTx = "0100000001d2e34df5d7ee565208eddd231548916b9b0e99f4f5071f896134a448c5fb07bf0100000000ffffffff01f0b9f505000000001976a9143d5a352cab583b12fbcb26d1269b4a2c951a33ad88ac00000000" - --- op0 = head $ prevOutput <$> txIn unsignedTx - --- Just keys = traverse secHexKey [ "3030303030303030303030303030303030303030303030303030303030303031" --- , "3030303030303030303030303030303030303030303030303030303030303032" --- , "3030303030303030303030303030303030303030303030303030303030303033" --- ] - --- rdm = PayMulSig (toPubKey <$> keys) 2 --- sigIn = SigInput (toP2WSH $ encodeOutput rdm) 100000000 op0 sigHashAll (Just rdm) --- generatedSignedTx = signTx btc unsignedTx [sigIn] (take 2 keys) - --- -- Reproduce the P2SH-P2WSH multisig example from BIP 143 --- testBip143p2shp2wpkhMulsig :: Assertion --- testBip143p2shp2wpkhMulsig = --- assertEqual "BIP143 p2sh-p2wsh multisig" (Right exampleSignedTx) generatedSignedTx --- where --- exampleSignedTx = "0100000000010136641869ca081e70f394c6948e8af409e18b619df2ed74aa106c1ca29787b96e0100000023220020a16b5755f7f6f96dbd65f5f0d6ab9418b89af4b1f14a1bb8a09062c35f0dcb54ffffffff0200e9a435000000001976a914389ffce9cd9ae88dcc0631e88a821ffdbe9bfe2688acc0832f05000000001976a9147480a33f950689af511e6e84c138dbbd3c3ee41588ac080047304402206ac44d672dac41f9b00e28f4df20c52eeb087207e8d758d76d92c6fab3b73e2b0220367750dbbe19290069cba53d096f44530e4f98acaa594810388cf7409a1870ce01473044022068c7946a43232757cbdf9176f009a928e1cd9a1a8c212f15c1e11ac9f2925d9002205b75f937ff2f9f3c1246e547e54f62e027f64eefa2695578cc6432cdabce271502473044022059ebf56d98010a932cf8ecfec54c48e6139ed6adb0728c09cbe1e4fa0915302e022007cd986c8fa870ff5d2b3a89139c9fe7e499259875357e20fcbb15571c76795403483045022100fbefd94bd0a488d50b79102b5dad4ab6ced30c4069f1eaa69a4b5a763414067e02203156c6a5c9cf88f91265f5a942e96213afae16d83321c8b31bb342142a14d16381483045022100a5263ea0553ba89221984bd7f0b13613db16e7a70c549a86de0cc0444141a407022005c360ef0ae5a5d4f9f2f87a56c1546cc8268cab08c73501d6b3be2e1e1a8a08824730440220525406a1482936d5a21888260dc165497a90a15669636d8edca6b9fe490d309c022032af0c646a34a44d1f4576bf6a4a74b67940f8faa84c7df9abe12a01a11e2b4783cf56210307b8ae49ac90a048e9b53357a2354b3334e9c8bee813ecb98e99a7e07e8c3ba32103b28f0c28bfab54554ae8c658ac5c3e0ce6e79ad336331f78c428dd43eea8449b21034b8113d703413d57761b8b9781957b8c0ac1dfe69f492580ca4195f50376ba4a21033400f6afecb833092a9a21cfdf1ed1376e58c5d1f47de74683123987e967a8f42103a6d48b1131e94ba04d9737d61acdaa1322008af9602b3b14862c07a1789aac162102d8b661b0b3302ee2f162b09e07a55ad5dfbe673a9f01d9f0c19617681024306b56ae00000000" - --- unsignedTx = "010000000136641869ca081e70f394c6948e8af409e18b619df2ed74aa106c1ca29787b96e0100000000ffffffff0200e9a435000000001976a914389ffce9cd9ae88dcc0631e88a821ffdbe9bfe2688acc0832f05000000001976a9147480a33f950689af511e6e84c138dbbd3c3ee41588ac00000000" - --- op0 = head $ prevOutput <$> txIn unsignedTx - --- rawKeys = [ "730fff80e1413068a05b57d6a58261f07551163369787f349438ea38ca80fac6" --- , "11fa3d25a17cbc22b29c44a484ba552b5a53149d106d3d853e22fdd05a2d8bb3" --- , "77bf4141a87d55bdd7f3cd0bdccf6e9e642935fec45f2f30047be7b799120661" --- , "14af36970f5025ea3e8b5542c0f8ebe7763e674838d08808896b63c3351ffe49" --- , "fe9a95c19eef81dde2b95c1284ef39be497d128e2aa46916fb02d552485e0323" --- , "428a7aee9f0c2af0cd19af3cf1c78149951ea528726989b2e83e4778d2c3f890" --- ] - --- Just keys@[key0, key1, key2, key3, key4, key5] = traverse secHexKey rawKeys - --- rdm = PayMulSig (toPubKey <$> keys) 6 --- sigIn sh = SigInput (toP2WSH $ encodeOutput rdm) 987654321 op0 sh (Just rdm) - --- sigHashesA = [sigHashAll, sigHashNone, sigHashSingle] --- sigHashesB = setAnyoneCanPayFlag <$> sigHashesA --- sigIns = sigIn <$> (sigHashesA <> sigHashesB) - --- 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 - -{- Building Transactions -} - -testBuildAddrTx :: Network -> Address -> TestCoin -> Bool -testBuildAddrTx net a (TestCoin v) - | isPubKeyAddress a = Right (PayPKHash (getAddrHash160 a)) == out - | isScriptAddress a = Right (PayScriptHash (getAddrHash160 a)) == out - | otherwise = undefined - where - tx = buildAddrTx net [] [(fromJust (addrToString net a), v)] - out = - decodeOutputBS $ - scriptOutput $ - head $ txOut (fromRight (error "Could not build transaction") tx) - -testGuessSize :: Network -> Tx -> Bool -testGuessSize net 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) - = guess >= len && guess <= len + 2 * delta - where - delta = pki + sum (map fst msi) - guess = guessTxSize pki msi pkout msout - len = B.length $ S.encode tx - ins = map f $ txIn tx - f i = - fromRight (error "Could not decode input") $ - decodeInputBS net $ scriptInput i - pki = length $ filter isSpendPKHash ins - msi = concatMap shData ins - shData (ScriptHashInput _ (PayMulSig keys r)) = [(r, length keys)] - shData _ = [] - out = - map - (fromRight (error "Could not decode transaction output") . - decodeOutputBS . scriptOutput) $ - txOut tx - pkout = length $ filter isPayPKHash out - msout = length $ filter isPayScriptHash out - -testChooseCoins :: [TestCoin] -> Word64 -> Word64 -> Int -> Property -testChooseCoins coins target byteFee nOut = nOut >= 0 ==> - case chooseCoins target byteFee nOut True coins of - Right (chosen, change) -> - let outSum = sum $ map coinValue chosen - fee = guessTxFee byteFee nOut (length chosen) - in outSum == target + change + fee - Left _ -> - let fee = guessTxFee byteFee nOut (length coins) - in target == 0 || s < target + fee - where - s = sum $ map coinValue coins - -testChooseMSCoins :: (Int, Int) -> [TestCoin] - -> Word64 -> Word64 -> Int -> Property -testChooseMSCoins (m, n) coins target byteFee nOut = nOut >= 0 ==> - case chooseMSCoins target byteFee (m,n) nOut True coins of - Right (chosen,change) -> - let outSum = sum $ map coinValue chosen - fee = guessMSTxFee byteFee (m,n) nOut (length chosen) - in outSum == target + change + fee - Left _ -> - let fee = guessMSTxFee byteFee (m,n) nOut (length coins) - in target == 0 || s < target + fee - where - s = sum $ map coinValue coins - -{- Signing Transactions -} - -testDetSignTx :: Network -> (Tx, [SigInput], [SecKeyI]) -> Bool -testDetSignTx net (tx, sigis, prv) = - not (verifyStdTx net tx verData) && - not (verifyStdTx net txSigP verData) && verifyStdTx net txSigC verData - where - txSigP = - fromRight (error "Could not decode transaction") $ - signTx net tx sigis (map secKeyData (tail prv)) - txSigC = - fromRight (error "Could not decode transaction") $ - signTx net txSigP sigis [secKeyData (head prv)] - verData = map (\(SigInput s v o _ _) -> (s, v, o)) sigis - -testDetSignNestedTx :: Network -> (Tx, [SigInput], [SecKeyI]) -> Bool -testDetSignNestedTx net (tx, sigis, prv) = - not (verifyStdTx net tx verData) && - not (verifyStdTx net txSigP verData) && verifyStdTx net txSigC verData - where - txSigP = - fromRight (error "Could not decode transaction") $ - signNestedWitnessTx net tx sigis (secKeyData <$> tail prv) - txSigC = - fromRight (error "Could not decode transaction") $ - signNestedWitnessTx net txSigP sigis [secKeyData (head prv)] - verData = handleSegwit <$> sigis - handleSegwit (SigInput s v o _ _) - | 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 - [ isRight mergeRes - , length (txIn mergedTx) == length os - , if enoughSigs then isValid else not isValid - -- Signature count == min (length txs) (sum required signatures) - , sum (map snd sigMap) == min (length txs) (sum (map fst sigMap)) - ] - where - outs = map (\(so, val, op, _, _) -> (so, val, op)) os - mergeRes = mergeTxs net txs outs - mergedTx = fromRight (error "Could not merge") mergeRes - isValid = verifyStdTx net mergedTx outs - enoughSigs = all (\(m,c) -> c >= m) sigMap - sigMap = map (\((_,_,_,m,_), inp) -> (m, sigCnt inp)) $ zip os $ txIn mergedTx - sigCnt inp = case decodeInputBS net $ scriptInput inp of - Right (RegularInput (SpendMulSig sigs)) -> length sigs - Right (ScriptHashInput (SpendMulSig sigs) _) -> length sigs - _ -> error "Invalid input script type" - -testID :: (FromJSON a, ToJSON a, Eq a) => a -> Bool -testID x = - (A.decode . A.encode) (singleton ("object" :: String) x) == - Just (singleton ("object" :: String) x) diff --git a/test/Network/Haskoin/UtilSpec.hs b/test/Network/Haskoin/UtilSpec.hs deleted file mode 100644 --- a/test/Network/Haskoin/UtilSpec.hs +++ /dev/null @@ -1,64 +0,0 @@ -module Network.Haskoin.UtilSpec (spec) where - -import qualified Data.ByteString as BS -import Data.Either (fromLeft, fromRight, isLeft, isRight) -import Data.Foldable (toList) -import Data.List (permutations) -import Data.Maybe -import qualified Data.Sequence as Seq -import Network.Haskoin.Test -import Network.Haskoin.Util -import Test.Hspec -import Test.QuickCheck - -spec :: Spec -spec = - describe "utility functions" $ do - it "bsToInteger . integerToBS" $ property getPutInteger - it "decodeHex . encodeHex" $ property $ forAll arbitraryBS fromToHex - it "compare updateIndex with Data.Sequence" $ property testUpdateIndex - it "matchTemplate" $ property testMatchTemplate - it "testing matchTemplate with two lists" $ - property testMatchTemplateLen - it "either helper functions" $ property testEither - -{- 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 - res = matchTemplate as bs (==) - idx = - if null as - then 0 - 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 (==) - -testEither :: Either String Int -> Bool -testEither e = - case e of - (Right v) -> - isRight e && - not (isLeft e) && - fromRight (error "Unexpected Left") e == v && - eitherToMaybe e == Just v - (Left v) -> - isLeft e && - not (isRight e) && - fromLeft (error "Unexpected Right") e == v && - isNothing (eitherToMaybe e)