diff --git a/haskoin-core.cabal b/bitcoin.cabal similarity index 86% rename from haskoin-core.cabal rename to bitcoin.cabal index 9a6265cf..45db95de 100644 --- a/haskoin-core.cabal +++ b/bitcoin.cabal @@ -4,17 +4,18 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -name: haskoin-core +name: bitcoin version: 0.21.2 -synopsis: Bitcoin & Bitcoin Cash library for Haskell -description: Please see the README on GitHub at +synopsis: Bitcoin library for Haskell +description: Please see the README on GitHub at category: Bitcoin, Finance, Network -homepage: http://github.com/haskoin/haskoin#readme -bug-reports: http://github.com/haskoin/haskoin/issues +homepage: http://github.com/haskell-bitcoin/bitcoin#readme +bug-reports: http://github.com/haskell-bitcoin/bitcoin/issues author: Philippe Laprade, Jean-Pierre Rupp, - Matthew Wraith -maintainer: jprupp@protonmail.ch + Matthew Wraith, + Keagan McClelland +maintainer: keagan.mcclelland@gmail.com license: MIT license-file: LICENSE build-type: Simple @@ -38,7 +39,7 @@ extra-source-files: source-repository head type: git - location: git://github.com/haskoin/haskoin.git + location: git://github.com/haskell-bitcoin/bitcoin.git library exposed-modules: @@ -46,7 +47,6 @@ library Haskoin.Address Haskoin.Address.Base58 Haskoin.Address.Bech32 - Haskoin.Address.CashAddr Haskoin.Block Haskoin.Block.Common Haskoin.Block.Headers @@ -93,15 +93,11 @@ library src build-depends: QuickCheck >=2.13.2 - , aeson >=1.4.6.0 , array >=0.5.4.0 , base >=4.9 && <5 , base16 >=0.3.0.1 - , binary >=0.8.8 , bytes >=0.17 , bytestring >=0.10.10.0 - , cereal >=0.5.8 - , conduit >=1.3.1.2 , containers >=0.6.2.1 , cryptonite >=0.26 , deepseq >=1.4.4.0 @@ -109,7 +105,6 @@ library , hashable >=1.3.0.0 , hspec >=2.7.1 , memory >=0.15.0 - , mtl >=2.2.2 , murmur3 >=1.0.3 , network >=3.1.1.1 , safe >=0.3.18 @@ -129,7 +124,6 @@ test-suite spec main-is: Spec.hs other-modules: Haskoin.Address.Bech32Spec - Haskoin.Address.CashAddrSpec Haskoin.AddressSpec Haskoin.BlockSpec Haskoin.Crypto.HashSpec @@ -143,33 +137,28 @@ test-suite spec Haskoin.Transaction.TaprootSpec Haskoin.TransactionSpec Haskoin.UtilSpec - Paths_haskoin_core + Paths_bitcoin hs-source-dirs: test build-depends: HUnit >=1.6.0.0 , QuickCheck >=2.13.2 - , aeson >=1.4.6.0 , array >=0.5.4.0 , base >=4.9 && <5 , base16 >=0.3.0.1 , base64 ==0.4.* - , binary >=0.8.8 + , bitcoin , bytes >=0.17 , bytestring >=0.10.10.0 - , cereal >=0.5.8 - , conduit >=1.3.1.2 , containers >=0.6.2.1 , cryptonite >=0.26 , deepseq >=1.4.4.0 , entropy >=0.4.1.5 , hashable >=1.3.0.0 - , haskoin-core , hspec >=2.7.1 , lens >=4.18.1 , lens-aeson >=1.1 , memory >=0.15.0 - , mtl >=2.2.2 , murmur3 >=1.0.3 , network >=3.1.1.1 , safe >=0.3.18 diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 00000000..71a53840 --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,8 @@ +indentation: 4 +comma-style: leading +record-brace-space: false +indent-wheres: true +diff-friendly-import-export: true +respectful: true +haddock-style: single-line +newlines-between-decls: 2 diff --git a/package.yaml b/package.yaml index 84d7d563..9c73976a 100644 --- a/package.yaml +++ b/package.yaml @@ -1,32 +1,29 @@ -name: haskoin-core +name: bitcoin version: 0.21.2 -synopsis: Bitcoin & Bitcoin Cash library for Haskell -description: Please see the README on GitHub at +synopsis: Bitcoin library for Haskell +description: Please see the README on GitHub at category: Bitcoin, Finance, Network author: - Philippe Laprade - Jean-Pierre Rupp - Matthew Wraith -maintainer: jprupp@protonmail.ch + - Keagan McClelland +maintainer: keagan.mcclelland@gmail.com license: MIT license-file: LICENSE -homepage: http://github.com/haskoin/haskoin#readme -git: git://github.com/haskoin/haskoin.git -bug-reports: http://github.com/haskoin/haskoin/issues +homepage: http://github.com/haskell-bitcoin/bitcoin#readme +git: git://github.com/haskell-bitcoin/bitcoin.git +bug-reports: http://github.com/haskell-bitcoin/bitcoin/issues extra-source-files: - data/*.json - README.md - CHANGELOG.md dependencies: - - aeson >= 1.4.6.0 - array >= 0.5.4.0 - base >=4.9 && <5 - base16 >= 0.3.0.1 - - binary >= 0.8.8 - bytes >= 0.17 - bytestring >= 0.10.10.0 - - cereal >= 0.5.8 - - conduit >= 1.3.1.2 - containers >= 0.6.2.1 - cryptonite >= 0.26 - deepseq >= 1.4.4.0 @@ -34,7 +31,6 @@ dependencies: - hashable >= 1.3.0.0 - hspec >= 2.7.1 - memory >= 0.15.0 - - mtl >= 2.2.2 - murmur3 >= 1.0.3 - network >= 3.1.1.1 - QuickCheck >= 2.13.2 @@ -50,21 +46,19 @@ dependencies: - vector >= 0.12.1.2 library: source-dirs: src - other-modules: - Haskoin.Keys.Extended.Internal + other-modules: Haskoin.Keys.Extended.Internal when: - condition: false - other-modules: Paths_haskoin_core + other-modules: Paths_bitcoin tests: spec: main: Spec.hs source-dirs: test verbatim: - build-tool-depends: - hspec-discover:hspec-discover + build-tool-depends: hspec-discover:hspec-discover dependencies: - base64 ^>= 0.4 - - haskoin-core + - bitcoin - hspec >= 2.7.1 - HUnit >= 1.6.0.0 - QuickCheck >= 2.13.2 diff --git a/src/Haskoin/Address.hs b/src/Haskoin/Address.hs index c0ee8ed8..28b4a2fd 100644 --- a/src/Haskoin/Address.hs +++ b/src/Haskoin/Address.hs @@ -5,16 +5,15 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{- | -Module : Haskoin.Address -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Base58, CashAddr, Bech32 address and WIF private key serialization support. --} +-- | +--Module : Haskoin.Address +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX +-- +--Base58, CashAddr, Bech32 address and WIF private key serialization support. module Haskoin.Address ( -- * Addresses Address (..), @@ -26,11 +25,7 @@ module Haskoin.Address ( addrToText, textToAddr, bech32ToAddr, - cashToAddr, base58ToAddr, - addrToJSON, - addrToEncoding, - addrFromJSON, pubKeyAddr, pubKeyWitnessAddr, pubKeyCompatWitnessAddr, @@ -50,17 +45,12 @@ module Haskoin.Address ( scriptToAddressBS, module Haskoin.Address.Base58, module Haskoin.Address.Bech32, - module Haskoin.Address.CashAddr, ) where import Control.Applicative import Control.Arrow (second) import Control.DeepSeq import Control.Monad -import Data.Aeson as A -import Data.Aeson.Encoding as A -import Data.Aeson.Types -import Data.Binary (Binary (..)) import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.Bytes.Get @@ -68,20 +58,19 @@ import Data.Bytes.Put import Data.Bytes.Serial import Data.Hashable import Data.Maybe -import Data.Serialize (Serialize (..)) import Data.Text (Text) import qualified Data.Text as T import Data.Word (Word8) import GHC.Generics (Generic) import Haskoin.Address.Base58 import Haskoin.Address.Bech32 -import Haskoin.Address.CashAddr import Haskoin.Crypto import Haskoin.Data import Haskoin.Keys.Common import Haskoin.Script import Haskoin.Util + -- | Address format for Bitcoin and Bitcoin Cash. data Address = -- | pay to public key hash (regular) @@ -112,6 +101,7 @@ data Address deriving (Eq, Ord, Generic, Show, Read, Hashable, NFData) + instance Serial Address where serialize (PubKeyAddress k) = do putWord8 0x00 @@ -131,6 +121,7 @@ instance Serial Address where putWord64be (fromIntegral (B.length d)) putByteString d + deserialize = getWord8 >>= \case 0x00 -> PubKeyAddress <$> deserialize @@ -145,68 +136,41 @@ instance Serial Address where "Could not decode address type byte: " <> encodeHex (B.singleton b) -instance Serialize Address where - put = serialize - get = deserialize - -instance Binary Address where - put = serialize - get = deserialize -- | 'Address' pays to a public key hash. isPubKeyAddress :: Address -> Bool isPubKeyAddress PubKeyAddress{} = True isPubKeyAddress _ = False + -- | 'Address' pays to a script hash. isScriptAddress :: Address -> Bool isScriptAddress ScriptAddress{} = True isScriptAddress _ = False -{- | 'Address' pays to a witness public key hash. Only valid for SegWit - networks. --} + +-- | 'Address' pays to a witness public key hash. Only valid for SegWit +-- networks. isWitnessPubKeyAddress :: Address -> Bool isWitnessPubKeyAddress WitnessPubKeyAddress{} = True isWitnessPubKeyAddress _ = False + isWitnessScriptAddress :: Address -> Bool isWitnessScriptAddress WitnessScriptAddress{} = True isWitnessScriptAddress _ = False + isWitnessAddress :: Address -> Bool isWitnessAddress WitnessAddress{} = True isWitnessAddress _ = False -addrToJSON :: Network -> Address -> Value -addrToJSON net a = toJSON (addrToText net a) - -addrToEncoding :: Network -> Address -> Encoding -addrToEncoding net = maybe null_ text . addrToText net - -{- | JSON parsing for Bitcoin addresses. Works with 'Base58', 'CashAddr' and - 'Bech32'. --} -addrFromJSON :: Network -> Value -> Parser Address -addrFromJSON net = - withText "address" $ \t -> - case textToAddr net t of - Nothing -> fail "could not decode address" - Just x -> return x - -{- | Convert address to human-readable string. Uses 'Base58', 'Bech32', or - 'CashAddr' depending on network. --} + +-- | Convert address to human-readable string. Uses 'Base58', 'Bech32', or +-- 'CashAddr' depending on network. addrToText :: Network -> Address -> Maybe Text -addrToText net a@PubKeyAddress{getAddrHash160 = h} - | isNothing (getCashAddrPrefix net) = - Just . encodeBase58Check . runPutS $ base58put net a - | otherwise = cashAddrEncode net 0 (runPutS $ serialize h) -addrToText net a@ScriptAddress{getAddrHash160 = h} - | isNothing (getCashAddrPrefix net) = - Just . encodeBase58Check . runPutS $ base58put net a - | otherwise = - cashAddrEncode net 1 (runPutS $ serialize h) +addrToText net a@PubKeyAddress{getAddrHash160 = h} = Just . encodeBase58Check . runPutS $ base58put net a +addrToText net a@ScriptAddress{getAddrHash160 = h} = Just . encodeBase58Check . runPutS $ base58put net a addrToText net WitnessPubKeyAddress{getAddrHash160 = h} = do hrp <- getBech32Prefix net segwitEncode hrp 0 (B.unpack (runPutS $ serialize h)) @@ -217,18 +181,12 @@ addrToText net WitnessAddress{getAddrVersion = v, getAddrData = d} = do hrp <- getBech32Prefix net segwitEncode hrp v (B.unpack d) + -- | Parse 'Base58', 'Bech32' or 'CashAddr' address, depending on network. textToAddr :: Network -> Text -> Maybe Address textToAddr net txt = - cashToAddr net txt <|> bech32ToAddr net txt <|> base58ToAddr net txt + bech32ToAddr net txt <|> base58ToAddr net txt -cashToAddr :: Network -> Text -> Maybe Address -cashToAddr net txt = do - (ver, bs) <- cashAddrDecode net txt - case ver of - 0 -> PubKeyAddress <$> eitherToMaybe (runGetS deserialize bs) - 1 -> ScriptAddress <$> eitherToMaybe (runGetS deserialize bs) - _ -> Nothing bech32ToAddr :: Network -> Text -> Maybe Address bech32ToAddr net txt = do @@ -241,20 +199,23 @@ bech32ToAddr net txt = do _ -> Nothing _ -> Just $ WitnessAddress ver bs + base58ToAddr :: Network -> Text -> Maybe Address base58ToAddr net txt = eitherToMaybe . runGetS (base58get net) =<< decodeBase58Check txt + base58get :: MonadGet m => Network -> m Address base58get net = do pfx <- getWord8 addr <- deserialize f pfx addr - where - f x a - | x == getAddrPrefix net = return $ PubKeyAddress a - | x == getScriptPrefix net = return $ ScriptAddress a - | otherwise = fail "Does not recognize address prefix" + where + f x a + | x == getAddrPrefix net = return $ PubKeyAddress a + | x == getScriptPrefix net = return $ ScriptAddress a + | otherwise = fail "Does not recognize address prefix" + base58put :: MonadPut m => Network -> Address -> m () base58put net (PubKeyAddress h) = do @@ -265,20 +226,23 @@ base58put net (ScriptAddress h) = do serialize h base58put _ _ = error "Cannot serialize this address as Base58" + -- | Obtain a standard pay-to-public-key-hash address from a public key. pubKeyAddr :: PubKeyI -> Address pubKeyAddr = PubKeyAddress . addressHash . runPutS . serialize + -- | Obtain a standard pay-to-public-key-hash (P2PKH) address from a 'Hash160'. p2pkhAddr :: Hash160 -> Address p2pkhAddr = PubKeyAddress -{- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a - public key. --} + +-- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a +-- public key. pubKeyWitnessAddr :: PubKeyI -> Address pubKeyWitnessAddr = WitnessPubKeyAddress . addressHash . runPutS . serialize + -- | Obtain a backwards-compatible SegWit P2SH-P2WPKH address from a public key. pubKeyCompatWitnessAddr :: PubKeyI -> Address pubKeyCompatWitnessAddr = @@ -290,38 +254,42 @@ pubKeyCompatWitnessAddr = . runPutS . serialize -{- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a - 'Hash160'. --} + +-- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a +-- 'Hash160'. p2wpkhAddr :: Hash160 -> Address p2wpkhAddr = WitnessPubKeyAddress + -- | Obtain a standard pay-to-script-hash (P2SH) address from a 'Hash160'. p2shAddr :: Hash160 -> Address p2shAddr = ScriptAddress + -- | Obtain a SegWit pay-to-witness-script-hash (P2WSH) address from a 'Hash256' p2wshAddr :: Hash256 -> Address p2wshAddr = WitnessScriptAddress + -- | Compute a standard pay-to-script-hash (P2SH) address for an output script. payToScriptAddress :: ScriptOutput -> Address payToScriptAddress = p2shAddr . addressHash . encodeOutputBS -{- | Compute a SegWit pay-to-witness-script-hash (P2WSH) address for an output - script. --} + +-- | Compute a SegWit pay-to-witness-script-hash (P2WSH) address for an output +-- script. payToWitnessScriptAddress :: ScriptOutput -> Address payToWitnessScriptAddress = p2wshAddr . sha256 . encodeOutputBS + -- | Compute a backwards-compatible SegWit P2SH-P2WSH address. payToNestedScriptAddress :: ScriptOutput -> Address payToNestedScriptAddress = p2shAddr . addressHash . encodeOutputBS . toP2WSH . encodeOutput -{- | Encode an output script from an address. Will fail if using a - pay-to-witness address on a non-SegWit network. --} + +-- | Encode an output script from an address. Will fail if using a +-- pay-to-witness address on a non-SegWit network. addressToOutput :: Address -> ScriptOutput addressToOutput = \case @@ -331,24 +299,29 @@ addressToOutput = WitnessScriptAddress h -> PayWitnessScriptHash h WitnessAddress v d -> PayWitness v d + -- | Get output script AST for an 'Address'. addressToScript :: Address -> Script addressToScript = encodeOutput . addressToOutput + -- | Encode address as output script in 'ByteString' form. addressToScriptBS :: Address -> ByteString addressToScriptBS = runPutS . serialize . addressToScript + -- | Decode an output script into an 'Address' if it has such representation. scriptToAddress :: Script -> Either String Address scriptToAddress = maybeToEither "Could not decode address" . outputAddress <=< decodeOutput + -- | Decode a serialized script into an 'Address'. scriptToAddressBS :: ByteString -> Either String Address scriptToAddressBS = maybeToEither "Could not decode address" . outputAddress <=< decodeOutputBS + -- | Get the 'Address' of a 'ScriptOutput'. outputAddress :: ScriptOutput -> Maybe Address outputAddress = @@ -361,6 +334,7 @@ outputAddress = PayWitness v d -> Just $ WitnessAddress v d _ -> Nothing + -- | Infer the 'Address' of a 'ScriptInput'. inputAddress :: ScriptInput -> Maybe Address inputAddress = diff --git a/src/Haskoin/Address/Base58.hs b/src/Haskoin/Address/Base58.hs index 951aa128..fc614d1e 100644 --- a/src/Haskoin/Address/Base58.hs +++ b/src/Haskoin/Address/Base58.hs @@ -1,16 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} -{- | -Module : Haskoin.Address.Base58 -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Support for legacy 'Base58' addresses. Superseded by Bech32 for Bitcoin SegWit -(BTC) and CashAddr for Bitcoin Cash (BCH). --} +-- | +--Module : Haskoin.Address.Base58 +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX +-- +--Support for legacy 'Base58' addresses. Superseded by Bech32 for Bitcoin module Haskoin.Address.Base58 ( -- * Base58 Base58, @@ -38,84 +36,91 @@ import Haskoin.Crypto.Hash import Haskoin.Util import Numeric (readInt, showIntAtBase) + -- | 'Base58' classic Bitcoin address format. type Base58 = Text + -- | Symbols for Base58 encoding. b58Data :: ByteString b58Data = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz" + b58Array :: Array Int Word8 b58Array = listArray (0, 57) (BS.unpack b58Data) + b58InvArray :: Array Word8 (Maybe Int) b58InvArray = listArray (minBound, maxBound) (repeat Nothing) // map swap (assocs b58Array) - where - swap (i, c) = (c, Just i) + where + swap (i, c) = (c, Just i) -{- | Convert a number less than or equal to provided integer into a 'Base58' - character. --} + +-- | Convert a number less than or equal to provided integer into a 'Base58' +-- character. b58 :: Int -> Word8 b58 = (b58Array !) + -- | Convert a 'Base58' character into the number it represents. b58' :: Word8 -> Maybe Int b58' = (b58InvArray !) -{- | Encode an arbitrary-length 'Integer' into a 'Base58' string. Leading zeroes - will not be part of the resulting string. --} + +-- | Encode an arbitrary-length 'Integer' into a 'Base58' string. Leading zeroes +-- will not be part of the resulting string. encodeBase58I :: Integer -> Base58 encodeBase58I i = cs $ showIntAtBase 58 (chr . fromIntegral . b58) i "" + -- | Decode a 'Base58' string into an arbitrary-length 'Integer'. decodeBase58I :: Base58 -> Maybe Integer decodeBase58I s = case go of Just (r, []) -> Just r _ -> Nothing - where - p = isJust . b58' . fromIntegral . ord - f = fromMaybe e . b58' . fromIntegral . ord - go = listToMaybe $ readInt 58 p f (cs s) - e = error "Could not decode base58" - -{- | Encode an arbitrary 'ByteString' into a its 'Base58' representation, - preserving leading zeroes. --} + where + p = isJust . b58' . fromIntegral . ord + f = fromMaybe e . b58' . fromIntegral . ord + go = listToMaybe $ readInt 58 p f (cs s) + e = error "Could not decode base58" + + +-- | Encode an arbitrary 'ByteString' into a its 'Base58' representation, +-- preserving leading zeroes. encodeBase58 :: ByteString -> Base58 encodeBase58 bs = l <> r - where - (z, b) = BS.span (== 0) bs - l = cs $ BS.replicate (BS.length z) (b58 0) -- preserve leading 0's - r - | BS.null b = T.empty - | otherwise = encodeBase58I $ bsToInteger b + where + (z, b) = BS.span (== 0) bs + l = cs $ BS.replicate (BS.length z) (b58 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 (== b58 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'. --} + where + (z, b) = BS.span (== b58 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 $ runPutS $ serialize $ checkSum32 bs -{- | Decode a 'Base58'-encoded string that contains a checksum. This function - returns 'Nothing' if the input string contains invalid 'Base58' characters or - if the checksum fails. --} + +-- | Decode a 'Base58'-encoded string that contains a checksum. This function +-- returns 'Nothing' if the input string contains invalid 'Base58' characters or +-- if the checksum fails. decodeBase58Check :: Base58 -> Maybe ByteString decodeBase58Check bs = do rs <- decodeBase58 bs diff --git a/src/Haskoin/Address/CashAddr.hs b/src/Haskoin/Address/CashAddr.hs deleted file mode 100644 index 4b01ba5e..00000000 --- a/src/Haskoin/Address/CashAddr.hs +++ /dev/null @@ -1,219 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{- | -Module : Haskoin.Address.CashAddr -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Support for Bitcoin Cash (BCH) CashAddr format. --} -module Haskoin.Address.CashAddr ( - -- * CashAddr - CashPrefix, - CashVersion, - CashAddr, - Cash32, - cashAddrDecode, - cashAddrEncode, - cash32decodeType, - cash32encodeType, - cash32decode, - cash32encode, -) where - -import Control.Monad -import Data.Bits -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as C -import Data.Char -import Data.List -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as E -import Data.Word -import Haskoin.Data -import Haskoin.Util - -{- | 'CashAddr' prefix, usually shown before the colon in addresses, but sometimes - omitted. It is used in the checksum calculation to avoid parsing an address - from the wrong network. --} -type CashPrefix = Text - --- | 'CashAddr' version, until new address schemes appear it will be zero. -type CashVersion = Word8 - --- | High level 'CashAddr' human-reabale string, with explicit or implicit prefix. -type CashAddr = Text - -{- | Low level 'Cash32' is the human-readable low-level encoding used by 'CashAddr'. It - need not encode a valid address but any binary data. --} -type Cash32 = Text - --- | Symbols for encoding 'Cash32' data in human-readable strings. -charset :: String -charset = "qpzry9x8gf2tvdw0s3jn54khce6mua7l" - --- | Get the 32-bit number associated with this 'Cash32' character. -base32char :: Char -> Maybe Word8 -base32char = fmap fromIntegral . (`elemIndex` charset) - -{- | High-Level: decode 'CashAddr' string if it is valid for the - provided 'Network'. Prefix may be omitted from the string. --} -cashAddrDecode :: Network -> CashAddr -> Maybe (CashVersion, ByteString) -cashAddrDecode net ca = do - epfx <- getCashAddrPrefix net - let (cpfx, cdat) = T.breakOnEnd ":" (T.toLower ca) - guard (T.null cpfx || T.init cpfx == epfx) - (dpfx, ver, bs) <- cash32decodeType (epfx <> ":" <> cdat) - guard (dpfx == epfx) - return (ver, bs) - -{- | High-Level: encode 'CashAddr' string for the provided network and hash. - Fails if the 'CashVersion' or length of hash 'ByteString' is invalid. --} -cashAddrEncode :: Network -> CashVersion -> ByteString -> Maybe CashAddr -cashAddrEncode net cv bs = do - pfx <- getCashAddrPrefix net - cash32encodeType pfx cv bs - -{- | Mid-Level: decode 'CashAddr' string containing arbitrary prefix, plus a - version byte before the 'ByteString' that encodes type and length. --} -cash32decodeType :: Cash32 -> Maybe (CashPrefix, CashVersion, ByteString) -cash32decodeType ca' = do - guard (T.toUpper ca' == ca' || ca == ca') - (dpfx, bs) <- cash32decode ca - guard (not (B.null bs)) - let vb = B.head bs - pay = B.tail bs - (ver, len) <- decodeVersionByte vb - guard (B.length pay == len) - return (dpfx, ver, pay) - where - ca = T.toLower ca' - -{- | Mid-Level: encode 'CashAddr' string containing arbitrary prefix and - 'CashVersion'. Length must be among those allowed by the standard. --} -cash32encodeType :: CashPrefix -> CashVersion -> ByteString -> Maybe Cash32 -cash32encodeType pfx cv bs = do - let len = B.length bs - vb <- encodeVersionByte cv len - let pl = vb `B.cons` bs - return (cash32encode pfx pl) - -{- | Low-Level: decode 'Cash32' string. 'CashPrefix' must be part of the string. - No version or hash length validation is performed. --} -cash32decode :: Cash32 -> Maybe (CashPrefix, ByteString) -cash32decode text = do - let bs = C.map toLower bs' - guard (C.map toUpper bs' == bs' || bs == bs') - let (pfx', dat) = C.breakEnd (== ':') bs - pfx <- - if B.null pfx' || pfx' == C.singleton ':' - then Nothing - else Just (B.init pfx') - b32 <- B.pack <$> mapM base32char (C.unpack dat) - let px = B.map (.&. 0x1f) pfx - pd = px <> B.singleton 0 <> b32 - cs = cash32Polymod pd - bb = B.take (B.length b32 - 8) b32 - guard (verifyCash32Polymod cs) - let out = toBase256 bb - return (E.decodeUtf8 pfx, out) - where - bs' = E.encodeUtf8 text - -{- | Low-Level: encode 'Cash32' string for 'CashPrefix' provided. Can encode - arbitrary data. No prefix or length validation is performed. --} -cash32encode :: CashPrefix -> ByteString -> Cash32 -cash32encode pfx bs = - let b32 = toBase32 bs - px = B.map (.&. 0x1f) (E.encodeUtf8 pfx) - pd = px <> B.singleton 0 <> b32 <> B.replicate 8 0 - cs = cash32Polymod pd - c32 = B.map f (b32 <> cs) - f = fromIntegral . ord . (charset !!) . fromIntegral - in pfx <> ":" <> E.decodeUtf8 c32 - -{- | Convert base of 'ByteString' from eight bits per byte to five bits per - byte, adding padding as necessary. --} -toBase32 :: ByteString -> ByteString -toBase32 = - B.pack - . map fromIntegral - . fst - . convertBits True 8 5 - . map fromIntegral - . B.unpack - -{- | Convert base of 'ByteString' from five to eight bits per byte. Ignore - padding to be symmetric with respect to 'toBase32' function. --} -toBase256 :: ByteString -> ByteString -toBase256 = - B.pack - . map fromIntegral - . fst - . convertBits False 5 8 - . map fromIntegral - . B.unpack - --- | Obtain 'CashVersion' and payload length from 'CashAddr' version byte. -decodeVersionByte :: Word8 -> Maybe (CashVersion, Int) -decodeVersionByte vb = do - guard (vb .&. 0x80 == 0) - return (ver, len) - where - ver = vb `shiftR` 3 - len = ls !! fromIntegral (vb .&. 0x07) - ls = [20, 24, 28, 32, 40, 48, 56, 64] - -{- | Encode 'CashVersion' and length into version byte. Fail if version is - larger than five bits, or length incorrect, since that is invalid. --} -encodeVersionByte :: CashVersion -> Int -> Maybe Word8 -encodeVersionByte ver len = do - guard (ver == ver .&. 0x0f) - l <- case len of - 20 -> Just 0 - 24 -> Just 1 - 28 -> Just 2 - 32 -> Just 3 - 40 -> Just 4 - 48 -> Just 5 - 56 -> Just 6 - 64 -> Just 7 - _ -> Nothing - return ((ver `shiftL` 3) .|. l) - --- | Calculate or validate checksum from base32 'ByteString' (excluding prefix). -cash32Polymod :: ByteString -> ByteString -cash32Polymod v = - B.pack - [fromIntegral (polymod `shiftR` (5 * (7 - i))) .&. 0x1f | i <- [0 .. 7]] - where - polymod = B.foldl' outer (1 :: Word64) v `xor` 1 - outer c d = - let c0 = (fromIntegral (c `shiftR` 35) :: Word8) - c' = ((c .&. 0x07ffffffff) `shiftL` 5) `xor` fromIntegral d - in foldl' (inner c0) c' (zip [0 ..] generator) - generator = - [0x98f2bc8e61, 0x79b76d99e2, 0xf33e5fb3c4, 0xae2eabe2a8, 0x1e4f43e470] - inner c0 c (b, g) - | c0 `testBit` b = c `xor` g - | otherwise = c - --- | Validate that polymod 'ByteString' (eight bytes) is equal to zero. -verifyCash32Polymod :: ByteString -> Bool -verifyCash32Polymod = (== B.replicate 8 0) diff --git a/src/Haskoin/Block/Common.hs b/src/Haskoin/Block/Common.hs index 6c7d56cc..43e60df4 100644 --- a/src/Haskoin/Block/Common.hs +++ b/src/Haskoin/Block/Common.hs @@ -2,16 +2,15 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{- | -Module : Haskoin.Block.Common -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Common data types and functions to handle blocks from the block chain. --} +-- | +--Module : Haskoin.Block.Common +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX +-- +--Common data types and functions to handle blocks from the block chain. module Haskoin.Block.Common ( -- * Blocks Block (..), @@ -33,19 +32,6 @@ module Haskoin.Block.Common ( import Control.DeepSeq import Control.Monad (forM_, liftM2, mzero, replicateM, (<=<)) -import Data.Aeson ( - FromJSON (..), - ToJSON (..), - Value (..), - object, - toJSON, - withObject, - withText, - (.:), - (.=), - ) -import Data.Aeson.Encoding (pairs, unsafeToEncoding) -import Data.Binary (Binary (..)) import Data.Bits (shiftL, shiftR, (.&.), (.|.)) import qualified Data.ByteString as B import Data.ByteString.Builder (char7) @@ -65,7 +51,6 @@ import Data.Bytes.Put ( import Data.Bytes.Serial (Serial (..)) import Data.Hashable (Hashable) import Data.Maybe (fromMaybe) -import Data.Serialize (Serialize (..)) import Data.String (IsString, fromString) import Data.String.Conversions (cs) import Data.Text (Text) @@ -77,12 +62,15 @@ import Haskoin.Transaction.Common import Haskoin.Util import qualified Text.Read as R + -- | Height of a block in the block chain, starting at 0 for Genesis. type BlockHeight = Word32 + -- | Block timestamp as Unix time (seconds since 1970-01-01 00:00 UTC). type Timestamp = Word32 + -- | Block header and transactions. data Block = Block { blockHeader :: !BlockHeader @@ -90,6 +78,7 @@ data Block = Block } deriving (Eq, Show, Read, Generic, Hashable, NFData) + instance Serial Block where deserialize = do header <- deserialize @@ -101,22 +90,6 @@ instance Serial Block where putVarInt $ length txs forM_ txs serialize -instance Serialize Block where - get = deserialize - put = serialize - -instance Binary Block where - get = deserialize - put = serialize - -instance ToJSON Block where - toJSON (Block h t) = object ["header" .= h, "transactions" .= t] - toEncoding (Block h t) = pairs $ "header" .= h <> "transactions" .= t - -instance FromJSON Block where - parseJSON = - withObject "Block" $ \o -> - Block <$> o .: "header" <*> o .: "transactions" -- | Block header hash. To be serialized reversed for display purposes. newtype BlockHash = BlockHash @@ -124,62 +97,44 @@ newtype BlockHash = BlockHash } deriving (Eq, Ord, Generic, Hashable, Serial, NFData) -instance Serialize BlockHash where - put = serialize - get = deserialize - -instance Binary BlockHash where - put = serialize - get = deserialize instance Show BlockHash where showsPrec _ = shows . blockHashToHex + instance Read BlockHash where readPrec = do R.String str <- R.lexP maybe R.pfail return $ hexToBlockHash $ cs str + instance IsString BlockHash where fromString s = let e = error "Could not read block hash from hex string" in fromMaybe e $ hexToBlockHash $ cs s -instance FromJSON BlockHash where - parseJSON = - withText "BlockHash" $ - maybe mzero return . hexToBlockHash - -instance ToJSON BlockHash where - toJSON = String . blockHashToHex - toEncoding h = - unsafeToEncoding $ - char7 '"' - <> hexBuilder (BL.reverse (runPutL (serialize h))) - <> char7 '"' - -{- | Block hashes are reversed with respect to the in-memory byte order in a - block hash when displayed. --} + +-- | Block hashes are reversed with respect to the in-memory byte order in a +-- block hash when displayed. blockHashToHex :: BlockHash -> Text blockHashToHex (BlockHash h) = encodeHex (B.reverse (runPutS (serialize h))) -{- | Convert a human-readable hex block hash into a 'BlockHash'. Bytes are - reversed as normal. --} + +-- | Convert a human-readable hex block hash into a 'BlockHash'. Bytes are +-- reversed as normal. hexToBlockHash :: Text -> Maybe BlockHash hexToBlockHash hex = do bs <- B.reverse <$> decodeHex hex h <- eitherToMaybe (runGetS deserialize bs) return $ BlockHash h -{- | Data type recording information of a 'Block'. The hash of a block is - defined as the hash of this data structure, serialized. The block mining - process involves finding a partial hash collision by varying the nonce in the - 'BlockHeader' and/or additional entropy in the coinbase 'Transaction' of this - 'Block'. Variations in the coinbase will result in different merkle roots in - the 'BlockHeader'. --} + +-- | Data type recording information of a 'Block'. The hash of a block is +-- defined as the hash of this data structure, serialized. The block mining +-- process involves finding a partial hash collision by varying the nonce in the +-- 'BlockHeader' and/or additional entropy in the coinbase 'Transaction' of this +-- 'Block'. Variations in the coinbase will result in different merkle roots in +-- the 'BlockHeader'. data BlockHeader = BlockHeader { blockVersion :: !Word32 -- 4 bytes , -- | hash of the previous block (parent) @@ -195,39 +150,8 @@ data BlockHeader = BlockHeader } deriving (Eq, Ord, Show, Read, Generic, Hashable, NFData) --- 80 bytes -instance ToJSON BlockHeader where - toJSON (BlockHeader v p m t b n) = - object - [ "version" .= v - , "prevblock" .= p - , "merkleroot" .= encodeHex (runPutS (serialize m)) - , "timestamp" .= t - , "bits" .= b - , "nonce" .= n - ] - toEncoding (BlockHeader v p m t b n) = - pairs - ( "version" .= v - <> "prevblock" .= p - <> "merkleroot" .= encodeHex (runPutS (serialize m)) - <> "timestamp" .= t - <> "bits" .= b - <> "nonce" .= n - ) - -instance FromJSON BlockHeader where - parseJSON = - withObject "BlockHeader" $ \o -> - BlockHeader <$> o .: "version" - <*> o .: "prevblock" - <*> (f =<< o .: "merkleroot") - <*> o .: "timestamp" - <*> o .: "bits" - <*> o .: "nonce" - where - f = maybe mzero return . (eitherToMaybe . runGetS deserialize <=< decodeHex) +-- 80 bytes instance Serial BlockHeader where deserialize = do @@ -254,34 +178,27 @@ instance Serial BlockHeader where putWord32le bb putWord32le n -instance Binary BlockHeader where - put = serialize - get = deserialize - -instance Serialize BlockHeader where - put = serialize - get = deserialize -- | Compute hash of 'BlockHeader'. headerHash :: BlockHeader -> BlockHash headerHash = BlockHash . doubleSHA256 . runPutS . serialize -{- | A block locator is a set of block headers, denser towards the best block - and sparser towards the genesis block. It starts at the highest block known. - It is used by a node to synchronize against the network. When the locator is - provided to a peer, it will send back block hashes starting from the first - block in the locator that it recognizes. --} + +-- | A block locator is a set of block headers, denser towards the best block +-- and sparser towards the genesis block. It starts at the highest block known. +-- It is used by a node to synchronize against the network. When the locator is +-- provided to a peer, it will send back block hashes starting from the first +-- block in the locator that it recognizes. type BlockLocator = [BlockHash] -{- | Data type representing a getblocks message request. It is used in the - bitcoin protocol to retrieve blocks from a peer by providing it a - 'BlockLocator' object. The response to a 'GetBlocks' message is an 'Inv' - message containing a list of block hashes that the peer believes this node is - missing. The number of block hashes in that inv message will end at the stop - block hash, at at the tip of the chain, or after 500 entries, whichever comes - earlier. --} + +-- | Data type representing a getblocks message request. It is used in the +-- bitcoin protocol to retrieve blocks from a peer by providing it a +-- 'BlockLocator' object. The response to a 'GetBlocks' message is an 'Inv' +-- message containing a list of block hashes that the peer believes this node is +-- missing. The number of block hashes in that inv message will end at the stop +-- block hash, at at the tip of the chain, or after 500 entries, whichever comes +-- earlier. data GetBlocks = GetBlocks { getBlocksVersion :: !Word32 , -- | block locator object @@ -291,19 +208,17 @@ data GetBlocks = GetBlocks } deriving (Eq, Show, Read, Generic, NFData) + instance Serial GetBlocks where deserialize = GetBlocks <$> getWord32le <*> (repList =<< deserialize) <*> deserialize - where - repList (VarInt c) = replicateM (fromIntegral c) deserialize + where + repList (VarInt c) = replicateM (fromIntegral c) deserialize serialize (GetBlocks v xs h) = putGetBlockMsg v xs h -instance Serialize GetBlocks where - put = serialize - get = deserialize putGetBlockMsg :: MonadPut m => Word32 -> BlockLocator -> BlockHash -> m () putGetBlockMsg v xs h = do @@ -312,12 +227,12 @@ putGetBlockMsg v xs h = do forM_ xs serialize serialize h -{- | Similar to the 'GetBlocks' message type but for retrieving block headers - only. The response to a 'GetHeaders' request is a 'Headers' message - containing a list of block headers. A maximum of 2000 block headers can be - returned. 'GetHeaders' is used by simplified payment verification (SPV) - clients to exclude block contents when synchronizing the block chain. --} + +-- | Similar to the 'GetBlocks' message type but for retrieving block headers +-- only. The response to a 'GetHeaders' request is a 'Headers' message +-- containing a list of block headers. A maximum of 2000 block headers can be +-- returned. 'GetHeaders' is used by simplified payment verification (SPV) +-- clients to exclude block contents when synchronizing the block chain. data GetHeaders = GetHeaders { getHeadersVersion :: !Word32 , -- | block locator object @@ -327,118 +242,105 @@ data GetHeaders = GetHeaders } deriving (Eq, Show, Read, Generic, NFData) + instance Serial GetHeaders where deserialize = GetHeaders <$> getWord32le <*> (repList =<< deserialize) <*> deserialize - where - repList (VarInt c) = replicateM (fromIntegral c) deserialize + where + repList (VarInt c) = replicateM (fromIntegral c) deserialize serialize (GetHeaders v xs h) = putGetBlockMsg v xs h -instance Serialize GetHeaders where - put = serialize - get = deserialize - -instance Binary GetHeaders where - put = serialize - get = deserialize -- | 'BlockHeader' type with a transaction count as 'VarInt' type BlockHeaderCount = (BlockHeader, VarInt) -{- | The 'Headers' type is used to return a list of block headers in - response to a 'GetHeaders' message. --} + +-- | The 'Headers' type is used to return a list of block headers in +-- response to a 'GetHeaders' message. newtype Headers = Headers { -- | list of block headers with transaction count headersList :: [BlockHeaderCount] } deriving (Eq, Show, Read, Generic, NFData) + instance Serial Headers where deserialize = Headers <$> (repList =<< deserialize) - where - repList (VarInt c) = replicateM (fromIntegral c) action - action = liftM2 (,) deserialize deserialize + where + repList (VarInt c) = replicateM (fromIntegral c) action + action = liftM2 (,) deserialize deserialize serialize (Headers xs) = do putVarInt $ length xs forM_ xs $ \(a, b) -> serialize a >> serialize b -instance Serialize Headers where - put = serialize - get = deserialize - -instance Binary Headers where - put = serialize - get = deserialize - -{- | Decode the compact number used in the difficulty target of a block. - - The compact format is a representation of a whole number \(N\) using an - unsigned 32-bit number similar to a floating point format. The most - significant 8 bits are the unsigned exponent of base 256. This exponent can - be thought of as the number of bytes of \(N\). The lower 23 bits are the - mantissa. Bit number 24 represents the sign of \(N\). - \[ - N = -1^{sign} \times mantissa \times 256^{exponent-3} - \] --} +-- | Decode the compact number used in the difficulty target of a block. +-- +-- The compact format is a representation of a whole number \(N\) using an +-- unsigned 32-bit number similar to a floating point format. The most +-- significant 8 bits are the unsigned exponent of base 256. This exponent can +-- be thought of as the number of bytes of \(N\). The lower 23 bits are the +-- mantissa. Bit number 24 represents the sign of \(N\). +-- +-- \[ +-- N = -1^{sign} \times mantissa \times 256^{exponent-3} +-- \] decodeCompact :: Word32 -> -- | true means overflow (Integer, Bool) 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. --} + 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 + 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 index 3d2e8c7e..cb939537 100644 --- a/src/Haskoin/Block/Headers.hs +++ b/src/Haskoin/Block/Headers.hs @@ -5,16 +5,15 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} -{- | -Module : Haskoin.Block.Headers -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Block chain header synchronization and proof-of-work consensus functions. --} +-- | +--Module : Haskoin.Block.Headers +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX +-- +--Block chain header synchronization and proof-of-work consensus functions. module Haskoin.Block.Headers ( -- * Block Headers BlockNode (..), @@ -53,7 +52,6 @@ module Haskoin.Block.Headers ( nextWorkRequired, nextEdaWorkRequired, nextDaaWorkRequired, - nextAsertWorkRequired, computeAsertBits, computeTarget, getSuitableBlock, @@ -74,20 +72,19 @@ module Haskoin.Block.Headers ( import Control.Applicative ((<|>)) import Control.DeepSeq import Control.Monad (guard, mzero, unless, when) -import Control.Monad.Except ( +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except ( ExceptT (..), runExceptT, - throwError, + throwE, ) -import Control.Monad.State.Strict as State ( +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.State.Strict as State ( StateT, get, gets, - lift, modify, ) -import Control.Monad.Trans.Maybe -import Data.Binary (Binary (..)) import Data.Bits (shiftL, shiftR, (.&.)) import qualified Data.ByteString as B import Data.ByteString.Short ( @@ -104,7 +101,6 @@ import qualified Data.HashMap.Strict as HashMap import Data.Hashable import Data.List (sort, sortBy) import Data.Maybe (fromMaybe, listToMaybe) -import Data.Serialize (Serialize (..)) import Data.Typeable (Typeable) import Data.Word (Word32, Word64) import GHC.Generics (Generic) @@ -114,23 +110,24 @@ import Haskoin.Data import Haskoin.Transaction.Genesis import Haskoin.Util -{- | Short version of the block hash. Uses the good end of the hash (the part - that doesn't have a long string of zeroes). --} + +-- | Short version of the block hash. Uses the good end of the hash (the part +-- that doesn't have a long string of zeroes). type ShortBlockHash = Word64 -{- | Memory-based map to a serialized 'BlockNode' data structure. - 'ShortByteString' is used to avoid memory fragmentation and make the data - structure compact. --} + +-- | Memory-based map to a serialized 'BlockNode' data structure. +-- 'ShortByteString' is used to avoid memory fragmentation and make the data +-- structure compact. type BlockMap = HashMap ShortBlockHash ShortByteString + -- | Represents accumulated work in the block chain so far. type BlockWork = Integer -{- | Data structure representing a block header and its position in the - block chain. --} + +-- | Data structure representing a block header and its position in the +-- block chain. data BlockNode = BlockNode { nodeHeader :: !BlockHeader , nodeHeight :: !BlockHeight @@ -141,6 +138,7 @@ data BlockNode = BlockNode } deriving (Show, Read, Generic, Hashable, NFData) + instance Serial BlockNode where deserialize = do nodeHeader <- deserialize @@ -161,20 +159,15 @@ instance Serial BlockNode where 0 -> return () _ -> serialize $ nodeSkip bn -instance Serialize BlockNode where - put = serialize - get = deserialize - -instance Binary BlockNode where - put = serialize - get = deserialize instance Eq BlockNode where (==) = (==) `on` nodeHeader + instance Ord BlockNode where compare = compare `on` nodeHeight + -- | Memory-based header tree. data HeaderMemory = HeaderMemory { memoryHeaderMap :: !BlockMap @@ -182,30 +175,37 @@ data HeaderMemory = HeaderMemory } deriving (Eq, Typeable, Show, Read, Generic, Hashable, NFData) + -- | Typeclass for block header chain storage monad. class Monad m => BlockHeaders m where -- | Add a new 'BlockNode' to the chain. Does not validate. addBlockHeader :: BlockNode -> m () + -- | Get a 'BlockNode' associated with a 'BlockHash'. getBlockHeader :: BlockHash -> m (Maybe BlockNode) + -- | Locate the 'BlockNode' for the highest block in the chain getBestBlockHeader :: m BlockNode + -- | Set the highest block in the chain. setBestBlockHeader :: BlockNode -> m () + -- | Add a continuous bunch of block headers the chain. Does not validate. addBlockHeaders :: [BlockNode] -> m () addBlockHeaders = mapM_ addBlockHeader + instance Monad m => BlockHeaders (StateT HeaderMemory m) where addBlockHeader = modify . addBlockHeaderMemory getBlockHeader bh = getBlockHeaderMemory bh <$> State.get getBestBlockHeader = gets memoryBestHeader setBestBlockHeader bn = modify $ \s -> s{memoryBestHeader = bn} + -- | Initialize memory-based chain. initialChain :: Network -> HeaderMemory initialChain net = @@ -214,6 +214,7 @@ initialChain net = , memoryBestHeader = genesisNode net } + -- | Initialize map for memory-based chain. genesisMap :: Network -> BlockMap genesisMap net = @@ -221,26 +222,29 @@ genesisMap net = (shortBlockHash (headerHash (getGenesisHeader net))) (toShort (runPutS (serialize (genesisNode net)))) + -- | Add block header to memory block map. addBlockHeaderMemory :: BlockNode -> HeaderMemory -> HeaderMemory addBlockHeaderMemory bn s@HeaderMemory{..} = let bm' = addBlockToMap bn memoryHeaderMap in s{memoryHeaderMap = bm'} + -- | Get block header from memory block map. getBlockHeaderMemory :: BlockHash -> HeaderMemory -> Maybe BlockNode getBlockHeaderMemory bh HeaderMemory{..} = do bs <- shortBlockHash bh `HashMap.lookup` memoryHeaderMap eitherToMaybe . runGetS deserialize $ fromShort bs -{- | Calculate short block hash taking eight non-zero bytes from the 16-byte - hash. This function will take the bytes that are not on the zero-side of the - hash, making colissions between short block hashes difficult. --} + +-- | Calculate short block hash taking eight non-zero bytes from the 16-byte +-- hash. This function will take the bytes that are not on the zero-side of the +-- hash, making colissions between short block hashes difficult. shortBlockHash :: BlockHash -> ShortBlockHash shortBlockHash = either error id . runGetS deserialize . B.take 8 . runPutS . serialize + -- | Add a block to memory-based block map. addBlockToMap :: BlockNode -> BlockMap -> BlockMap addBlockToMap node = @@ -248,9 +252,9 @@ addBlockToMap node = (shortBlockHash $ headerHash $ nodeHeader node) (toShort $ runPutS $ serialize node) -{- | Get the ancestor of the provided 'BlockNode' at the specified - 'BlockHeight'. --} + +-- | Get the ancestor of the provided 'BlockNode' at the specified +-- 'BlockHeight'. getAncestor :: BlockHeaders m => BlockHeight -> @@ -259,37 +263,39 @@ getAncestor :: 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 + 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 BlockNode{nodeHeight = 0} = True isGenesis _ = False + -- | Build the genesis 'BlockNode' for the supplied 'Network'. genesisNode :: Network -> BlockNode genesisNode net = @@ -300,9 +306,9 @@ genesisNode net = , nodeSkip = headerHash (getGenesisHeader net) } -{- | Validate a list of continuous block headers and import them to the - block chain. Return 'Left' on failure with error information. --} + +-- | Validate a list of continuous block headers and import them to the +-- block chain. Return 'Left' on failure with error information. connectBlocks :: BlockHeaders m => Network -> @@ -314,7 +320,7 @@ connectBlocks _ _ [] = return $ Right [] connectBlocks net t bhs@(bh : _) = runExceptT $ do unless (chained bhs) $ - throwError "Blocks to connect do not form a chain" + throwE "Blocks to connect do not form a chain" par <- maybeToExceptT "Could not get parent block" @@ -328,44 +334,44 @@ connectBlocks net t bhs@(bh : _) = 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. --} + 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 -> + throwE $ + "BUG: Could not get skip for block " + ++ show (headerHash $ nodeHeader par) + | otherwise = do + let sn = ls !! fromIntegral (nodeHeight par - sh) + when (nodeHeight sn /= sh) $ + throwE "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. --} + +-- | Validate and connect single block header to the block chain. Return 'Left' +-- if fails to be validated. connectBlock :: BlockHeaders m => Network -> @@ -385,7 +391,7 @@ connectBlock net t bh = case skM of Just sk -> return sk Nothing -> - throwError $ + throwE $ "BUG: Could not get skip for block " ++ show (headerHash $ nodeHeader par) bb <- lift getBestBlockHeader @@ -395,6 +401,7 @@ connectBlock net t bh = when (bb /= bb') . lift $ setBestBlockHeader bb' return bn + -- | Validate this block header. Build a 'BlockNode' if successful. validBlock :: Network -> @@ -440,28 +447,30 @@ validBlock net t bb par pars bh sk = do , nodeSkip = headerHash $ nodeHeader sk } -{- | Return the median of all provided timestamps. Can be unsorted. Error on - empty list. --} + +-- | Return the median of all provided timestamps. Can be unsorted. Error on +-- empty list. medianTime :: [Timestamp] -> Timestamp medianTime ts | null ts = error "Cannot compute median time of empty header list" | otherwise = sort ts !! (length ts `div` 2) -{- | Calculate the height of the skip (magic) block that corresponds to the - given height. The block hash of the ancestor at that height will be placed on - the 'BlockNode' structure to help locate ancestors at any height quickly. --} + +-- | Calculate the height of the skip (magic) block that corresponds to the +-- given height. The block hash of the ancestor at that height will be placed on +-- the 'BlockNode' structure to help locate ancestors at any height quickly. skipHeight :: BlockHeight -> BlockHeight skipHeight height | height < 2 = 0 | height .&. 1 /= 0 = invertLowestOne (invertLowestOne $ height - 1) + 1 | otherwise = invertLowestOne height + -- | Part of the skip black magic calculation. invertLowestOne :: BlockHeight -> BlockHeight invertLowestOne height = height .&. (height - 1) + -- | Get a number of parents for the provided block. getParents :: BlockHeaders m => @@ -470,15 +479,16 @@ getParents :: -- | starts from immediate parent m [BlockNode] getParents = getpars [] - where - getpars acc 0 _ = return $ reverse acc - getpars acc n BlockNode{..} - | nodeHeight == 0 = return $ reverse acc - | otherwise = 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" + where + getpars acc 0 _ = return $ reverse acc + getpars acc n BlockNode{..} + | nodeHeight == 0 = return $ reverse acc + | otherwise = 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 :: @@ -493,9 +503,9 @@ validCP net height newChildHash = Just cpHash -> cpHash == newChildHash Nothing -> True -{- | New block height above the last checkpoint imported. Used to prevent a - reorg below the highest checkpoint that was already imported. --} + +-- | New block height above the last checkpoint imported. Used to prevent a +-- reorg below the highest checkpoint that was already imported. afterLastCP :: Network -> -- | best height @@ -507,15 +517,15 @@ 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. --} + 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 -> -- | new child height @@ -528,6 +538,7 @@ bip34 net height hsh | fst (getBip34Block net) == height = snd (getBip34Block net) == hsh | otherwise = True + -- | Check if the provided block height and version are valid. validVersion :: Network -> @@ -542,9 +553,9 @@ validVersion net height version | version < 4 = height < getBip65Height net | otherwise = True -{- | Find last block with normal, as opposed to minimum difficulty (for test - networks). --} + +-- | Find last block with normal, as opposed to minimum difficulty (for test +-- networks). lastNoMinDiff :: BlockHeaders m => Network -> BlockNode -> m BlockNode lastNoMinDiff _ bn@BlockNode{nodeHeight = 0} = return bn lastNoMinDiff net bn@BlockNode{..} = do @@ -561,9 +572,9 @@ lastNoMinDiff net bn@BlockNode{..} = do lastNoMinDiff net bn' else return bn -{- | Returns the work required on a block header given the previous block. This - coresponds to @bitcoind@ function @GetNextWorkRequired@ in @main.cpp@. --} + +-- | 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 -> @@ -571,28 +582,23 @@ nextWorkRequired :: BlockHeader -> m Word32 nextWorkRequired net par bh = do - ma <- getAsertAnchor net - case asert ma <|> daa <|> eda <|> pow of + case daa <|> eda <|> pow of Just f -> f par bh Nothing -> error "Could not determine difficulty algorithm" - where - asert ma = do - anchor <- ma - guard (nodeHeight par > nodeHeight anchor) - return $ nextAsertWorkRequired net anchor - daa = do - daa_height <- getDaaBlockHeight net - guard (nodeHeight par + 1 >= daa_height) - return $ nextDaaWorkRequired net - eda = do - eda_height <- getEdaBlockHeight net - guard (nodeHeight par + 1 >= eda_height) - return $ nextEdaWorkRequired net - pow = return $ nextPowWorkRequired net - -{- | Find out the next amount of work required according to the Emergency - Difficulty Adjustment (EDA) algorithm from Bitcoin Cash. --} + where + daa = do + daa_height <- getDaaBlockHeight net + guard (nodeHeight par + 1 >= daa_height) + return $ nextDaaWorkRequired net + eda = do + eda_height <- getEdaBlockHeight net + guard (nodeHeight par + 1 >= eda_height) + return $ nextEdaWorkRequired net + pow = return $ nextPowWorkRequired net + + +-- | Find out the next amount of work required according to the Emergency +-- Difficulty Adjustment (EDA) algorithm from Bitcoin Cash. nextEdaWorkRequired :: BlockHeaders m => Network -> BlockNode -> BlockHeader -> m Word32 nextEdaWorkRequired net par bh @@ -618,15 +624,15 @@ nextEdaWorkRequired net par bh 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. --} + 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 @@ -641,12 +647,13 @@ nextDaaWorkRequired net par bh if nextTarget > getPowLimit net then return $ encodeCompact (getPowLimit net) else return $ encodeCompact nextTarget - where - height = nodeHeight par - e1 = error "Cannot get ancestor at parent - 144 height" - minDifficulty = - blockTimestamp bh - > blockTimestamp (nodeHeader par) + getTargetSpacing net * 2 + where + height = nodeHeight par + e1 = error "Cannot get ancestor at parent - 144 height" + minDifficulty = + blockTimestamp bh + > blockTimestamp (nodeHeader par) + getTargetSpacing net * 2 + mtp :: BlockHeaders m => BlockNode -> m Timestamp mtp bn @@ -655,6 +662,7 @@ mtp bn pars <- getParents 11 bn return $ medianTime (map (blockTimestamp . nodeHeader) pars) + firstGreaterOrEqual :: BlockHeaders m => Network -> @@ -662,6 +670,7 @@ firstGreaterOrEqual :: m (Maybe BlockNode) firstGreaterOrEqual = binSearch False + lastSmallerOrEqual :: BlockHeaders m => Network -> @@ -669,6 +678,7 @@ lastSmallerOrEqual :: m (Maybe BlockNode) lastSmallerOrEqual = binSearch True + binSearch :: BlockHeaders m => Bool -> @@ -678,102 +688,76 @@ binSearch :: binSearch top net f = runMaybeT $ do (a, b) <- lift $ extremes net go a b - where - go a b = do - m <- lift $ middleBlock a b - a' <- lift $ f a - b' <- lift $ f b - m' <- lift $ f m + where + go a b = do + m <- lift $ middleBlock a b + a' <- lift $ f a + b' <- lift $ f b + m' <- lift $ f m + r (a, a') (b, b') (m, m') r (a, a') (b, b') (m, m') - r (a, a') (b, b') (m, m') - | out_of_bounds a' b' = mzero - | select_first a' = return a - | select_last b' = return b - | no_middle a b = choose_one a b - | is_between a' m' = go a m - | is_between m' b' = go m b - | otherwise = mzero - select_first a' - | not top = a' /= LT - | otherwise = False - select_last b' - | top = b' /= GT - | otherwise = False - out_of_bounds a' b' - | top = a' == GT - | otherwise = b' == LT - no_middle a b = nodeHeight b - nodeHeight a <= 1 - is_between a' b' = a' /= GT && b' /= LT - choose_one a b - | top = return a - | otherwise = return b + | out_of_bounds a' b' = mzero + | select_first a' = return a + | select_last b' = return b + | no_middle a b = choose_one a b + | is_between a' m' = go a m + | is_between m' b' = go m b + | otherwise = mzero + select_first a' + | not top = a' /= LT + | otherwise = False + select_last b' + | top = b' /= GT + | otherwise = False + out_of_bounds a' b' + | top = a' == GT + | otherwise = b' == LT + no_middle a b = nodeHeight b - nodeHeight a <= 1 + is_between a' b' = a' /= GT && b' /= LT + choose_one a b + | top = return a + | otherwise = return b + extremes :: BlockHeaders m => Network -> m (BlockNode, BlockNode) extremes net = do b <- getBestBlockHeader return (genesisNode net, b) + middleBlock :: BlockHeaders m => BlockNode -> BlockNode -> m BlockNode middleBlock a b = getAncestor h b >>= \case Nothing -> error "You fell into a pit full of mud and snakes" Just x -> return x - where - h = middleOf (nodeHeight a) (nodeHeight b) + where + h = middleOf (nodeHeight a) (nodeHeight b) + middleOf :: Integral a => a -> a -> a middleOf a b = a + ((b - a) `div` 2) --- TODO: Use known anchor after fork -getAsertAnchor :: BlockHeaders m => Network -> m (Maybe BlockNode) -getAsertAnchor net = - case getAsertActivationTime net of - Nothing -> return Nothing - Just act -> firstGreaterOrEqual net (f act) - where - f act bn = do - m <- mtp bn - return $ compare m act - --- | Find the next amount of work required according to the aserti3-2d algorithm. -nextAsertWorkRequired :: - BlockHeaders m => - Network -> - BlockNode -> - BlockNode -> - BlockHeader -> - m Word32 -nextAsertWorkRequired net anchor par bh = do - anchor_parent <- - fromMaybe e_fork - <$> getBlockHeader (prevBlock (nodeHeader anchor)) - let anchor_parent_time = toInteger $ blockTimestamp $ nodeHeader anchor_parent - time_diff = current_time - anchor_parent_time - return $ computeAsertBits halflife anchor_bits time_diff height_diff - where - halflife = getAsertHalfLife net - anchor_height = toInteger $ nodeHeight anchor - anchor_bits = blockBits $ nodeHeader anchor - current_height = toInteger (nodeHeight par) + 1 - height_diff = current_height - anchor_height - current_time = toInteger $ blockTimestamp bh - e_fork = error "Could not get fork block header" idealBlockTime :: Integer idealBlockTime = 10 * 60 + rBits :: Int rBits = 16 + radix :: Integer radix = 1 `shiftL` rBits + maxBits :: Word32 maxBits = 0x1d00ffff + maxTarget :: Integer maxTarget = fst $ decodeCompact maxBits + computeAsertBits :: Integer -> Word32 -> @@ -790,25 +774,26 @@ computeAsertBits halflife anchor_bits time_diff height_diff = then maxBits else encodeCompact g4 else error $ "Exponent not in range: " ++ show e2 - where - g1 = fst (decodeCompact anchor_bits) - e1 = - ((time_diff - idealBlockTime * (height_diff + 1)) * radix) - `quot` halflife - s = e1 `shiftR` rBits - e2 = e1 - s * radix - g2 = - g1 - * ( radix - + ( (195766423245049 * e2 + 971821376 * e2 ^ 2 + 5127 * e2 ^ 3 + 2 ^ 47) - `shiftR` (rBits * 3) - ) - ) - g3 = - if s < 0 - then g2 `shiftR` negate (fromIntegral s) - else g2 `shiftL` fromIntegral s - g4 = g3 `shiftR` rBits + where + g1 = fst (decodeCompact anchor_bits) + e1 = + ((time_diff - idealBlockTime * (height_diff + 1)) * radix) + `quot` halflife + s = e1 `shiftR` rBits + e2 = e1 - s * radix + g2 = + g1 + * ( radix + + ( (195766423245049 * e2 + 971821376 * e2 ^ 2 + 5127 * e2 ^ 3 + 2 ^ 47) + `shiftR` (rBits * 3) + ) + ) + g3 = + if s < 0 + then g2 `shiftR` negate (fromIntegral s) + else g2 `shiftL` fromIntegral s + g4 = g3 `shiftR` rBits + -- | Compute Bitcoin Cash DAA target for a new block. computeTarget :: Network -> BlockNode -> BlockNode -> Integer @@ -825,6 +810,7 @@ computeTarget net f l = 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 @@ -832,9 +818,9 @@ getSuitableBlock par = do blocks <- (par :) <$> getParents 2 par return $ sortBy (compare `on` blockTimestamp . nodeHeader) blocks !! 1 -{- | Returns the work required on a block header given the previous block. This - coresponds to bitcoind function GetNextWorkRequired in main.cpp. --} + +-- | Returns the work required on a block header given the previous block. This +-- coresponds to bitcoind function GetNextWorkRequired in main.cpp. nextPowWorkRequired :: BlockHeaders m => Network -> BlockNode -> BlockHeader -> m Word32 nextPowWorkRequired net par bh @@ -852,11 +838,12 @@ nextPowWorkRequired net par bh 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 + 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 :: @@ -870,45 +857,48 @@ 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@. --} + 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 + where + (target, over) = decodeCompact $ blockBits h + -- | Returns the proof of work of a block header hash as an 'Integer' number. blockPOW :: BlockHash -> Integer blockPOW = bsToInteger . B.reverse . runPutS . serialize -{- | Returns the work represented by this block. Work is defined as the number - of tries needed to solve a block in the average case with respect to the - target. --} + +-- | Returns the work represented by this block. Work is defined as the number +-- of tries needed to solve a block in the average case with respect to the +-- target. headerWork :: BlockHeader -> Integer headerWork bh = largestHash `div` (target + 1) - where - target = fst $ decodeCompact $ blockBits bh - largestHash = 1 `shiftL` 256 + where + target = fst $ decodeCompact $ blockBits bh + largestHash = 1 `shiftL` 256 + -- | Number of blocks on average between difficulty cycles (2016 blocks). diffInterval :: Network -> Word32 diffInterval net = getTargetTimespan net `div` getTargetSpacing net + -- | Compare two blocks to get the best. chooseBest :: BlockNode -> BlockNode -> BlockNode chooseBest b1 b2 @@ -919,31 +909,34 @@ chooseBest b1 b2 | nodeWork b1 > nodeWork b2 = b1 | otherwise = b2 + -- | Get list of blocks for a block locator. blockLocatorNodes :: BlockHeaders m => BlockNode -> m [BlockNode] blockLocatorNodes best = 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' + 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 = @@ -954,6 +947,7 @@ mineBlock net seed h = , isValidPOW net j ] + -- | Generate and append new blocks (mining). Only practical in regtest network. appendBlocks :: Network -> @@ -965,16 +959,17 @@ appendBlocks :: 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 $ runPutS $ serialize seed - } + where + bh' = + mineBlock + net + seed + bh + { prevBlock = headerHash bh + , -- Just to make it different in every header + merkleRoot = sha256 $ runPutS $ serialize seed + } + -- | Find the last common block ancestor between provided block headers. splitPoint :: BlockHeaders m => BlockNode -> BlockNode -> m BlockNode @@ -983,21 +978,23 @@ splitPoint l r = do 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 + 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 = diff --git a/src/Haskoin/Block/Merkle.hs b/src/Haskoin/Block/Merkle.hs index e4e0ec92..a1c194ee 100644 --- a/src/Haskoin/Block/Merkle.hs +++ b/src/Haskoin/Block/Merkle.hs @@ -1,16 +1,15 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} -{- | -Module : Haskoin.Block.Merkle -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Function to deal with Merkle trees inside blocks. --} +-- | +--Module : Haskoin.Block.Merkle +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX +-- +--Function to deal with Merkle trees inside blocks. module Haskoin.Block.Merkle ( -- * Merkle Blocks MerkleBlock (..), @@ -36,7 +35,6 @@ module Haskoin.Block.Merkle ( import Control.DeepSeq import Control.Monad (forM_, replicateM, when) -import Data.Binary (Binary (..)) import Data.Bits import qualified Data.ByteString as BS import Data.Bytes.Get @@ -45,7 +43,6 @@ import Data.Bytes.Serial import Data.Either (isRight) import Data.Hashable import Data.Maybe -import Data.Serialize (Serialize (..)) import Data.Word (Word32, Word8) import GHC.Generics import Haskoin.Block.Common @@ -54,18 +51,21 @@ import Haskoin.Data import Haskoin.Network.Common import Haskoin.Transaction.Common + -- | Hash of the block's Merkle root. type MerkleRoot = Hash256 + -- | Bits that are used to rebuild partial merkle tree transaction hash list. type FlagBits = [Bool] + -- | Partial Merkle tree for a filtered block. type PartialMerkleTree = [Hash256] -{- | Filtered block: a block with a partial Merkle tree that only includes the - transactions that pass a bloom filter that was negotiated. --} + +-- | Filtered block: a block with a partial Merkle tree that only includes the +-- transactions that pass a bloom filter that was negotiated. data MerkleBlock = MerkleBlock { -- | block header merkleHeader :: !BlockHeader @@ -78,6 +78,7 @@ data MerkleBlock = MerkleBlock } deriving (Eq, Show, Read, Generic, Hashable, NFData) + instance Serial MerkleBlock where deserialize = do header <- deserialize @@ -88,6 +89,7 @@ instance Serial MerkleBlock where ws <- replicateM (fromIntegral flagLen) getWord8 return $ MerkleBlock header ntx hashes (decodeMerkleFlags ws) + serialize (MerkleBlock h ntx hashes flags) = do serialize h putWord32le ntx @@ -97,13 +99,6 @@ instance Serial MerkleBlock where putVarInt $ length ws forM_ ws putWord8 -instance Binary MerkleBlock where - put = serialize - get = deserialize - -instance Serialize MerkleBlock where - put = serialize - get = deserialize -- | Unpack Merkle flags into 'FlagBits' structure. decodeMerkleFlags :: [Word8] -> FlagBits @@ -111,10 +106,12 @@ decodeMerkleFlags ws = [ b | p <- [0 .. length ws * 8 - 1], b <- [testBit (ws !! (p `div` 8)) (p `mod` 8)] ] + -- | Pack Merkle flags from 'FlagBits'. encodeMerkleFlags :: FlagBits -> [Word8] encodeMerkleFlags bs = map boolsToWord8 $ splitIn 8 bs + -- | Computes the height of a Merkle tree. calcTreeHeight :: -- | number of transactions (leaf nodes) @@ -126,9 +123,9 @@ calcTreeHeight ntx | even ntx = 1 + calcTreeHeight (ntx `div` 2) | otherwise = calcTreeHeight $ ntx + 1 -{- | Computes the width of a Merkle tree at a specific height. The transactions - are at height 0. --} + +-- | Computes the width of a Merkle tree at a specific height. The transactions +-- are at height 0. calcTreeWidth :: -- | number of transactions (leaf nodes) Int -> @@ -138,6 +135,7 @@ calcTreeWidth :: Int calcTreeWidth ntx h = (ntx + (1 `shiftL` h) - 1) `shiftR` h + -- | Computes the root of a Merkle tree from a list of leaf node hashes. buildMerkleRoot :: -- | transaction hashes (leaf nodes) @@ -146,10 +144,12 @@ buildMerkleRoot :: MerkleRoot buildMerkleRoot txs = calcHash (calcTreeHeight $ length txs) 0 txs + -- | Concatenate and compute double SHA256. hash2 :: Hash256 -> Hash256 -> Hash256 hash2 a b = doubleSHA256 $ runPutS (serialize a) <> runPutS (serialize b) + -- | Computes the hash of a specific node in a Merkle tree. calcHash :: -- | height of the node @@ -164,18 +164,18 @@ 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. --} + 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 :: -- | transaction hash and whether to include [(TxHash, Bool)] -> @@ -183,25 +183,26 @@ buildPartialMerkle :: (FlagBits, PartialMerkleTree) buildPartialMerkle hs = traverseAndBuild (calcTreeHeight $ length hs) 0 hs -{- | Helper function to build partial Merkle tree. Used by 'buildPartialMerkle' - above. --} + +-- | Helper function to build partial Merkle tree. Used by 'buildPartialMerkle' +-- above. traverseAndBuild :: Int -> Int -> [(TxHash, Bool)] -> (FlagBits, PartialMerkleTree) traverseAndBuild height pos txs | 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 = ([], []) + 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 :: @@ -220,28 +221,28 @@ traverseAndExtract height pos ntx flags hashes | 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'. --} + 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 -> @@ -273,25 +274,27 @@ extractMatches net flags hashes ntx 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. --} + 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 + where + (xs1, xs2) = splitAt c xs + -- | Pack up to eight bools in a byte. boolsToWord8 :: [Bool] -> Word8 boolsToWord8 [] = 0 boolsToWord8 xs = foldl setBit 0 (map snd $ filter fst $ zip xs [0 .. 7]) + -- | Get matching transactions from Merkle block. merkleBlockTxs :: Network -> MerkleBlock -> Either String [TxHash] merkleBlockTxs net b = @@ -304,6 +307,7 @@ merkleBlockTxs net b = when (root /= merkle) $ Left "merkleBlockTxs: Merkle root incorrect" return ths + -- | Check if Merkle block root is valid against the block header. testMerkleRoot :: Network -> MerkleBlock -> Bool testMerkleRoot net = isRight . merkleBlockTxs net diff --git a/src/Haskoin/Constants.hs b/src/Haskoin/Constants.hs index ff8945bd..4626dff5 100644 --- a/src/Haskoin/Constants.hs +++ b/src/Haskoin/Constants.hs @@ -1,19 +1,15 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{- | -Module : Haskoin.Constants -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Network constants for various networks, including Bitcoin SegWit (BTC), Bitcoin -Cash (BCH), and corresponding public test and private regression test networks. --} +-- | +--Module : Haskoin.Constants +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX +-- +--Network constants for main, test and private regression test networks. module Haskoin.Constants ( Network (..), @@ -21,23 +17,17 @@ module Haskoin.Constants ( btc, btcTest, btcRegTest, - bch, - bchTest, - bchTest4, - bchRegTest, allNets, netByName, ) where import Control.DeepSeq -import Data.Binary (Binary (..)) import Data.ByteString (ByteString) import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial import Data.List import Data.Maybe -import Data.Serialize (Serialize (..)) import Data.String import Data.Text (Text) import Data.Word (Word32, Word64, Word8) @@ -48,6 +38,7 @@ import Haskoin.Network.Common import Haskoin.Transaction import Text.Read + -- | Version of Haskoin Core package. versionString :: IsString a => a @@ -57,10 +48,12 @@ versionString = CURRENT_PACKAGE_VERSION versionString = "Unavailable" #endif + -- | Query known networks by name. netByName :: String -> Maybe Network netByName str = find ((== str) . getNetworkName) allNets + -- | Bitcoin SegWit network. Symbol: BTC. btc :: Network btc = @@ -167,15 +160,13 @@ btc = , getSigHashForkId = Nothing , getEdaBlockHeight = Nothing , getDaaBlockHeight = Nothing - , getAsertActivationTime = Nothing - , getAsertHalfLife = 0 , getSegWit = True - , getCashAddrPrefix = Nothing , getBech32Prefix = Just "bc" , getReplaceByFee = True , getHalvingInterval = 210000 } + -- | Testnet for Bitcoin SegWit network. btcTest :: Network btcTest = @@ -228,15 +219,13 @@ btcTest = , getSigHashForkId = Nothing , getEdaBlockHeight = Nothing , getDaaBlockHeight = Nothing - , getAsertActivationTime = Nothing - , getAsertHalfLife = 0 , getSegWit = True - , getCashAddrPrefix = Nothing , getBech32Prefix = Just "tb" , getReplaceByFee = True , getHalvingInterval = 210000 } + -- | RegTest for Bitcoin SegWit network. btcRegTest :: Network btcRegTest = @@ -279,337 +268,13 @@ btcRegTest = , getSigHashForkId = Nothing , getEdaBlockHeight = Nothing , getDaaBlockHeight = Nothing - , getAsertActivationTime = Nothing - , getAsertHalfLife = 0 , getSegWit = True - , getCashAddrPrefix = Nothing , getBech32Prefix = Just "bcrt" , getReplaceByFee = True , getHalvingInterval = 150 } --- | Bitcoin Cash network. Symbol: BCH. -bch :: Network -bch = - Network - { getNetworkName = "bch" - , getAddrPrefix = 0 - , getScriptPrefix = 5 - , getSecretPrefix = 128 - , getExtPubKeyPrefix = 0x0488b21e - , getExtSecretPrefix = 0x0488ade4 - , getNetworkMagic = 0xe3e1f3e8 - , getGenesisHeader = - BlockHeader - 0x01 - "0000000000000000000000000000000000000000000000000000000000000000" - (buildMerkleRoot [txHash genesisTx]) - 1231006505 - 0x1d00ffff - 2083236893 - , -- Hash 000000000019d6689c085ae165831e934ff763ae46a2a6c172b3f1b60a8ce26f - getMaxBlockSize = 32000000 - , getMaxSatoshi = 2100000000000000 - , getHaskoinUserAgent = "/haskoin-bch:" <> versionString <> "/" - , getDefaultPort = 8333 - , getAllowMinDifficultyBlocks = False - , getPowNoRetargetting = False - , getPowLimit = - 0x00000000ffffffffffffffffffffffffffffffffffffffffffffffffffffffff - , getBip34Block = - ( 227931 - , "000000000000024b89b42a942fe0d9fea3bb44ab7bd1b19115dd6a759c0808b8" - ) - , getBip65Height = 388381 - , getBip66Height = 363725 - , getTargetTimespan = 14 * 24 * 60 * 60 - , getTargetSpacing = 10 * 60 - , getCheckpoints = - [ - ( 11111 - , "0000000069e244f73d78e8fd29ba2fd2ed618bd6fa2ee92559f542fdb26e7c1d" - ) - , - ( 33333 - , "000000002dd5588a74784eaa7ab0507a18ad16a236e7b1ce69f00d7ddfb5d0a6" - ) - , - ( 74000 - , "0000000000573993a3c9e41ce34471c079dcf5f52a0e824a81e7f953b8661a20" - ) - , - ( 105000 - , "00000000000291ce28027faea320c8d2b054b2e0fe44a773f3eefb151d6bdc97" - ) - , - ( 134444 - , "00000000000005b12ffd4cd315cd34ffd4a594f430ac814c91184a0d42d2b0fe" - ) - , - ( 168000 - , "000000000000099e61ea72015e79632f216fe6cb33d7899acb35b75c8303b763" - ) - , - ( 193000 - , "000000000000059f452a5f7340de6682a977387c17010ff6e6c3bd83ca8b1317" - ) - , - ( 210000 - , "000000000000048b95347e83192f69cf0366076336c639f9b7228e9ba171342e" - ) - , - ( 216116 - , "00000000000001b4f4b433e81ee46494af945cf96014816a4e2370f11b23df4e" - ) - , - ( 225430 - , "00000000000001c108384350f74090433e7fcf79a606b8e797f065b130575932" - ) - , - ( 250000 - , "000000000000003887df1f29024b06fc2200b55f8af8f35453d7be294df2d214" - ) - , - ( 279000 - , "0000000000000001ae8c72a0b0c301f67e3afca10e819efa9041e458e9bd7e40" - ) - , - ( 295000 - , "00000000000000004d9b4ef50f0f9d686fd69db2e03af35a100370c64632a983" - ) - , -- UAHF fork block. - - ( 478559 - , "000000000000000000651ef99cb9fcbe0dadde1d424bd9f15ff20136191a5eec" - ) - , -- Nov, 13 DAA activation block. - - ( 504031 - , "0000000000000000011ebf65b60d0a3de80b8175be709d653b4c1a1beeb6ab9c" - ) - ] - , getSeeds = - [ "seed.bitcoinabc.org" - , "seed-bch.bitcoinforks.org" - , "btccash-seeder.bitcoinunlimited.info" - , "seed.bchd.cash" - , "seed.bch.loping.net" - , "dnsseed.electroncash.de" - ] - , getBip44Coin = 145 - , getSigHashForkId = Just 0 - , getEdaBlockHeight = Just 478559 - , getDaaBlockHeight = Just 404031 - , getAsertActivationTime = Just 1605441600 - , getAsertHalfLife = 60 * 60 * 10 - , getSegWit = False - , getCashAddrPrefix = Just "bitcoincash" - , getBech32Prefix = Nothing - , getReplaceByFee = False - , getHalvingInterval = 210000 - } - --- | Testnet for Bitcoin Cash network. -bchTest4 :: Network -bchTest4 = - Network - { getNetworkName = "bchtest4" - , getAddrPrefix = 111 - , getScriptPrefix = 196 - , getSecretPrefix = 239 - , getExtPubKeyPrefix = 0x043587cf - , getExtSecretPrefix = 0x04358394 - , getNetworkMagic = 0xe2b7daaf - , getGenesisHeader = - BlockHeader - 0x01 - "0000000000000000000000000000000000000000000000000000000000000000" - (buildMerkleRoot [txHash genesisTx]) - 1597811185 - 0x1d00ffff - 114152193 - , -- Hash 000000000933ea01ad0ee984209779baaec3ced90fa3f408719526f8d77f4943 - getMaxBlockSize = 2000000 - , getMaxSatoshi = 2100000000000000 - , getHaskoinUserAgent = "/haskoin-bch-test4:" <> versionString <> "/" - , getDefaultPort = 28333 - , getAllowMinDifficultyBlocks = True - , getPowNoRetargetting = False - , getPowLimit = - 0x00000000ffffffffffffffffffffffffffffffffffffffffffffffffffffffff - , getBip34Block = - ( 2 - , "00000000b0c65b1e03baace7d5c093db0d6aac224df01484985ffd5e86a1a20c" - ) - , getBip65Height = 3 - , getBip66Height = 4 - , getTargetTimespan = 14 * 24 * 60 * 60 - , getTargetSpacing = 10 * 60 - , getCheckpoints = - [ - ( 5000 - , "000000009f092d074574a216faec682040a853c4f079c33dfd2c3ef1fd8108c4" - ) - , -- Axion activation - - ( 16845 - , "00000000fb325b8f34fe80c96a5f708a08699a68bbab82dba4474d86bd743077" - ) - , - ( 38000 - , "000000000015197537e59f339e3b1bbf81a66f691bd3d7aa08560fc7bf5113fb" - ) - , - ( 54700 - , "00000000009af4379d87f17d0f172ee4769b48839a5a3a3e81d69da4322518b8" - ) - ] - , getSeeds = - [ "testnet4-seed-bch.bitcoinforks.org" - , "testnet4-seed-bch.toom.im" - , "seed.tbch4.loping.net" - , "testnet4-seed.flowee.cash" - ] - , getBip44Coin = 1 - , getSigHashForkId = Just 0 - , getEdaBlockHeight = Just 7 - , getDaaBlockHeight = Just 3000 - , getAsertActivationTime = Just 1605441600 - , getAsertHalfLife = 60 * 60 - , getSegWit = False - , getCashAddrPrefix = Just "bchtest" - , getBech32Prefix = Nothing - , getReplaceByFee = False - , getHalvingInterval = 210000 - } - --- | Testnet for Bitcoin Cash network. -bchTest :: Network -bchTest = - Network - { getNetworkName = "bchtest" - , getAddrPrefix = 111 - , getScriptPrefix = 196 - , getSecretPrefix = 239 - , getExtPubKeyPrefix = 0x043587cf - , getExtSecretPrefix = 0x04358394 - , getNetworkMagic = 0xf4e5f3f4 - , getGenesisHeader = - BlockHeader - 0x01 - "0000000000000000000000000000000000000000000000000000000000000000" - (buildMerkleRoot [txHash genesisTx]) - 1296688602 - 486604799 - 414098458 - , -- Hash 000000000933ea01ad0ee984209779baaec3ced90fa3f408719526f8d77f4943 - getMaxBlockSize = 32000000 - , getMaxSatoshi = 2100000000000000 - , getHaskoinUserAgent = "/haskoin-bch-test:" <> versionString <> "/" - , getDefaultPort = 18333 - , getAllowMinDifficultyBlocks = True - , getPowNoRetargetting = False - , getPowLimit = - 0x00000000ffffffffffffffffffffffffffffffffffffffffffffffffffffffff - , getBip34Block = - ( 21111 - , "0000000023b3a96d3484e5abb3755c413e7d41500f8e2a5c3f0dd01299cd8ef8" - ) - , getBip65Height = 581885 - , getBip66Height = 330776 - , getTargetTimespan = 14 * 24 * 60 * 60 - , getTargetSpacing = 10 * 60 - , getCheckpoints = - [ - ( 546 - , "000000002a936ca763904c3c35fce2f3556c559c0214345d31b1bcebf76acb70" - ) - , -- UAHF fork block. - - ( 1155876 - , "00000000000e38fef93ed9582a7df43815d5c2ba9fd37ef70c9a0ea4a285b8f5" - ) - , -- Nov, 13. DAA activation block. - - ( 1188697 - , "0000000000170ed0918077bde7b4d36cc4c91be69fa09211f748240dabe047fb" - ) - ] - , getSeeds = - [ "testnet-seed.bitcoinabc.org" - , "testnet-seed-bch.bitcoinforks.org" - , "testnet-seed.bchd.cash" - , "seed.tbch.loping.net" - ] - , getBip44Coin = 1 - , getSigHashForkId = Just 0 - , getEdaBlockHeight = Just 1155876 - , getDaaBlockHeight = Just 1188697 - , getAsertActivationTime = Just 1605441600 - , getAsertHalfLife = 60 * 60 - , getSegWit = False - , getCashAddrPrefix = Just "bchtest" - , getBech32Prefix = Nothing - , getReplaceByFee = False - , getHalvingInterval = 210000 - } - --- | RegTest for Bitcoin Cash network. -bchRegTest :: Network -bchRegTest = - Network - { getNetworkName = "bchreg" - , getAddrPrefix = 111 - , getScriptPrefix = 196 - , getSecretPrefix = 239 - , getExtPubKeyPrefix = 0x043587cf - , getExtSecretPrefix = 0x04358394 - , getNetworkMagic = 0xdab5bffa - , getGenesisHeader = - BlockHeader - -- 0f9188f13cb7b2c71f2a335e3a4fc328bf5beb436012afca590b1a11466e2206 - 0x01 - "0000000000000000000000000000000000000000000000000000000000000000" - (buildMerkleRoot [txHash genesisTx]) - 1296688602 - 0x207fffff - 2 - , getMaxBlockSize = 1000000 - , getMaxSatoshi = 2100000000000000 - , getHaskoinUserAgent = "/haskoin-bch-regtest:" <> versionString <> "/" - , getDefaultPort = 18444 - , getAllowMinDifficultyBlocks = True - , getPowNoRetargetting = True - , getPowLimit = - 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff - , getBip34Block = - ( 100000000 - , "0000000000000000000000000000000000000000000000000000000000000000" - ) - , getBip65Height = 1351 - , getBip66Height = 1251 - , getTargetTimespan = 14 * 24 * 60 * 60 - , getTargetSpacing = 10 * 60 - , getCheckpoints = - [ - ( 0 - , "0f9188f13cb7b2c71f2a335e3a4fc328bf5beb436012afca590b1a11466e2206" - ) - ] - , getSeeds = ["localhost"] - , getBip44Coin = 1 - , getSigHashForkId = Just 0 - , getEdaBlockHeight = Nothing - , getDaaBlockHeight = Just 0 - , getAsertActivationTime = Just 1605441600 - , getAsertHalfLife = 2 * 24 * 60 * 60 - , getSegWit = False - , getCashAddrPrefix = Just "bchreg" - , getBech32Prefix = Nothing - , getReplaceByFee = False - , getHalvingInterval = 150 - } -- | List of all networks supported by this library. allNets :: [Network] -allNets = [btc, bch, btcTest, bchTest4, bchTest, btcRegTest, bchRegTest] +allNets = [btc, btcTest, btcRegTest] diff --git a/src/Haskoin/Crypto/Hash.hs b/src/Haskoin/Crypto/Hash.hs index 41102173..937ca231 100644 --- a/src/Haskoin/Crypto/Hash.hs +++ b/src/Haskoin/Crypto/Hash.hs @@ -2,17 +2,16 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeApplications #-} -{- | -Module : Haskoin.Crypto.Hash -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Hashing functions and corresponding data types. Uses functions from the -cryptonite library. --} +-- | +--Module : Haskoin.Crypto.Hash +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX +-- +--Hashing functions and corresponding data types. Uses functions from the +--cryptonite library. module Haskoin.Crypto.Hash ( -- * Hashes Hash512 (getHash512), @@ -45,7 +44,6 @@ import Crypto.Hash ( hashWith, ) import Crypto.MAC.HMAC (HMAC, hmac) -import Data.Binary (Binary (..)) import Data.ByteArray (ByteArrayAccess) import qualified Data.ByteArray as BA import Data.ByteString (ByteString) @@ -57,7 +55,6 @@ import qualified Data.Bytes.Put as Put import Data.Bytes.Serial (Serial (..)) import Data.Either (fromRight) import Data.Hashable (Hashable) -import Data.Serialize (Serialize (..)) import Data.String (IsString, fromString) import Data.String.Conversions (cs) import Data.Word (Word32) @@ -65,56 +62,59 @@ import GHC.Generics (Generic) import Haskoin.Util import Text.Read as R + -- | 'Word32' wrapped for type-safe 32-bit checksums. newtype CheckSum32 = CheckSum32 { getCheckSum32 :: Word32 } deriving (Eq, Ord, Serial, Show, Read, Hashable, Generic, NFData) -instance Serialize CheckSum32 where - put = serialize - get = deserialize - -instance Binary CheckSum32 where - put = serialize - get = deserialize -- | Type for 512-bit hashes. newtype Hash512 = Hash512 {getHash512 :: ShortByteString} deriving (Eq, Ord, Hashable, Generic, NFData) + -- | Type for 256-bit hashes. newtype Hash256 = Hash256 {getHash256 :: ShortByteString} deriving (Eq, Ord, Hashable, Generic, NFData) + -- | Type for 160-bit hashes. newtype Hash160 = Hash160 {getHash160 :: ShortByteString} deriving (Eq, Ord, Hashable, Generic, NFData) + instance Show Hash512 where showsPrec _ = shows . encodeHex . BSS.fromShort . getHash512 + instance Read Hash512 where readPrec = do R.String str <- lexP maybe pfail return $ Hash512 . BSS.toShort <$> decodeHex (cs str) + instance Show Hash256 where showsPrec _ = shows . encodeHex . BSS.fromShort . getHash256 + instance Read Hash256 where readPrec = do R.String str <- lexP maybe pfail return $ Hash256 . BSS.toShort <$> decodeHex (cs str) + instance Show Hash160 where showsPrec _ = shows . encodeHex . BSS.fromShort . getHash160 + instance Read Hash160 where readPrec = do R.String str <- lexP maybe pfail return $ Hash160 . BSS.toShort <$> decodeHex (cs str) + instance IsString Hash512 where fromString str = case decodeHex $ cs str of @@ -123,20 +123,14 @@ instance IsString Hash512 where case BS.length bs of 64 -> Hash512 (BSS.toShort bs) _ -> e - where - e = error "Could not decode hash from hex string" + where + e = error "Could not decode hash from hex string" + instance Serial Hash512 where deserialize = Hash512 . BSS.toShort <$> Get.getByteString 64 serialize = Put.putByteString . BSS.fromShort . getHash512 -instance Serialize Hash512 where - put = serialize - get = deserialize - -instance Binary Hash512 where - put = serialize - get = deserialize instance IsString Hash256 where fromString str = @@ -146,20 +140,14 @@ instance IsString Hash256 where case BS.length bs of 32 -> Hash256 (BSS.toShort bs) _ -> e - where - e = error "Could not decode hash from hex string" + where + e = error "Could not decode hash from hex string" + instance Serial Hash256 where deserialize = Hash256 . BSS.toShort <$> Get.getByteString 32 serialize = Put.putByteString . BSS.fromShort . getHash256 -instance Serialize Hash256 where - put = serialize - get = deserialize - -instance Binary Hash256 where - put = serialize - get = deserialize instance IsString Hash160 where fromString str = @@ -169,47 +157,47 @@ instance IsString Hash160 where case BS.length bs of 20 -> Hash160 (BSS.toShort bs) _ -> e - where - e = error "Could not decode hash from hex string" + where + e = error "Could not decode hash from hex string" + instance Serial Hash160 where deserialize = Hash160 . BSS.toShort <$> Get.getByteString 20 serialize = Put.putByteString . BSS.fromShort . getHash160 -instance Serialize Hash160 where - put = serialize - get = deserialize - -instance Binary Hash160 where - put = serialize - get = deserialize -- | Calculate SHA512 hash. sha512 :: ByteArrayAccess b => b -> Hash512 sha512 = Hash512 . BSS.toShort . BA.convert . hashWith SHA512 + -- | Calculate SHA256 hash. sha256 :: ByteArrayAccess b => b -> Hash256 sha256 = Hash256 . BSS.toShort . BA.convert . hashWith SHA256 + -- | Calculate RIPEMD160 hash. ripemd160 :: ByteArrayAccess b => b -> Hash160 ripemd160 = Hash160 . BSS.toShort . BA.convert . hashWith RIPEMD160 + -- | Claculate SHA1 hash. sha1 :: ByteArrayAccess b => b -> Hash160 sha1 = Hash160 . BSS.toShort . BA.convert . hashWith SHA1 + -- | Compute two rounds of SHA-256. doubleSHA256 :: ByteArrayAccess b => b -> Hash256 doubleSHA256 = Hash256 . BSS.toShort . BA.convert . hashWith SHA256 . hashWith SHA256 + -- | Compute SHA-256 followed by RIPMED-160. addressHash :: ByteArrayAccess b => b -> Hash160 addressHash = Hash160 . BSS.toShort . BA.convert . hashWith RIPEMD160 . hashWith SHA256 + {- CheckSum -} -- | Computes a 32 bit checksum. @@ -222,6 +210,7 @@ checkSum32 = . hashWith SHA256 . hashWith SHA256 + {- HMAC -} -- | Computes HMAC over SHA-512. @@ -229,17 +218,20 @@ 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 + where + (a, b) = BS.splitAt 32 . BSS.fromShort $ getHash512 h + -- | Join a pair of 'Hash256' into a 'Hash512'. join512 :: (Hash256, Hash256) -> Hash512 @@ -248,10 +240,10 @@ join512 (a, b) = . BSS.toShort $ BSS.fromShort (getHash256 a) `BS.append` BSS.fromShort (getHash256 b) -{- | Initialize tagged hash specified in BIP340 -@since 0.21.0 --} +-- | Initialize tagged hash specified in BIP340 +-- +-- @since 0.21.0 initTaggedHash :: -- | Hash tag ByteString -> @@ -259,5 +251,5 @@ initTaggedHash :: initTaggedHash tag = (`hashUpdates` [hashedTag, hashedTag]) $ hashInit @SHA256 - where - hashedTag = hashWith SHA256 tag + where + hashedTag = hashWith SHA256 tag diff --git a/src/Haskoin/Crypto/Signature.hs b/src/Haskoin/Crypto/Signature.hs index 31e24047..1bd34f93 100644 --- a/src/Haskoin/Crypto/Signature.hs +++ b/src/Haskoin/Crypto/Signature.hs @@ -1,16 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} -{- | -Module : Haskoin.Crypto.Signature -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -ECDSA signatures using secp256k1 curve. Uses functions from upstream secp256k1 -library. --} +-- | +--Module : Haskoin.Crypto.Signature +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX +-- +--ECDSA signatures using secp256k1 curve. Uses functions from upstream secp256k1 +--library. module Haskoin.Crypto.Signature ( -- * Signatures putSig, @@ -24,33 +23,35 @@ module Haskoin.Crypto.Signature ( import Control.Monad (guard, unless, when) import Crypto.Secp256k1 -import Data.Binary (Binary (..)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial import Data.Maybe (fromMaybe, isNothing) -import Data.Serialize (Serialize (..)) import Haskoin.Crypto.Hash import Numeric (showHex) + -- | Convert 256-bit hash into a 'Msg' for signing or verification. hashToMsg :: Hash256 -> Msg hashToMsg = fromMaybe e . msg . runPutS . serialize - where - e = error "Could not convert 32-byte hash to secp256k1 message" + where + e = error "Could not convert 32-byte hash to secp256k1 message" + -- | Sign a 256-bit hash using secp256k1 elliptic curve. signHash :: SecKey -> Hash256 -> Sig signHash k = signMsg k . hashToMsg + -- | Verify an ECDSA signature for a 256-bit hash. verifyHashSig :: Hash256 -> Sig -> PubKey -> Bool verifyHashSig h s p = verifySig p norm (hashToMsg h) - where - norm = fromMaybe s (normalizeSig s) + where + norm = fromMaybe s (normalizeSig s) + -- | Deserialize an ECDSA signature as commonly encoded in Bitcoin. getSig :: MonadGet m => m Sig @@ -71,14 +72,17 @@ getSig = do Just s -> return s Nothing -> fail "Invalid signature" + -- | Serialize an ECDSA signature for Bitcoin use. putSig :: MonadPut m => Sig -> m () putSig s = putByteString $ exportSig s + -- | Is canonical half order. isCanonicalHalfOrder :: Sig -> Bool isCanonicalHalfOrder = isNothing . normalizeSig + -- | Decode signature strictly. decodeStrictSig :: ByteString -> Maybe Sig decodeStrictSig bs = do diff --git a/src/Haskoin/Data.hs b/src/Haskoin/Data.hs index bb03fdcb..b2220420 100644 --- a/src/Haskoin/Data.hs +++ b/src/Haskoin/Data.hs @@ -6,13 +6,11 @@ module Haskoin.Data ( ) where import Control.DeepSeq -import Data.Binary (Binary (..)) import Data.ByteString (ByteString) import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial import Data.List -import Data.Serialize (Serialize (..)) import Data.String import Data.Text (Text) import Data.Word (Word32, Word64, Word8) @@ -20,6 +18,7 @@ import GHC.Generics (Generic) import Haskoin.Block.Common import Text.Read + -- | Network definition. data Network = Network { -- | lowercase alphanumeric and dashes @@ -74,15 +73,8 @@ data Network = Network getEdaBlockHeight :: !(Maybe Word32) , -- | DAA start block height getDaaBlockHeight :: !(Maybe Word32) - , -- | asert3-2d algorithm activation time - -- TODO: Replace with block height after fork - getAsertActivationTime :: !(Maybe Word32) - , -- | asert3-2d algorithm halflife (not used for non-BCH networks) - getAsertHalfLife :: !Integer , -- | segregated witness active getSegWit :: !Bool - , -- | 'CashAddr' prefix (for Bitcoin Cash) - getCashAddrPrefix :: !(Maybe Text) , -- | 'Bech32' prefix (for SegWit network) getBech32Prefix :: !(Maybe Text) , -- | Replace-By-Fee (BIP-125) diff --git a/src/Haskoin/Keys/Common.hs b/src/Haskoin/Keys/Common.hs index c88c0f97..a72cfd95 100644 --- a/src/Haskoin/Keys/Common.hs +++ b/src/Haskoin/Keys/Common.hs @@ -6,16 +6,15 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -{- | -Module : Haskoin.Keys.Common -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -ECDSA private and public key functions. --} +-- | +--Module : Haskoin.Keys.Common +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX +-- +--ECDSA private and public key functions. module Haskoin.Keys.Common ( -- * Public & Private Keys PubKeyI (..), @@ -39,15 +38,6 @@ module Haskoin.Keys.Common ( import Control.DeepSeq import Control.Monad (guard, mzero, (<=<)) import Crypto.Secp256k1 -import Data.Aeson ( - FromJSON, - ToJSON (..), - Value (String), - parseJSON, - withText, - ) -import Data.Aeson.Encoding (unsafeToEncoding) -import Data.Binary (Binary (..)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Builder (char7) @@ -56,7 +46,6 @@ import Data.Bytes.Put import Data.Bytes.Serial import Data.Hashable import Data.Maybe (fromMaybe) -import Data.Serialize (Serialize (..)) import Data.String (IsString, fromString) import Data.String.Conversions (cs) import GHC.Generics (Generic) @@ -65,6 +54,7 @@ import Haskoin.Crypto.Hash import Haskoin.Data import Haskoin.Util + -- | Elliptic curve public key type with expected serialized compression flag. data PubKeyI = PubKeyI { pubKeyPoint :: !PubKey @@ -72,98 +62,86 @@ data PubKeyI = PubKeyI } deriving (Generic, Eq, Show, Read, Hashable, NFData) + instance IsString PubKeyI where fromString str = fromMaybe e $ eitherToMaybe . runGetS deserialize <=< decodeHex $ cs str - where - e = error "Could not decode public key" - -instance ToJSON PubKeyI where - toJSON = String . encodeHex . runPutS . serialize - toEncoding s = - unsafeToEncoding $ - char7 '"' - <> hexBuilder (runPutL (serialize s)) - <> char7 '"' - -instance FromJSON PubKeyI where - parseJSON = - withText "PubKeyI" $ - maybe mzero return . ((eitherToMaybe . runGetS deserialize) <=< decodeHex) + where + e = error "Could not decode public key" + instance Serial PubKeyI where deserialize = s >>= \case True -> c False -> u - where - s = - lookAhead $ - getWord8 >>= \case - 0x02 -> return True - 0x03 -> return True - 0x04 -> return False - _ -> fail "Not a public key" - c = do - bs <- getByteString 33 - maybe (fail "Could not decode public key") return $ - PubKeyI <$> importPubKey bs <*> pure True - u = do - bs <- getByteString 65 - maybe (fail "Could not decode public key") return $ - PubKeyI <$> importPubKey bs <*> pure False + where + s = + lookAhead $ + getWord8 >>= \case + 0x02 -> return True + 0x03 -> return True + 0x04 -> return False + _ -> fail "Not a public key" + c = do + bs <- getByteString 33 + maybe (fail "Could not decode public key") return $ + PubKeyI <$> importPubKey bs <*> pure True + u = do + bs <- getByteString 65 + maybe (fail "Could not decode public key") return $ + PubKeyI <$> importPubKey bs <*> pure False - serialize pk = putByteString $ exportPubKey (pubKeyCompressed pk) (pubKeyPoint pk) -instance Serialize PubKeyI where - put = serialize - get = deserialize + serialize pk = putByteString $ exportPubKey (pubKeyCompressed pk) (pubKeyPoint pk) -instance Binary PubKeyI where - put = serialize - get = deserialize -- | Wrap a public key from secp256k1 library adding information about compression. wrapPubKey :: Bool -> PubKey -> PubKeyI wrapPubKey c p = PubKeyI p c -{- | Derives a public key from a private key. This function will preserve - compression flag. --} + +-- | Derives a public key from a private key. This function will preserve +-- compression flag. derivePubKeyI :: SecKeyI -> PubKeyI derivePubKeyI (SecKeyI d c) = PubKeyI (derivePubKey d) c + -- | Tweak a public key. tweakPubKey :: PubKey -> Hash256 -> Maybe PubKey tweakPubKey p h = tweakAddPubKey p =<< tweak (runPutS (serialize h)) -{- | Elliptic curve private key type with expected public key compression - information. Compression information is stored in private key WIF formats and - needs to be preserved to generate the correct address from the corresponding - public key. --} + +-- | Elliptic curve private key type with expected public key compression +-- information. Compression information is stored in private key WIF formats and +-- needs to be preserved to generate the correct address from the corresponding +-- public key. data SecKeyI = SecKeyI { secKeyData :: !SecKey , secKeyCompressed :: !Bool } deriving (Eq, Show, Read, Generic, NFData) + -- | Wrap private key with corresponding public key compression flag. wrapSecKey :: Bool -> SecKey -> SecKeyI wrapSecKey c d = SecKeyI d c + -- | Tweak a private key. tweakSecKey :: SecKey -> Hash256 -> Maybe SecKey tweakSecKey key h = tweakAddSecKey key =<< tweak (runPutS (serialize h)) + -- | Decode Casascius mini private keys (22 or 30 characters). fromMiniKey :: ByteString -> Maybe SecKeyI fromMiniKey bs = do guard checkShortKey wrapSecKey False <$> secKey (runPutS (serialize (sha256 bs))) - where - checkHash = runPutS $ serialize $ sha256 $ bs `BS.append` "?" - checkShortKey = BS.length bs `elem` [22, 30] && BS.head checkHash == 0x00 + where + checkHash = runPutS $ serialize $ sha256 $ bs `BS.append` "?" + checkShortKey = BS.length bs `elem` [22, 30] && BS.head checkHash == 0x00 + -- | Decode private key from WIF (wallet import format) string. fromWif :: Network -> Base58 -> Maybe SecKeyI @@ -181,6 +159,7 @@ fromWif net wif = do -- Bad length _ -> Nothing + -- | Encode private key into a WIF string. toWif :: Network -> SecKeyI -> Base58 toWif net (SecKeyI k c) = diff --git a/src/Haskoin/Keys/Extended.hs b/src/Haskoin/Keys/Extended.hs index 4cbfe109..367be7ef 100644 --- a/src/Haskoin/Keys/Extended.hs +++ b/src/Haskoin/Keys/Extended.hs @@ -4,16 +4,15 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{- | -Module : Haskoin.Keys.Extended -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -BIP-32 extended keys. --} +-- | +--Module : Haskoin.Keys.Extended +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX +-- +--BIP-32 extended keys. module Haskoin.Keys.Extended ( -- * Extended Keys XPubKey (..), @@ -41,13 +40,7 @@ module Haskoin.Keys.Extended ( xPubWitnessAddr, xPubCompatWitnessAddr, xPubExport, - xPubToJSON, - xPubToEncoding, - xPubFromJSON, xPrvExport, - xPrvToJSON, - xPrvToEncoding, - xPrvFromJSON, xPubImport, xPrvImport, xPrvWif, @@ -110,17 +103,6 @@ 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.Binary (Binary (get, put)) import Data.Bits (clearBit, setBit, testBit) import Data.ByteString (ByteString) import qualified Data.ByteString as B @@ -132,8 +114,6 @@ import Data.Hashable import Data.List (foldl') import Data.List.Split (splitOn) import Data.Maybe (fromMaybe) -import Data.Serialize (Serialize (..)) -import qualified Data.Serialize as S import Data.String (IsString, fromString) import Data.String.Conversions (cs) import qualified Data.Text as Text @@ -154,24 +134,27 @@ import Haskoin.Util import Text.Read as R import Text.Read.Lex -{- | A derivation exception is thrown in the very unlikely event that a - derivation is invalid. --} + +-- | A derivation exception is thrown in the very unlikely event that a +-- derivation is invalid. newtype DerivationException = DerivationException String deriving (Eq, Read, Show, Typeable, Generic, NFData) + instance Exception DerivationException + -- | Chain code as specified in BIP-32. type ChainCode = Hash256 + -- | Index of key as specified in BIP-32. type KeyIndex = Word32 -{- | Data type representing an extended BIP32 private key. An extended key - is a node in a tree of key derivations. It has a depth in the tree, a - parent node and an index to differentiate it from other siblings. --} + +-- | Data type representing an extended BIP32 private key. An extended key +-- is a node in a tree of key derivations. It has a depth in the tree, a +-- parent node and an index to differentiate it from other siblings. data XPrvKey = XPrvKey { -- | depth in the tree xPrvDepth :: !Word8 @@ -186,6 +169,7 @@ data XPrvKey = XPrvKey } deriving (Generic, Eq, Show, Read, NFData, Hashable) + instance Serial XPrvKey where serialize k = do putWord8 $ xPrvDepth k @@ -200,27 +184,6 @@ instance Serial XPrvKey where <*> deserialize <*> getPadPrvKey -instance Binary XPrvKey where - put = serialize - get = deserialize - -instance Serialize XPrvKey where - put = serialize - get = deserialize - -xPrvToJSON :: Network -> XPrvKey -> Value -xPrvToJSON net = A.String . xPrvExport net - -xPrvToEncoding :: Network -> XPrvKey -> Encoding -xPrvToEncoding net = text . xPrvExport net - --- | Decode an extended private key from a JSON string -xPrvFromJSON :: Network -> Value -> Parser XPrvKey -xPrvFromJSON net = - withText "xprv" $ \t -> - case xPrvImport net t of - Nothing -> fail "could not read xprv" - Just x -> return x -- | Data type representing an extended BIP32 public key. data XPubKey = XPubKey @@ -237,6 +200,7 @@ data XPubKey = XPubKey } deriving (Generic, Eq, Show, Read, NFData, Hashable) + instance Serial XPubKey where serialize k = do putWord8 $ xPubDepth k @@ -251,57 +215,34 @@ instance Serial XPubKey where <*> deserialize <*> (pubKeyPoint <$> deserialize) -instance Serialize XPubKey where - put = serialize - get = deserialize - -instance Binary XPubKey where - put = serialize - get = deserialize - --- | Decode an extended public key from a JSON string -xPubFromJSON :: Network -> Value -> Parser XPubKey -xPubFromJSON net = - 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 - -{- | Build a BIP32 compatible extended private key from a bytestring. This will - produce a root node (@depth=0@ and @parent=0@). --} +-- | Build a BIP32 compatible extended private key from a bytestring. This will +-- produce a root node (@depth=0@ and @parent=0@). makeXPrvKey :: ByteString -> XPrvKey makeXPrvKey bs = XPrvKey 0 (Fingerprint 0) 0 c k - where - (p, c) = split512 $ hmac512 "Bitcoin seed" bs - k = fromMaybe err (secKey (runPutS (serialize p))) - err = throw $ DerivationException "Invalid seed" - -{- | Derive an extended public key from an extended private key. This function - will preserve the depth, parent, index and chaincode fields of the extended - private keys. --} + where + (p, c) = split512 $ hmac512 "Bitcoin seed" bs + k = fromMaybe err (secKey (runPutS (serialize p))) + err = throw $ DerivationException "Invalid seed" + + +-- | Derive an extended public key from an extended private key. This function +-- will preserve the depth, parent, index and chaincode fields of the extended +-- private keys. deriveXPubKey :: XPrvKey -> XPubKey deriveXPubKey (XPrvKey d p i c k) = XPubKey d p i c (derivePubKey k) -{- | Compute a private, soft child key derivation. A private soft derivation - will allow the equivalent extended public key to derive the public key for - this child. Given a parent key /m/ and a derivation index /i/, this function - will compute /m\/i/. - Soft derivations allow for more flexibility such as read-only wallets. - However, care must be taken not the leak both the parent extended public key - and one of the extended child private keys as this would compromise the - extended parent private key. --} +-- | Compute a private, soft child key derivation. A private soft derivation +-- will allow the equivalent extended public key to derive the public key for +-- this child. Given a parent key /m/ and a derivation index /i/, this function +-- will compute /m\/i/. +-- +-- Soft derivations allow for more flexibility such as read-only wallets. +-- However, care must be taken not the leak both the parent extended public key +-- and one of the extended child private keys as this would compromise the +-- extended parent private key. prvSubKey :: -- | extended parent private key XPrvKey -> @@ -313,16 +254,16 @@ 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) (runPutS (serialize child)) - (a, c) = split512 $ hmac512 (runPutS $ serialize $ 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/. --} + where + pK = xPubKey $ deriveXPubKey xkey + m = B.append (exportPubKey True pK) (runPutS (serialize child)) + (a, c) = split512 $ hmac512 (runPutS $ serialize $ 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 :: -- | extended parent public key XPubKey -> @@ -334,19 +275,19 @@ 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)) (runPutS $ serialize child) - (a, c) = split512 $ hmac512 (runPutS $ serialize $ 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'/. --} + where + m = B.append (exportPubKey True (xPubKey xKey)) (runPutS $ serialize child) + (a, c) = split512 $ hmac512 (runPutS $ serialize $ 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 :: -- | extended parent private key XPrvKey -> @@ -358,98 +299,108 @@ 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) (runPutS $ serialize i) - (a, c) = split512 $ hmac512 (runPutS $ serialize $ 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. --} + where + i = setBit child 31 + m = B.append (bsPadPrvKey $ xPrvKey xkey) (runPutS $ serialize i) + (a, c) = split512 $ hmac512 (runPutS $ serialize $ 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. --} + +-- | Returns true if the extended public key was derived through a hard +-- derivation. xPubIsHard :: XPubKey -> Bool xPubIsHard k = testBit (xPubIndex k) 31 -{- | Returns the derivation index of this extended private key without the hard - bit set. --} + +-- | Returns the derivation index of this extended private key without the hard +-- bit set. xPrvChild :: XPrvKey -> KeyIndex xPrvChild k = clearBit (xPrvIndex k) 31 -{- | Returns the derivation index of this extended public key without the hard - bit set. --} + +-- | Returns the derivation index of this extended public key without the hard +-- bit set. xPubChild :: XPubKey -> KeyIndex xPubChild k = clearBit (xPubIndex k) 31 + -- | Computes the key identifier of an extended private key. xPrvID :: XPrvKey -> Hash160 xPrvID = xPubID . deriveXPubKey + -- | Computes the key identifier of an extended public key. xPubID :: XPubKey -> Hash160 xPubID = ripemd160 . runPutS . serialize . sha256 . exportPubKey True . xPubKey + -- | Computes the key fingerprint of an extended private key. xPrvFP :: XPrvKey -> Fingerprint xPrvFP = fromRight err . runGetS deserialize . B.take 4 . runPutS . serialize . xPrvID - where - err = error "Could not decode xPrvFP" + where + err = error "Could not decode xPrvFP" + -- | Computes the key fingerprint of an extended public key. xPubFP :: XPubKey -> Fingerprint xPubFP = fromRight err . runGetS deserialize . B.take 4 . runPutS . serialize . xPubID - where - err = error "Could not decode xPubFP" + where + err = error "Could not decode xPubFP" + -- | Compute a standard P2PKH address for an extended public key. xPubAddr :: XPubKey -> Address xPubAddr xkey = pubKeyAddr (wrapPubKey True (xPubKey xkey)) + -- | Compute a SegWit P2WPKH address for an extended public key. xPubWitnessAddr :: XPubKey -> Address xPubWitnessAddr xkey = pubKeyWitnessAddr (wrapPubKey True (xPubKey xkey)) -{- | Compute a backwards-compatible SegWit P2SH-P2WPKH address for an extended - public key. --} + +-- | Compute a backwards-compatible SegWit P2SH-P2WPKH address for an extended +-- public key. xPubCompatWitnessAddr :: XPubKey -> Address xPubCompatWitnessAddr xkey = pubKeyCompatWitnessAddr (wrapPubKey True (xPubKey xkey)) + -- | Exports an extended private key to the BIP32 key export format ('Base58'). xPrvExport :: Network -> XPrvKey -> Base58 xPrvExport net = encodeBase58Check . runPutS . putXPrvKey net + -- | Exports an extended public key to the BIP32 key export format ('Base58'). xPubExport :: Network -> XPubKey -> Base58 xPubExport net = encodeBase58Check . runPutS . putXPubKey net -{- | Decodes a BIP32 encoded extended private key. This function will fail if - invalid base 58 characters are detected or if the checksum fails. --} + +-- | Decodes a BIP32 encoded extended private key. This function will fail if +-- invalid base 58 characters are detected or if the checksum fails. xPrvImport :: Network -> Base58 -> Maybe XPrvKey xPrvImport net = eitherToMaybe . runGetS (getXPrvKey net) <=< decodeBase58Check -{- | Decodes a BIP32 encoded extended public key. This function will fail if - invalid base 58 characters are detected or if the checksum fails. --} + +-- | Decodes a BIP32 encoded extended public key. This function will fail if +-- invalid base 58 characters are detected or if the checksum fails. xPubImport :: Network -> Base58 -> Maybe XPubKey xPubImport net = eitherToMaybe . runGetS (getXPubKey net) <=< decodeBase58Check + -- | Export an extended private key to WIF (Wallet Import Format). xPrvWif :: Network -> XPrvKey -> Base58 xPrvWif net xkey = toWif net (wrapSecKey True (xPrvKey xkey)) + -- | Parse a binary extended private key. getXPrvKey :: MonadGet m => Network -> m XPrvKey getXPrvKey net = do @@ -459,12 +410,14 @@ getXPrvKey net = do "Get: Invalid version for extended private key" deserialize + -- | Serialize an extended private key. putXPrvKey :: MonadPut m => Network -> XPrvKey -> m () putXPrvKey net k = do putWord32be $ getExtSecretPrefix net serialize k + -- | Parse a binary extended public key. getXPubKey :: MonadGet m => Network -> m XPubKey getXPubKey net = do @@ -474,106 +427,110 @@ getXPubKey net = do "Get: Invalid version for extended public key" deserialize + -- | Serialize an extended public key. putXPubKey :: MonadPut m => Network -> XPubKey -> m () putXPubKey net k = do putWord32be $ getExtPubKeyPrefix net serialize k + {- Derivation helpers -} -{- | Cyclic list of all private soft child key derivations of a parent key - starting from an offset index. --} +-- | Cyclic list of all private soft child key derivations of a parent key +-- starting from an offset index. prvSubKeys :: XPrvKey -> KeyIndex -> [(XPrvKey, KeyIndex)] prvSubKeys k = map (\i -> (prvSubKey k i, i)) . cycleIndex -{- | Cyclic list of all public soft child key derivations of a parent key - starting from an offset index. --} + +-- | Cyclic list of all public soft child key derivations of a parent key +-- starting from an offset index. pubSubKeys :: XPubKey -> KeyIndex -> [(XPubKey, KeyIndex)] pubSubKeys k = map (\i -> (pubSubKey k i, i)) . cycleIndex -{- | Cyclic list of all hard child key derivations of a parent key starting - from an offset index. --} + +-- | Cyclic list of all hard child key derivations of a parent key starting +-- from an offset index. hardSubKeys :: XPrvKey -> KeyIndex -> [(XPrvKey, KeyIndex)] hardSubKeys k = map (\i -> (hardSubKey k i, i)) . cycleIndex + -- | Derive a standard address from an extended public key and an index. deriveAddr :: XPubKey -> KeyIndex -> (Address, PubKey) deriveAddr k i = (xPubAddr key, xPubKey key) - where - key = pubSubKey k i + where + key = pubSubKey k i + -- | Derive a SegWit P2WPKH address from an extended public key and an index. deriveWitnessAddr :: XPubKey -> KeyIndex -> (Address, PubKey) deriveWitnessAddr k i = (xPubWitnessAddr key, xPubKey key) - where - key = pubSubKey k i + where + key = pubSubKey k i -{- | Derive a backwards-compatible SegWit P2SH-P2WPKH address from an extended - public key and an index. --} + +-- | Derive a backwards-compatible SegWit P2SH-P2WPKH address from an extended +-- public key and an index. deriveCompatWitnessAddr :: XPubKey -> KeyIndex -> (Address, PubKey) deriveCompatWitnessAddr k i = (xPubCompatWitnessAddr key, xPubKey key) - where - key = pubSubKey k i + where + key = pubSubKey k i + -{- | Cyclic list of all addresses derived from a public key starting from an - offset index. --} +-- | Cyclic list of all addresses derived from a public key starting from an +-- offset index. deriveAddrs :: XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)] deriveAddrs k = map f . cycleIndex - where - f i = let (a, key) = deriveAddr k i in (a, key, i) + where + f i = let (a, key) = deriveAddr k i in (a, key, i) -{- | Cyclic list of all SegWit P2WPKH addresses derived from a public key - starting from an offset index. --} + +-- | Cyclic list of all SegWit P2WPKH addresses derived from a public key +-- starting from an offset index. deriveWitnessAddrs :: XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)] deriveWitnessAddrs k = map f . cycleIndex - where - f i = let (a, key) = deriveWitnessAddr k i in (a, key, i) + where + f i = let (a, key) = deriveWitnessAddr k i in (a, key, i) + -{- | Cyclic list of all backwards-compatible SegWit P2SH-P2WPKH addresses - derived from a public key starting from an offset index. --} +-- | Cyclic list of all backwards-compatible SegWit P2SH-P2WPKH addresses +-- derived from a public key starting from an offset index. deriveCompatWitnessAddrs :: XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)] deriveCompatWitnessAddrs k = map f . cycleIndex - where - f i = let (a, key) = deriveCompatWitnessAddr k i in (a, key, i) + where + f i = let (a, key) = deriveCompatWitnessAddr k i in (a, key, i) + -{- | Derive a multisig address from a list of public keys, the number of - required signatures /m/ and a derivation index. The derivation type is a - public, soft derivation. --} +-- | Derive a multisig address from a list of public keys, the number of +-- required signatures /m/ and a derivation index. The derivation type is a +-- public, soft derivation. deriveMSAddr :: [XPubKey] -> Int -> KeyIndex -> (Address, RedeemScript) deriveMSAddr keys m i = (payToScriptAddress rdm, rdm) - where - rdm = sortMulSig $ PayMulSig k m - k = map (wrapPubKey True . xPubKey . flip pubSubKey i) keys - -{- | Cyclic list of all multisig addresses derived from a list of public keys, - a number of required signatures /m/ and starting from an offset index. The - derivation type is a public, soft derivation. --} + 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) + where + f i = + let (a, rdm) = deriveMSAddr keys m i + in (a, rdm, i) + -- | Helper function to go through derivation indices. cycleIndex :: KeyIndex -> [KeyIndex] @@ -582,73 +539,84 @@ cycleIndex i | i < 0x80000000 = cycle $ [i .. 0x7fffffff] ++ [0 .. (i - 1)] | otherwise = error $ "cycleIndex: invalid index " ++ show i + {- Derivation Paths -} -{- | Phantom type signaling a hardened derivation path that can only be computed - from private extended key. --} +-- | Phantom type signaling a hardened derivation path that can only be computed +-- from private extended key. data HardDeriv deriving (Generic, NFData) + -- | Phantom type signaling no knowledge about derivation path: can be hardened or not. data AnyDeriv deriving (Generic, NFData) -{- | Phantom type signaling derivation path including only non-hardened paths - that can be computed from an extended public key. --} + +-- | Phantom type signaling derivation path including only non-hardened paths +-- that can be computed from an extended public key. data SoftDeriv deriving (Generic, NFData) + -- | Hardened derivation path. Can be computed from extended private key only. type HardPath = DerivPathI HardDeriv + -- | Any derivation path. type DerivPath = DerivPathI AnyDeriv + -- | Non-hardened derivation path can be computed from extended public key. type SoftPath = DerivPathI SoftDeriv + -- | Helper class to perform validations on a hardened derivation path. class HardOrAny a + instance HardOrAny HardDeriv instance HardOrAny AnyDeriv + -- | Helper class to perform validations on a non-hardened derivation path. class AnyOrSoft a + instance AnyOrSoft AnyDeriv instance AnyOrSoft SoftDeriv -{- | Data type representing a derivation path. Two constructors are provided - for specifying soft or hard derivations. The path /\/0\/1'\/2/ for example can be - expressed as @'Deriv' :\/ 0 :| 1 :\/ 2@. The 'HardOrAny' and 'AnyOrSoft' type - classes are used to constrain the valid values for the phantom type /t/. If - you mix hard '(:|)' and soft '(:\/)' paths, the only valid type for /t/ is 'AnyDeriv'. - Otherwise, /t/ can be 'HardDeriv' if you only have hard derivation or 'SoftDeriv' - if you only have soft derivations. - - Using this type is as easy as writing the required derivation like in these - example: - - > Deriv :/ 0 :/ 1 :/ 2 :: SoftPath - > Deriv :| 0 :| 1 :| 2 :: HardPath - > Deriv :| 0 :/ 1 :/ 2 :: DerivPath --} + +-- | Data type representing a derivation path. Two constructors are provided +-- for specifying soft or hard derivations. The path /\/0\/1'\/2/ for example can be +-- expressed as @'Deriv' :\/ 0 :| 1 :\/ 2@. The 'HardOrAny' and 'AnyOrSoft' type +-- classes are used to constrain the valid values for the phantom type /t/. If +-- you mix hard '(:|)' and soft '(:\/)' paths, the only valid type for /t/ is 'AnyDeriv'. +-- Otherwise, /t/ can be 'HardDeriv' if you only have hard derivation or 'SoftDeriv' +-- if you only have soft derivations. +-- +-- Using this type is as easy as writing the required derivation like in these +-- example: +-- +-- > Deriv :/ 0 :/ 1 :/ 2 :: SoftPath +-- > Deriv :| 0 :| 1 :| 2 :: HardPath +-- > Deriv :| 0 :/ 1 :/ 2 :: DerivPath data DerivPathI t where (:|) :: HardOrAny t => !(DerivPathI t) -> !KeyIndex -> DerivPathI t (:/) :: AnyOrSoft t => !(DerivPathI t) -> !KeyIndex -> DerivPathI t Deriv :: DerivPathI t + instance NFData (DerivPathI t) where rnf (a :| b) = rnf a `seq` rnf b rnf (a :/ b) = rnf a `seq` rnf b rnf Deriv = () + instance Eq (DerivPathI t) where (nextA :| iA) == (nextB :| iB) = iA == iB && nextA == nextB (nextA :/ iA) == (nextB :/ iB) = iA == iB && nextA == nextB Deriv == Deriv = True _ == _ = False + instance Ord (DerivPathI t) where -- Same hardness on each side (nextA :| iA) `compare` (nextB :| iB) = @@ -664,17 +632,11 @@ instance Ord (DerivPathI t) where Deriv `compare` _ = LT _ `compare` Deriv = GT + instance Serial DerivPath where deserialize = listToPath <$> getList getWord32be serialize = putList putWord32be . pathToList -instance Serialize DerivPath where - put = serialize - get = deserialize - -instance Binary DerivPath where - put = serialize - get = deserialize instance Serial HardPath where deserialize = @@ -686,13 +648,6 @@ instance Serial HardPath where =<< getList getWord32be serialize = putList putWord32be . pathToList -instance Serialize HardPath where - put = serialize - get = deserialize - -instance Binary HardPath where - put = serialize - get = deserialize instance Serial SoftPath where deserialize = @@ -704,32 +659,27 @@ instance Serial SoftPath where =<< getList getWord32be serialize = putList putWord32be . pathToList -instance Serialize SoftPath where - put = serialize - get = deserialize - -instance Binary SoftPath where - put = serialize - get = deserialize -- | Get a list of derivation indices from a derivation path. pathToList :: DerivPathI t -> [KeyIndex] pathToList = reverse . go - where - go (next :| i) = setBit i 31 : go next - go (next :/ i) = i : go next - 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 + 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 @@ -739,24 +689,25 @@ pathToStr p = next :/ i -> concat [pathToStr next, "/", show i] Deriv -> "" -{- | Turn a derivation path into a hard derivation path. Will fail if the path - contains soft derivations. --} + +-- | Turn a derivation path into a hard derivation path. Will fail if the path +-- contains soft derivations. toHard :: DerivPathI t -> Maybe HardPath toHard p = case p of next :| i -> (:| i) <$> toHard next Deriv -> Just Deriv _ -> Nothing -{- | Turn a derivation path into a soft derivation path. Will fail if the path - has hard derivations. --} + +-- | Turn a derivation path into a soft derivation path. Will fail if the path +-- has hard derivations. toSoft :: DerivPathI t -> Maybe SoftPath toSoft p = case p of next :/ i -> (:/ i) <$> toSoft next Deriv -> Just Deriv _ -> Nothing + -- | Make a derivation path generic. toGeneric :: DerivPathI t -> DerivPath toGeneric p = case p of @@ -764,145 +715,127 @@ toGeneric p = case p of next :| i -> toGeneric next :| i Deriv -> Deriv -{- | Append two derivation paths together. The result will be a mixed - derivation path. --} + +-- | Append two derivation paths together. The result will be a mixed +-- derivation path. (++/) :: DerivPathI t1 -> DerivPathI t2 -> DerivPath (++/) p1 p2 = go id (toGeneric p2) $ toGeneric p1 - where - go f p = case p of - next :/ i -> go (f . (:/ i)) $ toGeneric next - next :| i -> go (f . (:| i)) $ toGeneric next - _ -> f + 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 + 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 + 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" + 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" + 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" + where + e = error "Could not parse hard derivation path" + instance IsString SoftPath where fromString = fromMaybe e . parseSoft - where - e = error "Could not parse soft derivation path" - -instance FromJSON ParsedPath where - parseJSON = withText "ParsedPath" $ \str -> case parsePath $ cs str of - Just p -> return p - _ -> mzero - -instance FromJSON DerivPath where - parseJSON = withText "DerivPath" $ \str -> case parsePath $ cs str of - Just p -> return $ getParsedPath p - _ -> mzero - -instance FromJSON HardPath where - parseJSON = withText "HardPath" $ \str -> case parseHard $ cs str of - Just p -> return p - _ -> mzero - -instance FromJSON SoftPath where - parseJSON = withText "SoftPath" $ \str -> case parseSoft $ cs str of - Just p -> return p - _ -> mzero - -instance ToJSON (DerivPathI t) where - toJSON = A.String . cs . pathToStr - toEncoding = text . cs . pathToStr - -instance ToJSON ParsedPath where - toJSON (ParsedPrv p) = A.String . cs . ("m" ++) . pathToStr $ p - toJSON (ParsedPub p) = A.String . cs . ("M" ++) . pathToStr $ p - toJSON (ParsedEmpty p) = A.String . cs . ("" ++) . pathToStr $ p - toEncoding (ParsedPrv p) = text . cs . ("m" ++) . pathToStr $ p - toEncoding (ParsedPub p) = text . cs . ("M" ++) . pathToStr $ p - toEncoding (ParsedEmpty p) = text . cs . ("" ++) . pathToStr $ p + where + e = error "Could not parse soft derivation path" + {- Parsing derivation paths of the form m/1/2'/3 or M/1/2'/3 -} -{- | Type for parsing derivation paths of the form /m\/1\/2'\/3/ or - /M\/1\/2'\/3/. --} +-- | Type for parsing derivation paths of the form /m\/1\/2'\/3/ or +-- /M\/1\/2'\/3/. data ParsedPath = ParsedPrv {getParsedPath :: !DerivPath} | ParsedPub {getParsedPath :: !DerivPath} | ParsedEmpty {getParsedPath :: !DerivPath} deriving (Eq, Generic, NFData) + instance Show ParsedPath where showsPrec d p = showParen (d > 10) $ showString "ParsedPath " . shows f - where - f = - case p of - ParsedPrv d' -> "m" <> pathToStr d' - ParsedPub d' -> "M" <> pathToStr d' - ParsedEmpty d' -> pathToStr d' + 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 @@ -910,9 +843,9 @@ instance Read ParsedPath where R.String str <- lexP maybe pfail return $ parsePath str -{- | Parse derivation path string for extended key. - Forms: /m\/0'\/2/, /M\/2\/3\/4/. --} + +-- | Parse derivation path string for extended key. +-- Forms: /m\/0'\/2/, /M\/2\/3\/4/. parsePath :: String -> Maybe ParsedPath parsePath str = do res <- concatBip32Segments <$> mapM parseBip32PathIndex xs @@ -921,18 +854,21 @@ parsePath str = do "M" -> Just $ ParsedPub res "" -> Just $ ParsedEmpty res _ -> Nothing - where - (x : xs) = splitOn "/" str + 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 @@ -940,12 +876,14 @@ parseBip32PathIndex segment = case reads segment of [(i, "'")] -> guard (is31Bit i) >> return (Bip32HardIndex i) _ -> Nothing + -- | Type for BIP32 path index element. data Bip32PathIndex = Bip32HardIndex KeyIndex | Bip32SoftIndex KeyIndex deriving (Eq, Generic, NFData) + instance Show Bip32PathIndex where showsPrec d (Bip32HardIndex i) = showParen (d > 10) $ @@ -954,34 +892,39 @@ instance Show Bip32PathIndex where 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 + 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 @@ -994,12 +937,12 @@ data XKey } deriving (Eq, Show, Generic, NFData) -{- | Apply a parsed path to an extended key to derive the new key defined in the - path. If the path starts with /m/, a private key will be returned and if the - path starts with /M/, a public key will be returned. Private derivations on a - public key, and public derivations with a hard segment, return an error - value. --} + +-- | Apply a parsed path to an extended key to derive the new key defined in the +-- path. If the path starts with /m/, a private key will be returned and if the +-- path starts with /M/, a public key will be returned. Private derivations on a +-- public key, and public derivations with a hard segment, return an error +-- value. applyPath :: ParsedPath -> XKey -> Either String XKey applyPath path key = case (path, key) of @@ -1010,21 +953,22 @@ applyPath path key = -- 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" + 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 -} @@ -1032,16 +976,16 @@ applyPath path key = derivePathAddr :: XPubKey -> SoftPath -> KeyIndex -> (Address, PubKey) derivePathAddr key path = deriveAddr (derivePubPath path key) -{- | Cyclic list of all addresses derived from a given parent path and starting - from the given offset index. --} + +-- | Cyclic list of all addresses derived from a given parent path and starting +-- from the given offset index. derivePathAddrs :: XPubKey -> SoftPath -> KeyIndex -> [(Address, PubKey, KeyIndex)] derivePathAddrs key path = deriveAddrs (derivePubPath path key) -{- | Derive a multisig address from a given parent path. The number of required - signatures (m in m of n) is also needed. --} + +-- | Derive a multisig address from a given parent path. The number of required +-- signatures (m in m of n) is also needed. derivePathMSAddr :: [XPubKey] -> SoftPath -> @@ -1051,10 +995,10 @@ derivePathMSAddr :: derivePathMSAddr keys path = deriveMSAddr $ map (derivePubPath path) keys -{- | Cyclic list of all multisig addresses derived from a given parent path and - starting from the given offset index. The number of required signatures - (m in m of n) is also needed. --} + +-- | Cyclic list of all multisig addresses derived from a given parent path and +-- starting from the given offset index. The number of required signatures +-- (m in m of n) is also needed. derivePathMSAddrs :: [XPubKey] -> SoftPath -> @@ -1064,6 +1008,7 @@ derivePathMSAddrs :: derivePathMSAddrs keys path = deriveMSAddrs $ map (derivePubPath path) keys + {- Utilities for extended keys -} -- | De-serialize HDW-specific private key. @@ -1072,13 +1017,15 @@ getPadPrvKey = do pad <- getWord8 unless (pad == 0x00) $ fail "Private key must be padded with 0x00" bs <- getByteString 32 - case runGetS S.get bs of - Left e -> fail e - Right x -> return x + case secKey bs of + Nothing -> fail "Invalid Secret Key" + Just x -> return x + -- | Serialize HDW-specific private key. putPadPrvKey :: MonadPut m => SecKey -> m () -putPadPrvKey p = putWord8 0x00 >> putByteString (runPutS (S.put p)) +putPadPrvKey p = putWord8 0x00 >> putByteString (getSecKey p) + bsPadPrvKey :: SecKey -> ByteString bsPadPrvKey = runPutS . putPadPrvKey diff --git a/src/Haskoin/Keys/Extended/Internal.hs b/src/Haskoin/Keys/Extended/Internal.hs index 57d539cb..6e4293e1 100644 --- a/src/Haskoin/Keys/Extended/Internal.hs +++ b/src/Haskoin/Keys/Extended/Internal.hs @@ -9,22 +9,12 @@ module Haskoin.Keys.Extended.Internal ( import Control.DeepSeq (NFData) import Control.Monad ((>=>)) -import Data.Aeson ( - FromJSON, - ToJSON, - parseJSON, - toJSON, - withText, - ) -import Data.Binary (Binary (..)) -import Data.Bytes.Get (getWord32be) -import Data.Bytes.Put (putWord32be) +import Data.Bytes.Get (getWord32be, runGetS) +import Data.Bytes.Put (putWord32be, runPutS) import Data.Bytes.Serial (Serial (..)) import Data.Either (fromRight) import Data.Hashable (Hashable) import Data.Maybe (fromMaybe) -import Data.Serialize (Serialize (..)) -import qualified Data.Serialize as S import Data.String (IsString (..)) import Data.Text (Text) import qualified Data.Text as Text @@ -34,50 +24,43 @@ import GHC.Generics (Generic) import Haskoin.Util (decodeHex, encodeHex) import Text.Read (readEither, readPrec) + -- | Fingerprint of parent newtype Fingerprint = Fingerprint {unFingerprint :: Word32} deriving (Eq, Ord, Hashable, Typeable, Generic, NFData) + fingerprintToText :: Fingerprint -> Text -fingerprintToText = encodeHex . S.encode +fingerprintToText = encodeHex . runPutS . serialize + textToFingerprint :: Text -> Either String Fingerprint -textToFingerprint = maybe (Left "Fingerprint: invalid hex") Right . decodeHex >=> S.decode +textToFingerprint = maybe (Left "Fingerprint: invalid hex") Right . decodeHex >=> runGetS deserialize + instance Show Fingerprint where - show = show . Text.unpack . encodeHex . S.encode + show = show . Text.unpack . encodeHex . runPutS . serialize + instance Read Fingerprint where readPrec = readPrec >>= maybe (fail "Fingerprint: invalid hex") pure . decodeHex - >>= either (fail . ("Fingerprint: " <>)) pure . S.decode + >>= either (fail . ("Fingerprint: " <>)) pure . runGetS deserialize + instance IsString Fingerprint where fromString = fromRight decodeError - . S.decode + . runGetS deserialize . fromMaybe hexError . decodeHex . Text.pack - where - decodeError = error "Fingerprint literal: Unable to decode" - hexError = error "Fingerprint literal: Invalid hex" + where + decodeError = error "Fingerprint literal: Unable to decode" + hexError = error "Fingerprint literal: Invalid hex" + instance Serial Fingerprint where serialize = putWord32be . unFingerprint deserialize = Fingerprint <$> getWord32be - -instance Binary Fingerprint where - put = serialize - get = deserialize - -instance Serialize Fingerprint where - put = serialize - get = deserialize - -instance FromJSON Fingerprint where - parseJSON = withText "Fingerprint" $ either fail pure . textToFingerprint - -instance ToJSON Fingerprint where - toJSON = toJSON . fingerprintToText diff --git a/src/Haskoin/Network/Bloom.hs b/src/Haskoin/Network/Bloom.hs index 047add34..a8cb9d04 100644 --- a/src/Haskoin/Network/Bloom.hs +++ b/src/Haskoin/Network/Bloom.hs @@ -1,19 +1,18 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} -{- | -Module : Haskoin.Network.Bloom -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Bloom filters are used to reduce data transfer when synchronizing thin cients. -When bloom filters are used a client will obtain filtered blocks that only -contain transactions that pass the bloom filter. Transactions announced via inv -messages also pass the filter. --} +-- | +--Module : Haskoin.Network.Bloom +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX +-- +--Bloom filters are used to reduce data transfer when synchronizing thin cients. +--When bloom filters are used a client will obtain filtered blocks that only +--contain transactions that pass the bloom filter. Transactions announced via inv +--messages also pass the filter. module Haskoin.Network.Bloom ( -- * Bloom Filters BloomFlags (..), @@ -32,7 +31,6 @@ module Haskoin.Network.Bloom ( import Control.DeepSeq import Control.Monad (forM_, replicateM) -import Data.Binary (Binary (..)) import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -43,32 +41,36 @@ 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 (..)) import Data.Word import GHC.Generics (Generic) import Haskoin.Network.Common import Haskoin.Script.Standard import Haskoin.Transaction.Common + -- | 20,000 items with fp rate < 0.1% or 10,000 items and <0.0001% maxBloomSize :: Int maxBloomSize = 36000 + maxHashFuncs :: Word32 maxHashFuncs = 50 + ln2Squared :: Double ln2Squared = 0.4804530139182014246671025263266649717305529515945455 + ln2 :: Double ln2 = 0.6931471805599453094172321214581765680755001343602552 + bitMask :: [Word8] bitMask = [0x01, 0x02, 0x04, 0x08, 0x10, 0x20, 0x40, 0x80] -{- | The bloom flags are used to tell the remote peer how to auto-update - the provided bloom filter. --} + +-- | The bloom flags are used to tell the remote peer how to auto-update +-- the provided bloom filter. data BloomFlags = -- | never update BloomUpdateNone @@ -78,34 +80,28 @@ data BloomFlags BloomUpdateP2PubKeyOnly deriving (Eq, Show, Read, Generic, NFData) + instance Serial BloomFlags where deserialize = go =<< getWord8 - where - go 0 = return BloomUpdateNone - go 1 = return BloomUpdateAll - go 2 = return BloomUpdateP2PubKeyOnly - go _ = fail "BloomFlags get: Invalid bloom flag" + where + go 0 = return BloomUpdateNone + go 1 = return BloomUpdateAll + go 2 = return BloomUpdateP2PubKeyOnly + go _ = fail "BloomFlags get: Invalid bloom flag" + serialize f = putWord8 $ case f of BloomUpdateNone -> 0 BloomUpdateAll -> 1 BloomUpdateP2PubKeyOnly -> 2 -instance Binary BloomFlags where - get = deserialize - put = serialize - -instance Serialize BloomFlags where - get = deserialize - put = serialize - -{- | A bloom filter is a probabilistic data structure that SPV clients send to - other peers to filter the set of transactions received from them. Bloom - filters can have false positives but not false negatives. Some transactions - that pass the filter may not be relevant to the receiving peer. By - controlling the false positive rate, SPV nodes can trade off bandwidth - versus privacy. --} + +-- | A bloom filter is a probabilistic data structure that SPV clients send to +-- other peers to filter the set of transactions received from them. Bloom +-- filters can have false positives but not false negatives. Some transactions +-- that pass the filter may not be relevant to the receiving peer. By +-- controlling the false positive rate, SPV nodes can trade off bandwidth +-- versus privacy. data BloomFilter = BloomFilter { -- | bloom filter data bloomData :: !(S.Seq Word8) @@ -118,6 +114,7 @@ data BloomFilter = BloomFilter } deriving (Eq, Show, Read, Generic, NFData) + instance Serial BloomFilter where deserialize = BloomFilter @@ -125,8 +122,9 @@ instance Serial BloomFilter where <*> getWord32le <*> getWord32le <*> deserialize - where - readDat (VarInt len) = replicateM (fromIntegral len) getWord8 + where + readDat (VarInt len) = replicateM (fromIntegral len) getWord8 + serialize (BloomFilter dat hashFuncs tweak flags) = do putVarInt $ S.length dat @@ -135,57 +133,37 @@ instance Serial BloomFilter where putWord32le tweak serialize flags -instance Binary BloomFilter where - put = serialize - get = deserialize - -instance Serialize BloomFilter where - put = serialize - get = deserialize -- | Set a new bloom filter on the peer connection. newtype FilterLoad = FilterLoad {filterLoadBloomFilter :: BloomFilter} deriving (Eq, Show, Read, Generic, NFData) + instance Serial FilterLoad where deserialize = FilterLoad <$> deserialize serialize (FilterLoad f) = serialize f -instance Binary FilterLoad where - put = serialize - get = deserialize -instance Serialize FilterLoad where - put = serialize - get = deserialize - -{- | Add the given data element to the connections current filter without - requiring a completely new one to be set. --} +-- | Add the given data element to the connections current filter without +-- requiring a completely new one to be set. newtype FilterAdd = FilterAdd {getFilterData :: ByteString} deriving (Eq, Show, Read, Generic, NFData) + instance Serial FilterAdd where deserialize = do (VarInt len) <- deserialize dat <- getByteString $ fromIntegral len return $ FilterAdd dat + serialize (FilterAdd bs) = do putVarInt $ BS.length bs putByteString bs -instance Binary FilterAdd where - put = serialize - get = deserialize -instance Serialize FilterAdd where - put = serialize - get = deserialize - -{- | Build a bloom filter that will provide the given false positive rate when - the given number of elements have been inserted. --} +-- | Build a bloom filter that will provide the given false positive rate when +-- the given number of elements have been inserted. bloomCreate :: -- | number of elements Int -> @@ -199,26 +177,27 @@ bloomCreate :: BloomFilter 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 + 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 + where + seed = hashNum * 0xfba4c795 + bloomTweak bfilter + -{- | Insert arbitrary data into a bloom filter. Returns the new bloom filter - containing the new data. --} +-- | Insert arbitrary data into a bloom filter. Returns the new bloom filter +-- containing the new data. bloomInsert :: -- | Original bloom filter BloomFilter -> @@ -229,18 +208,18 @@ bloomInsert :: 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. --} + 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 :: -- | Bloom filter BloomFilter -> @@ -252,17 +231,17 @@ 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). --} + 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 :: -- | Bloom filter BloomFilter -> @@ -275,44 +254,47 @@ bloomRelevantUpdate bfilter tx | bloomFlags bfilter == BloomUpdateNone = Nothing | not (null matchOuts) = 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 bf (id', scriptOut) = - case (bloomFlags bfilter, scriptType) of - -- We filtered out BloomUpdateNone so we insert any PayPk or PayMulSig - - (_, True) -> bloomInsert bf outpoint - (BloomUpdateAll, _) -> bloomInsert bf outpoint - _ -> error "Error Updating Bloom Filter with relevant outpoint" - where - outpoint = runPutS $ serialize $ 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 _) = runPutS $ serialize outputMuSig - encodeScriptOut (PayWitnessScriptHash scriptHash) = runPutS $ serialize scriptHash - encodeScriptOut (DataCarrier getOutputDat) = runPutS $ serialize getOutputDat - encodeScriptOut outputHash = (runPutS . serialize . getOutputHash) outputHash + 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 bf (id', scriptOut) = + case (bloomFlags bfilter, scriptType) of + -- We filtered out BloomUpdateNone so we insert any PayPk or PayMulSig + + (_, True) -> bloomInsert bf outpoint + (BloomUpdateAll, _) -> bloomInsert bf outpoint + _ -> error "Error Updating Bloom Filter with relevant outpoint" + where + outpoint = runPutS $ serialize $ 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 _) = runPutS $ serialize outputMuSig + encodeScriptOut (PayWitnessScriptHash scriptHash) = runPutS $ serialize scriptHash + encodeScriptOut (DataCarrier getOutputDat) = runPutS $ serialize getOutputDat + encodeScriptOut outputHash = (runPutS . serialize . getOutputHash) outputHash + -- | Returns True if the filter is empty (all bytes set to 0x00) isBloomEmpty :: BloomFilter -> Bool isBloomEmpty bfilter = all (== 0x00) $ F.toList $ bloomData bfilter + -- | Returns True if the filter is full (all bytes set to 0xff) isBloomFull :: BloomFilter -> Bool isBloomFull bfilter = all (== 0xff) $ F.toList $ bloomData bfilter + -- | Tests if a given bloom filter is valid. isBloomValid :: -- | Bloom filter to test @@ -323,6 +305,7 @@ isBloomValid bfilter = S.length (bloomData bfilter) <= maxBloomSize && bloomHashFuncs bfilter <= maxHashFuncs + -- | Does the peer with these version services accept bloom filters? acceptsFilters :: Word64 -> Bool acceptsFilters srv = srv .&. (1 `shiftL` 2) /= 0 diff --git a/src/Haskoin/Network/Common.hs b/src/Haskoin/Network/Common.hs index f1d942bc..038fce51 100644 --- a/src/Haskoin/Network/Common.hs +++ b/src/Haskoin/Network/Common.hs @@ -2,16 +2,15 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{- | -Module : Haskoin.Network.Common -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Common functions and data types related to peer-to-peer network. --} +-- | +--Module : Haskoin.Network.Common +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX +-- +--Common functions and data types related to peer-to-peer network. module Haskoin.Network.Common ( -- * Network Data Types Addr (..), @@ -48,7 +47,6 @@ module Haskoin.Network.Common ( import Control.DeepSeq import Control.Monad (forM_, liftM2, replicateM, unless) -import Data.Binary (Binary (..)) import Data.Bits (shiftL) import Data.ByteString (ByteString) import qualified Data.ByteString as B @@ -56,7 +54,6 @@ import Data.ByteString.Char8 as C (replicate) import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial -import Data.Serialize (Serialize (..)) import Data.String import Data.String.Conversions (cs) import Data.Word (Word32, Word64) @@ -65,40 +62,35 @@ import Haskoin.Crypto.Hash import Network.Socket (SockAddr (..)) import Text.Read as R + -- | Network address with a timestamp. type NetworkAddressTime = (Word32, NetworkAddress) -{- | Provides information about known nodes in the bitcoin network. An 'Addr' - type is sent inside a 'Message' as a response to a 'GetAddr' message. --} + +-- | Provides information about known nodes in the bitcoin network. An 'Addr' +-- type is sent inside a 'Message' as a response to a 'GetAddr' message. newtype Addr = Addr { -- List of addresses of other nodes on the network with timestamps. addrList :: [NetworkAddressTime] } deriving (Eq, Show, Generic, NFData) + instance Serial Addr where deserialize = Addr <$> (repList =<< deserialize) - where - repList (VarInt c) = replicateM (fromIntegral c) action - action = liftM2 (,) getWord32le deserialize + where + repList (VarInt c) = replicateM (fromIntegral c) action + action = liftM2 (,) getWord32le deserialize + serialize (Addr xs) = do putVarInt $ length xs forM_ xs $ \(a, b) -> putWord32le a >> serialize b -instance Binary Addr where - get = deserialize - put = serialize - -instance Serialize Addr where - get = deserialize - put = serialize -{- | Data type describing signed messages that can be sent between bitcoin - nodes to display important notifications to end users about the health of - the network. --} +-- | Data type describing signed messages that can be sent between bitcoin +-- nodes to display important notifications to end users about the health of +-- the network. data Alert = Alert { -- | Alert payload. alertPayload :: !VarString @@ -107,79 +99,60 @@ data Alert = Alert } deriving (Eq, Show, Read, Generic, NFData) + instance Serial Alert where deserialize = Alert <$> deserialize <*> deserialize serialize (Alert p s) = serialize p >> serialize s -instance Binary Alert where - put = serialize - get = deserialize - -instance Serialize Alert where - put = serialize - get = deserialize - -{- | The 'GetData' type is used to retrieve information on a specific object - ('Block' or 'Tx') identified by the objects hash. The payload of a 'GetData' - request is a list of 'InvVector' which represent all the hashes of objects - that a node wants. The response to a 'GetBlock' message will be either a - 'Block' or a 'Tx' message depending on the type of the object referenced by - the hash. Usually, 'GetData' messages are sent after a node receives an 'Inv' - message that contains unknown object hashes. --} + +-- | The 'GetData' type is used to retrieve information on a specific object +-- ('Block' or 'Tx') identified by the objects hash. The payload of a 'GetData' +-- request is a list of 'InvVector' which represent all the hashes of objects +-- that a node wants. The response to a 'GetBlock' message will be either a +-- 'Block' or a 'Tx' message depending on the type of the object referenced by +-- the hash. Usually, 'GetData' messages are sent after a node receives an 'Inv' +-- message that contains unknown object hashes. newtype GetData = GetData { -- | list of object hashes getDataList :: [InvVector] } deriving (Eq, Show, Generic, NFData) + instance Serial GetData where deserialize = GetData <$> (repList =<< deserialize) - where - repList (VarInt c) = replicateM (fromIntegral c) deserialize + where + repList (VarInt c) = replicateM (fromIntegral c) deserialize + serialize (GetData xs) = do putVarInt $ length xs forM_ xs serialize -instance Binary GetData where - get = deserialize - put = serialize -instance Serialize GetData where - get = deserialize - put = serialize - -{- | 'Inv' messages are used by nodes to advertise their knowledge of new - objects by publishing a list of hashes to a peer. 'Inv' messages can be sent - unsolicited or in response to a 'GetBlocks' message. --} +-- | 'Inv' messages are used by nodes to advertise their knowledge of new +-- objects by publishing a list of hashes to a peer. 'Inv' messages can be sent +-- unsolicited or in response to a 'GetBlocks' message. newtype Inv = Inv { -- | inventory invList :: [InvVector] } deriving (Eq, Show, Generic, NFData) + instance Serial Inv where deserialize = Inv <$> (repList =<< deserialize) - where - repList (VarInt c) = replicateM (fromIntegral c) deserialize + where + repList (VarInt c) = replicateM (fromIntegral c) deserialize + serialize (Inv xs) = do putVarInt $ length xs forM_ xs serialize -instance Binary Inv where - get = deserialize - put = serialize - -instance Serialize Inv where - get = deserialize - put = serialize -{- | Data type identifying the type of an inventory vector. SegWit types are - only used in 'GetData' messages, not 'Inv'. --} +-- | Data type identifying the type of an inventory vector. SegWit types are +-- only used in 'GetData' messages, not 'Inv'. data InvType = -- | error InvError @@ -199,20 +172,21 @@ data InvType InvType Word32 deriving (Eq, Show, Read, Generic, NFData) + instance Serial InvType where deserialize = 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 -> return (InvType x) + 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 -> return (InvType x) serialize x = putWord32le $ case x of @@ -225,18 +199,10 @@ instance Serial InvType where InvWitnessMerkleBlock -> 1 `shiftL` 30 + 3 InvType w -> w -instance Binary InvType where - get = deserialize - put = serialize -instance Serialize InvType where - get = deserialize - put = serialize - -{- | Invectory vectors represent hashes identifying objects such as a 'Block' or - a 'Tx'. They notify other peers about new data or data they have otherwise - requested. --} +-- | Invectory vectors represent hashes identifying objects such as a 'Block' or +-- a 'Tx'. They notify other peers about new data or data they have otherwise +-- requested. data InvVector = InvVector { -- | type of object invType :: !InvType @@ -245,38 +211,25 @@ data InvVector = InvVector } deriving (Eq, Show, Generic, NFData) + instance Serial InvVector where deserialize = InvVector <$> deserialize <*> deserialize serialize (InvVector t h) = serialize t >> serialize h -instance Binary InvVector where - get = deserialize - put = serialize - -instance Serialize InvVector where - get = deserialize - put = serialize newtype HostAddress = HostAddress ByteString deriving (Eq, Show, Ord, Generic, NFData) + instance Serial HostAddress where serialize (HostAddress bs) = putByteString bs deserialize = HostAddress <$> getByteString 18 -instance Binary HostAddress where - get = deserialize - put = serialize - -instance Serialize HostAddress where - get = deserialize - put = serialize -{- | Data type describing a bitcoin network address. Addresses are stored in - IPv6 format. IPv4 addresses are mapped to IPv6 using IPv4 mapped IPv6 - addresses: . --} +-- | Data type describing a bitcoin network address. Addresses are stored in +-- IPv6 format. IPv4 addresses are mapped to IPv6 using IPv4 mapped IPv6 +-- addresses: . data NetworkAddress = NetworkAddress { -- | bitmask of services available for this address naServices :: !Word64 @@ -285,15 +238,18 @@ data NetworkAddress = NetworkAddress } deriving (Eq, Show, Generic, NFData) + hostToSockAddr :: HostAddress -> SockAddr hostToSockAddr (HostAddress bs) = case runGetS getSockAddr bs of Left e -> error e Right x -> x + sockToHostAddress :: SockAddr -> HostAddress sockToHostAddress = HostAddress . runPutS . putSockAddr + putSockAddr :: MonadPut m => SockAddr -> m () putSockAddr (SockAddrInet6 p _ (a, b, c, d) _) = do putWord32be a @@ -309,6 +265,7 @@ putSockAddr (SockAddrInet p a) = do putWord16be (fromIntegral p) putSockAddr _ = error "Invalid address type" + getSockAddr :: MonadGet m => m SockAddr getSockAddr = do a <- getWord32be @@ -324,49 +281,36 @@ getSockAddr = do p <- getWord16be return $ SockAddrInet6 (fromIntegral p) 0 (a, b, c, d) 0 + instance Serial NetworkAddress where deserialize = NetworkAddress <$> getWord64le <*> deserialize serialize (NetworkAddress s a) = putWord64le s >> serialize a -instance Binary NetworkAddress where - get = deserialize - put = serialize - -instance Serialize NetworkAddress where - get = deserialize - put = serialize -{- | A 'NotFound' message is returned as a response to a 'GetData' message - whe one of the requested objects could not be retrieved. This could happen, - for example, if a tranasaction was requested and was not available in the - memory pool of the receiving node. --} +-- | A 'NotFound' message is returned as a response to a 'GetData' message +-- whe one of the requested objects could not be retrieved. This could happen, +-- for example, if a tranasaction was requested and was not available in the +-- memory pool of the receiving node. newtype NotFound = NotFound { -- | Inventory vectors related to this request notFoundList :: [InvVector] } deriving (Eq, Show, Generic, NFData) + instance Serial NotFound where deserialize = NotFound <$> (repList =<< deserialize) - where - repList (VarInt c) = replicateM (fromIntegral c) deserialize + where + repList (VarInt c) = replicateM (fromIntegral c) deserialize + serialize (NotFound xs) = do putVarInt $ length xs forM_ xs serialize -instance Binary NotFound where - get = deserialize - put = serialize -instance Serialize NotFound where - get = deserialize - put = serialize - -{- | A 'Ping' message is sent to bitcoin peers to check if a connection is still - open. --} +-- | A 'Ping' message is sent to bitcoin peers to check if a connection is still +-- open. newtype Ping = Ping { -- | A random nonce used to identify the recipient of the ping -- request once a Pong response is received. @@ -374,6 +318,7 @@ newtype Ping = Ping } 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' @@ -381,29 +326,16 @@ newtype Pong = Pong } deriving (Eq, Show, Read, Generic, NFData) + instance Serial Ping where deserialize = Ping <$> getWord64le serialize (Ping n) = putWord64le n + instance Serial Pong where deserialize = Pong <$> getWord64le serialize (Pong n) = putWord64le n -instance Binary Ping where - get = deserialize - put = serialize - -instance Binary Pong where - get = deserialize - put = serialize - -instance Serialize Ping where - get = deserialize - put = serialize - -instance Serialize Pong where - get = deserialize - put = serialize -- | The 'Reject' message is sent when messages are rejected by a peer. data Reject = Reject @@ -418,6 +350,7 @@ data Reject = Reject } deriving (Eq, Show, Read, Generic, NFData) + -- | Rejection code associated to the 'Reject' message. data RejectCode = RejectMalformed @@ -430,6 +363,7 @@ data RejectCode | RejectCheckpoint deriving (Eq, Show, Read, Generic, NFData) + instance Serial RejectCode where deserialize = getWord8 >>= \code -> case code of @@ -448,6 +382,7 @@ instance Serial RejectCode where , show code ] + serialize code = putWord8 $ case code of RejectMalformed -> 0x01 RejectInvalid -> 0x10 @@ -458,19 +393,13 @@ instance Serial RejectCode where RejectInsufficientFee -> 0x42 RejectCheckpoint -> 0x43 -instance Binary RejectCode where - put = serialize - get = deserialize - -instance Serialize RejectCode where - put = serialize - get = deserialize -- | Convenience function to build a 'Reject' message. reject :: MessageCommand -> RejectCode -> ByteString -> Reject reject cmd code reason = Reject cmd code (VarString reason) B.empty + instance Serial Reject where deserialize = deserialize >>= \(VarString bs) -> @@ -478,39 +407,33 @@ instance Serial Reject where <$> deserialize <*> deserialize <*> maybeData - where - maybeData = - isEmpty >>= \done -> - if done - then return B.empty - else getByteString 32 + where + maybeData = + isEmpty >>= \done -> + if done + then return B.empty + else getByteString 32 serialize (Reject cmd code reason dat) = do serialize $ VarString $ commandToString cmd serialize code serialize reason unless (B.null dat) $ putByteString dat -instance Binary Reject where - put = serialize - get = deserialize - -instance Serialize Reject where - put = serialize - get = deserialize -{- | Data type representing a variable-length integer. The 'VarInt' type - usually precedes an array or a string that can vary in length. --} +-- | Data type representing a variable-length integer. The 'VarInt' type +-- usually precedes an array or a string that can vary in length. newtype VarInt = VarInt {getVarInt :: Word64} deriving (Eq, Show, Read, Generic, NFData) + instance Serial VarInt where deserialize = VarInt <$> (getWord8 >>= go) - where - go 0xff = getWord64le - go 0xfe = fromIntegral <$> getWord32le - go 0xfd = fromIntegral <$> getWord16le - go x = return $ fromIntegral x + where + go 0xff = getWord64le + go 0xfe = fromIntegral <$> getWord32le + go 0xfd = fromIntegral <$> getWord16le + go x = return $ fromIntegral x + serialize (VarInt x) | x < 0xfd = @@ -525,42 +448,30 @@ instance Serial VarInt where putWord8 0xff putWord64le x -instance Binary VarInt where - put = serialize - get = deserialize - -instance Serialize VarInt where - put = serialize - get = deserialize putVarInt :: (MonadPut m, Integral a) => a -> m () putVarInt = serialize . VarInt . fromIntegral + -- | Data type for serialization of variable-length strings. newtype VarString = VarString {getVarString :: ByteString} deriving (Eq, Show, Read, Generic, NFData) + instance Serial VarString where deserialize = VarString <$> (readBS =<< deserialize) - where - readBS (VarInt len) = getByteString (fromIntegral len) + where + readBS (VarInt len) = getByteString (fromIntegral len) + serialize (VarString bs) = do putVarInt $ B.length bs putByteString bs -instance Binary VarString where - put = serialize - get = deserialize -instance Serialize VarString where - put = serialize - get = deserialize - -{- | When a bitcoin node creates an outgoing connection to another node, - the first message it will send is a 'Version' message. The other node - will similarly respond with it's own 'Version' message. --} +-- | When a bitcoin node creates an outgoing connection to another node, +-- the first message it will send is a 'Version' message. The other node +-- will similarly respond with it's own 'Version' message. data Version = Version { -- | protocol version version :: !Word32 @@ -583,6 +494,7 @@ data Version = Version } deriving (Eq, Show, Generic, NFData) + instance Serial Version where deserialize = Version <$> getWord32le @@ -594,9 +506,10 @@ instance Serial Version where <*> deserialize <*> getWord32le <*> (go =<< isEmpty) - where - go True = return True - go False = getBool + where + go True = return True + go False = getBool + serialize (Version v s t ar as n ua sh r) = do putWord32le v @@ -609,31 +522,25 @@ instance Serial Version where putWord32le sh putBool r -instance Binary Version where - put = serialize - get = deserialize - -instance Serialize Version where - put = serialize - get = deserialize -- | 0x00 is 'False', anything else is 'True'. getBool :: MonadGet m => m Bool getBool = go =<< getWord8 - where - go 0 = return False - go _ = return True + where + go 0 = return False + go _ = return True + putBool :: MonadPut m => Bool -> m () putBool True = putWord8 1 putBool False = putWord8 0 -{- | A 'MessageCommand' is included in a 'MessageHeader' in order to identify - the type of message present in the payload. This allows the message - de-serialization code to know how to decode a particular message payload. - Every valid 'Message' constructor has a corresponding 'MessageCommand' - constructor. --} + +-- | A 'MessageCommand' is included in a 'MessageHeader' in order to identify +-- the type of message present in the payload. This allows the message +-- de-serialization code to know how to decode a particular message payload. +-- Every valid 'Message' constructor has a corresponding 'MessageCommand' +-- constructor. data MessageCommand = MCVersion | MCVerAck @@ -660,33 +567,30 @@ data MessageCommand | MCOther ByteString deriving (Eq, Generic, NFData) + instance Show MessageCommand where showsPrec _ = shows . commandToString + instance Read MessageCommand where readPrec = do String str <- lexP return (stringToCommand (cs str)) + instance Serial MessageCommand where deserialize = go <$> getByteString 12 - where - go bs = - let str = unpackCommand bs - in stringToCommand str + where + go bs = + let str = unpackCommand bs + in stringToCommand str serialize mc = putByteString $ packCommand $ commandToString mc -instance Binary MessageCommand where - put = serialize - get = deserialize - -instance Serialize MessageCommand where - put = serialize - get = deserialize instance IsString MessageCommand where fromString str = stringToCommand (cs str) + -- | Read a 'MessageCommand' from its string representation. stringToCommand :: ByteString -> MessageCommand stringToCommand str = case str of @@ -714,6 +618,7 @@ stringToCommand str = case str of "sendheaders" -> MCSendHeaders _ -> MCOther str + -- | Convert a 'MessageCommand' to its string representation. commandToString :: MessageCommand -> ByteString commandToString mc = case mc of @@ -741,36 +646,44 @@ commandToString mc = case mc of MCSendHeaders -> "sendheaders" MCOther c -> c + -- | Pack a string 'MessageCommand' so that it is exactly 12-bytes long. packCommand :: ByteString -> ByteString packCommand s = B.take 12 $ s `mappend` C.replicate 12 '\NUL' + -- | Undo packing done by 'packCommand'. unpackCommand :: ByteString -> ByteString unpackCommand = B.takeWhile (/= 0) + -- | Node offers no services. nodeNone :: Word64 nodeNone = 0 + -- | Services indicate node is a full node that can serve full blocks. nodeNetwork :: Word64 nodeNetwork = 1 + -- | Services indicate node allows to request 'UTXO' set. nodeGetUTXO :: Word64 nodeGetUTXO = 1 `shiftL` 1 + -- | Services indicate node accepts bloom filters. nodeBloom :: Word64 nodeBloom = 1 `shiftL` 2 + -- | Services indicate SegWit-capable node. nodeWitness :: Word64 nodeWitness = 1 `shiftL` 3 + -- | Services indicate Xtreme Thinblocks compatibility. nodeXThin :: Word64 nodeXThin = 1 `shiftL` 4 diff --git a/src/Haskoin/Network/Message.hs b/src/Haskoin/Network/Message.hs index ba26b84c..7a28ef9d 100644 --- a/src/Haskoin/Network/Message.hs +++ b/src/Haskoin/Network/Message.hs @@ -1,16 +1,15 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} -{- | -Module : Haskoin.Network.Message -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Peer-to-peer network message serialization. --} +-- | +--Module : Haskoin.Network.Message +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX +-- +--Peer-to-peer network message serialization. module Haskoin.Network.Message ( -- * Network Message Message (..), @@ -22,13 +21,11 @@ module Haskoin.Network.Message ( import Control.DeepSeq import Control.Monad (unless) -import Data.Binary (Binary (..)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial -import Data.Serialize (Serialize (..)) import Data.Word (Word32) import GHC.Generics (Generic) import Haskoin.Block.Common @@ -39,9 +36,9 @@ import Haskoin.Network.Bloom import Haskoin.Network.Common import Haskoin.Transaction.Common -{- | Data type representing the header of a 'Message'. All messages sent between - nodes contain a message header. --} + +-- | Data type representing the header of a 'Message'. All messages sent between +-- nodes contain a message header. data MessageHeader = MessageHeader { -- | magic bytes identify network headMagic :: !Word32 @@ -54,6 +51,7 @@ data MessageHeader = MessageHeader } deriving (Eq, Show, Generic, NFData) + instance Serial MessageHeader where deserialize = MessageHeader @@ -62,27 +60,20 @@ instance Serial MessageHeader where <*> getWord32le <*> deserialize + serialize (MessageHeader m c l chk) = do putWord32be m serialize c putWord32le l serialize chk -instance Binary MessageHeader where - put = serialize - get = deserialize - -instance Serialize MessageHeader where - put = serialize - get = deserialize - -{- | The 'Message' type is used to identify all the valid messages that can be - sent between bitcoin peers. Only values of type 'Message' will be accepted - by other bitcoin peers as bitcoin protocol messages need to be correctly - serialized with message headers. Serializing a 'Message' value will - include the 'MessageHeader' with the correct checksum value automatically. - No need to add the 'MessageHeader' separately. --} + +-- | The 'Message' type is used to identify all the valid messages that can be +-- sent between bitcoin peers. Only values of type 'Message' will be accepted +-- by other bitcoin peers as bitcoin protocol messages need to be correctly +-- serialized with message headers. Serializing a 'Message' value will +-- include the 'MessageHeader' with the correct checksum value automatically. +-- No need to add the 'MessageHeader' separately. data Message = MVersion !Version | MVerAck @@ -109,6 +100,7 @@ data Message | MOther !ByteString !ByteString deriving (Eq, Show, Generic, NFData) + -- | Get 'MessageCommand' assocated with a message. msgType :: Message -> MessageCommand msgType (MVersion _) = MCVersion @@ -135,6 +127,7 @@ msgType MSendHeaders = MCSendHeaders msgType MGetAddr = MCGetAddr msgType (MOther c _) = MCOther c + -- | Deserializer for network messages. getMessage :: MonadGet m => Network -> m Message getMessage net = do @@ -185,6 +178,7 @@ getMessage net = do "get: command " ++ show cmd ++ " is expected to carry a payload" + -- | Serializer for network messages. putMessage :: MonadPut m => Network -> Message -> m () putMessage net msg = do diff --git a/src/Haskoin/Script/Common.hs b/src/Haskoin/Script/Common.hs index 9e3b0cb5..cd0f8624 100644 --- a/src/Haskoin/Script/Common.hs +++ b/src/Haskoin/Script/Common.hs @@ -2,16 +2,15 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{- | -Module : Haskoin.Script.Common -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Common script-related functions and data types. --} +-- | +--Module : Haskoin.Script.Common +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX +-- +--Common script-related functions and data types. module Haskoin.Script.Common ( -- * Scripts ScriptOp (..), @@ -25,7 +24,6 @@ module Haskoin.Script.Common ( import Control.DeepSeq import Control.Monad -import Data.Binary (Binary (..)) import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.Bytes.Get @@ -33,45 +31,39 @@ import Data.Bytes.Put import Data.Bytes.Serial import Data.Either (fromRight) import Data.Hashable -import Data.Serialize (Serialize (..)) import Data.Word (Word8) import GHC.Generics (Generic) -{- | Data type representing a transaction script. Scripts are defined as lists - of script operators 'ScriptOp'. Scripts are used to: - - * Define the spending conditions in the output of a transaction. - * Provide signatures in the input of a transaction (except SegWit). - SigWit only: the segregated witness data structure, and not the input script, - contains signatures and redeem script for pay-to-witness-script and - pay-to-witness-public-key-hash transactions. --} +-- | Data type representing a transaction script. Scripts are defined as lists +-- of script operators 'ScriptOp'. Scripts are used to: +-- +-- * Define the spending conditions in the output of a transaction. +-- * Provide signatures in the input of a transaction (except SegWit). +-- +-- SigWit only: the segregated witness data structure, and not the input script, +-- contains signatures and redeem script for pay-to-witness-script and +-- pay-to-witness-public-key-hash transactions. newtype Script = Script { -- | script operators defining this script scriptOps :: [ScriptOp] } deriving (Eq, Show, Read, Generic, Hashable, NFData) + instance Serial Script where deserialize = Script <$> getScriptOps - where - getScriptOps = do - empty <- isEmpty - if empty - then return [] - else (:) <$> deserialize <*> getScriptOps + where + getScriptOps = do + empty <- isEmpty + if empty + then return [] + else (:) <$> deserialize <*> getScriptOps - serialize (Script ops) = forM_ ops serialize -instance Binary Script where - put = serialize - get = deserialize + serialize (Script ops) = forM_ ops serialize -instance Serialize Script where - put = serialize - get = deserialize -- | Data type representing the type of an OP_PUSHDATA opcode. data PushDataType @@ -85,6 +77,7 @@ data PushDataType OPDATA4 deriving (Show, Read, Eq, Generic, Hashable, NFData) + -- | Data type representing an operator allowed inside a 'Script'. data ScriptOp = -- Pushing Data @@ -217,149 +210,151 @@ data ScriptOp | OP_INVALIDOPCODE !Word8 deriving (Show, Read, Eq, Generic, Hashable, NFData) + instance Serial ScriptOp where deserialize = 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_CHECKLOCKTIMEVERIFY - | op == 0xb2 = return OP_CHECKSEQUENCEVERIFY - | 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 - -- Bitcoin Cash May 2020 hard fork - | op == 0xbc = return OP_REVERSEBYTES - -- Constants - | op == 0xfd = return OP_PUBKEYHASH - | op == 0xfe = return OP_PUBKEY - | otherwise = return $ OP_INVALIDOPCODE op + 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_CHECKLOCKTIMEVERIFY + | op == 0xb2 = return OP_CHECKSEQUENCEVERIFY + | 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 + -- Bitcoin Cash May 2020 hard fork + | op == 0xbc = return OP_REVERSEBYTES + -- Constants + | op == 0xfd = return OP_PUBKEYHASH + | op == 0xfe = return OP_PUBKEY + | otherwise = return $ OP_INVALIDOPCODE op + serialize op = case op of (OP_PUSHDATA payload optype) -> do @@ -513,13 +508,6 @@ instance Serial ScriptOp where -- Bitcoin Cash May 2020 hard fork OP_REVERSEBYTES -> putWord8 0xbc -instance Binary ScriptOp where - put = serialize - get = deserialize - -instance Serialize ScriptOp where - put = serialize - get = deserialize -- | Check whether opcode is only data. isPushOp :: ScriptOp -> Bool @@ -545,6 +533,7 @@ isPushOp op = case op of OP_16 -> True _ -> False + -- | Optimally encode data using one of the 4 types of data pushing opcodes. opPushData :: ByteString -> ScriptOp opPushData bs @@ -553,29 +542,30 @@ opPushData bs | len <= 0xffff = OP_PUSHDATA bs OPDATA2 | len <= 0xffffffff = OP_PUSHDATA bs OPDATA4 | otherwise = error "opPushData: payload size too big" - where - len = B.length bs + 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 = - fromRight err - . runGetS deserialize - . B.singleton - . fromIntegral - $ i + 0x50 - err = error $ "intToScriptOp: Invalid integer " ++ show i + where + op = + fromRight err + . runGetS deserialize + . 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' --} +-- | 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 $ runPutS $ serialize s) - 0x50 + where + res = fromIntegral (B.head $ runPutS $ serialize s) - 0x50 diff --git a/src/Haskoin/Script/SigHash.hs b/src/Haskoin/Script/SigHash.hs index 867a5a92..a275976d 100644 --- a/src/Haskoin/Script/SigHash.hs +++ b/src/Haskoin/Script/SigHash.hs @@ -2,16 +2,15 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -{- | -Module : Haskoin.Script.SigHash -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Transaction signatures and related functions. --} +-- | +--Module : Haskoin.Script.SigHash +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX +-- +--Transaction signatures and related functions. module Haskoin.Script.SigHash ( -- * Script Signatures SigHash (..), @@ -39,7 +38,6 @@ module Haskoin.Script.SigHash ( import Control.DeepSeq import Control.Monad -import qualified Data.Aeson as J import Data.Bits import qualified Data.ByteString as BS import Data.Bytes.Get @@ -58,6 +56,7 @@ import Haskoin.Script.Common import Haskoin.Transaction.Common import Haskoin.Util + -- | Constant representing a SIGHASH flag that controls what is being signed. data SigHashFlag = -- | sign all outputs @@ -72,10 +71,13 @@ data SigHashFlag SIGHASH_ANYONECANPAY deriving (Eq, Ord, Show, Read, Generic) + instance NFData SigHashFlag + instance Hashable SigHashFlag + instance Enum SigHashFlag where fromEnum SIGHASH_ALL = 0x01 fromEnum SIGHASH_NONE = 0x02 @@ -89,18 +91,18 @@ instance Enum SigHashFlag where toEnum 0x80 = SIGHASH_ANYONECANPAY toEnum _ = error "Not a valid sighash flag" -{- | Data type representing the different ways a transaction can be signed. - When producing a signature, a hash of the transaction is used as the message - to be signed. The 'SigHash' parameter controls which parts of the - transaction are used or ignored to produce the transaction hash. The idea is - that if some part of a transaction is not used to produce the transaction - hash, then you can change that part of the transaction after producing a - signature without invalidating that signature. - - If the 'SIGHASH_ANYONECANPAY' flag is set (true), then only the current input - is signed. Otherwise, all of the inputs of a transaction are signed. The - default value for 'SIGHASH_ANYONECANPAY' is unset (false). --} + +-- | Data type representing the different ways a transaction can be signed. +-- When producing a signature, a hash of the transaction is used as the message +-- to be signed. The 'SigHash' parameter controls which parts of the +-- transaction are used or ignored to produce the transaction hash. The idea is +-- that if some part of a transaction is not used to produce the transaction +-- hash, then you can change that part of the transaction after producing a +-- signature without invalidating that signature. +-- +-- If the 'SIGHASH_ANYONECANPAY' flag is set (true), then only the current input +-- is signed. Otherwise, all of the inputs of a transaction are signed. The +-- default value for 'SIGHASH_ANYONECANPAY' is unset (false). newtype SigHash = SigHash Word32 deriving @@ -118,81 +120,89 @@ newtype SigHash , NFData ) -instance J.FromJSON SigHash where - parseJSON = - J.withScientific "sighash" $ - maybe mzero (return . SigHash) . toBoundedInteger - -instance J.ToJSON SigHash where - toJSON = J.Number . fromIntegral - toEncoding (SigHash n) = J.toEncoding n -- | SIGHASH_NONE as a byte. sigHashNone :: SigHash sigHashNone = fromIntegral $ fromEnum SIGHASH_NONE + -- | SIGHASH_ALL as a byte. sigHashAll :: SigHash sigHashAll = fromIntegral $ fromEnum SIGHASH_ALL + -- | SIGHASH_SINGLE as a byte. sigHashSingle :: SigHash sigHashSingle = fromIntegral $ fromEnum SIGHASH_SINGLE + -- | SIGHASH_FORKID as a byte. sigHashForkId :: SigHash sigHashForkId = fromIntegral $ fromEnum SIGHASH_FORKID + -- | SIGHASH_ANYONECANPAY as a byte. sigHashAnyoneCanPay :: SigHash sigHashAnyoneCanPay = fromIntegral $ fromEnum SIGHASH_ANYONECANPAY + -- | Set SIGHASH_FORKID flag. setForkIdFlag :: SigHash -> SigHash setForkIdFlag = (.|. sigHashForkId) + -- | Set SIGHASH_ANYONECANPAY flag. setAnyoneCanPayFlag :: SigHash -> SigHash setAnyoneCanPayFlag = (.|. sigHashAnyoneCanPay) + -- | Is the SIGHASH_FORKID flag set? hasForkIdFlag :: SigHash -> Bool hasForkIdFlag = (/= 0) . (.&. sigHashForkId) + -- | Is the SIGHASH_ANYONECANPAY flag set? hasAnyoneCanPayFlag :: SigHash -> Bool hasAnyoneCanPayFlag = (/= 0) . (.&. sigHashAnyoneCanPay) + -- | Returns 'True' if the 'SigHash' has the value 'SIGHASH_ALL'. isSigHashAll :: SigHash -> Bool isSigHashAll = (== sigHashAll) . (.&. 0x1f) + -- | Returns 'True' if the 'SigHash' has the value 'SIGHASH_NONE'. isSigHashNone :: SigHash -> Bool isSigHashNone = (== sigHashNone) . (.&. 0x1f) + -- | Returns 'True' if the 'SigHash' has the value 'SIGHASH_SINGLE'. isSigHashSingle :: SigHash -> Bool isSigHashSingle = (== sigHashSingle) . (.&. 0x1f) + -- | Returns 'True' if the 'SigHash' has the value 'SIGHASH_UNKNOWN'. isSigHashUnknown :: SigHash -> Bool isSigHashUnknown = (`notElem` [sigHashAll, sigHashNone, sigHashSingle]) . (.&. 0x1f) + -- | Add a fork id to a 'SigHash'. sigHashAddForkId :: SigHash -> Word32 -> SigHash sigHashAddForkId sh w = (fromIntegral w `shiftL` 8) .|. (sh .&. 0x000000ff) + -- | Add fork id of a particular network to a 'SigHash'. sigHashAddNetworkId :: Network -> SigHash -> SigHash sigHashAddNetworkId net = (`sigHashAddForkId` fromMaybe 0 (getSigHashForkId net)) + -- | Get fork id from 'SigHash'. sigHashGetForkId :: SigHash -> Word32 sigHashGetForkId (SigHash n) = fromIntegral $ n `shiftR` 8 + -- | Computes the hash that will be used for signing a transaction. txSigHash :: Network -> @@ -222,9 +232,10 @@ txSigHash net tx out v i sh runPutS $ do serialize newTx putWord32le $ fromIntegral sh - where - fout = Script $ filter (/= OP_CODESEPARATOR) $ scriptOps out - one = "0100000000000000000000000000000000000000000000000000000000000000" + where + fout = Script $ filter (/= OP_CODESEPARATOR) $ scriptOps out + one = "0100000000000000000000000000000000000000000000000000000000000000" + -- | Build transaction inputs for computing sighashes. buildInputs :: [TxIn] -> Script -> Int -> SigHash -> [TxIn] @@ -233,14 +244,15 @@ buildInputs txins out i sh [(txins !! i){scriptInput = runPutS $ serialize 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 = runPutS $ serialize out} - noSeq ti j = - if i == j - then ti - else ti{txInSequence = 0} + where + emptyIn = map (\ti -> ti{scriptInput = BS.empty}) txins + single = + updateIndex i emptyIn $ \ti -> ti{scriptInput = runPutS $ serialize out} + noSeq ti j = + if i == j + then ti + else ti{txInSequence = 0} + -- | Build transaction outputs for computing sighashes. buildOutputs :: [TxOut] -> Int -> SigHash -> Maybe [TxOut] @@ -249,12 +261,12 @@ buildOutputs txos i sh | isSigHashNone sh = return [] | i >= length txos = Nothing | otherwise = return $ buffer ++ [txos !! i] - where - buffer = replicate i $ TxOut maxBound BS.empty + 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. --} +-- | Compute the hash that will be used for signing a transaction. This +-- function is used when the 'SIGHASH_FORKID' flag is set. txSigHashForkId :: Network -> -- | transaction to sign @@ -281,34 +293,34 @@ txSigHashForkId net tx out v i sh = serialize hashOutputs putWord32le $ txLockTime tx putWord32le $ fromIntegral $ sigHashAddNetworkId net sh - where - hashPrevouts - | not $ hasAnyoneCanPayFlag sh = - doubleSHA256 $ runPutS $ mapM_ (serialize . prevOutput) $ txIn tx - | otherwise = zeros - hashSequence - | not (hasAnyoneCanPayFlag sh) - && not (isSigHashSingle sh) - && not (isSigHashNone sh) = - doubleSHA256 $ runPutS $ mapM_ (putWord32le . txInSequence) $ txIn tx - | otherwise = zeros - hashOutputs - | not (isSigHashSingle sh) && not (isSigHashNone sh) = - doubleSHA256 $ runPutS $ mapM_ serialize $ txOut tx - | isSigHashSingle sh && i < length (txOut tx) = - doubleSHA256 $ runPutS $ serialize $ txOut tx !! i - | otherwise = zeros - putScript s = do - let encodedScript = runPutS $ serialize 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'. --} + where + hashPrevouts + | not $ hasAnyoneCanPayFlag sh = + doubleSHA256 $ runPutS $ mapM_ (serialize . prevOutput) $ txIn tx + | otherwise = zeros + hashSequence + | not (hasAnyoneCanPayFlag sh) + && not (isSigHashSingle sh) + && not (isSigHashNone sh) = + doubleSHA256 $ runPutS $ mapM_ (putWord32le . txInSequence) $ txIn tx + | otherwise = zeros + hashOutputs + | not (isSigHashSingle sh) && not (isSigHashNone sh) = + doubleSHA256 $ runPutS $ mapM_ serialize $ txOut tx + | isSigHashSingle sh && i < length (txOut tx) = + doubleSHA256 $ runPutS $ serialize $ txOut tx !! i + | otherwise = zeros + putScript s = do + let encodedScript = runPutS $ serialize 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 @@ -317,14 +329,17 @@ data TxSignature | TxSignatureEmpty deriving (Eq, Show, Generic) + instance NFData TxSignature + -- | Serialize a 'TxSignature'. encodeTxSig :: TxSignature -> BS.ByteString encodeTxSig TxSignatureEmpty = error "Can not encode an empty signature" encodeTxSig (TxSignature sig (SigHash n)) = runPutS $ putSig sig >> putWord8 (fromIntegral n) + -- | Deserialize a 'TxSignature'. decodeTxSig :: Network -> BS.ByteString -> Either String TxSignature decodeTxSig _ bs | BS.null bs = Left "Empty signature candidate" diff --git a/src/Haskoin/Script/Standard.hs b/src/Haskoin/Script/Standard.hs index cf093ad2..e8970630 100644 --- a/src/Haskoin/Script/Standard.hs +++ b/src/Haskoin/Script/Standard.hs @@ -2,17 +2,16 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{- | -Module : Haskoin.Script.Standard -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Standard scripts like pay-to-public-key, pay-to-public-key-hash, -pay-to-script-hash, pay-to-multisig and corresponding SegWit variants. --} +-- | +--Module : Haskoin.Script.Standard +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX +-- +--Standard scripts like pay-to-public-key, pay-to-public-key-hash, +--pay-to-script-hash, pay-to-multisig and corresponding SegWit variants. module Haskoin.Script.Standard ( -- * Standard Script Outputs ScriptOutput (..), @@ -49,8 +48,6 @@ module Haskoin.Script.Standard ( import Control.Applicative ((<|>)) import Control.DeepSeq import Control.Monad (guard, liftM2, (<=<)) -import qualified Data.Aeson as A -import qualified Data.Aeson.Encoding as A import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Bytes.Get @@ -69,10 +66,10 @@ import Haskoin.Script.Common import Haskoin.Script.SigHash import Haskoin.Util -{- | Data type describing standard transaction output scripts. Output scripts - provide the conditions that must be fulfilled for someone to spend the funds - in a transaction output. --} + +-- | Data type describing standard transaction output scripts. Output scripts +-- provide the conditions that must be fulfilled for someone to spend the funds +-- in a transaction output. data ScriptOutput = -- | pay to public key PayPK {getOutputPubKey :: !PubKeyI} @@ -98,60 +95,57 @@ data ScriptOutput DataCarrier {getOutputData :: !ByteString} deriving (Eq, Show, Read, Generic, Hashable, NFData) -instance A.FromJSON ScriptOutput where - parseJSON = - A.withText "scriptoutput" $ \t -> - either fail return $ - maybeToEither "scriptoutput not hex" (decodeHex t) - >>= decodeOutputBS - -instance A.ToJSON ScriptOutput where - toJSON = A.String . encodeHex . encodeOutputBS - toEncoding = A.text . encodeHex . encodeOutputBS -- | Is script a pay-to-public-key output? isPayPK :: ScriptOutput -> Bool isPayPK (PayPK _) = True isPayPK _ = False + -- | Is script a pay-to-pub-key-hash output? isPayPKHash :: ScriptOutput -> Bool isPayPKHash (PayPKHash _) = True isPayPKHash _ = False + -- | Is script a pay-to-multi-sig output? isPayMulSig :: ScriptOutput -> Bool isPayMulSig (PayMulSig _ _) = True isPayMulSig _ = False + -- | Is script a pay-to-script-hash output? isPayScriptHash :: ScriptOutput -> Bool isPayScriptHash (PayScriptHash _) = True isPayScriptHash _ = False + -- | Is script a pay-to-witness-pub-key-hash output? isPayWitnessPKHash :: ScriptOutput -> Bool isPayWitnessPKHash (PayWitnessPKHash _) = True isPayWitnessPKHash _ = False + -- | Is script a pay-to-witness-script-hash output? isPayWitnessScriptHash :: ScriptOutput -> Bool isPayWitnessScriptHash (PayWitnessScriptHash _) = True isPayWitnessScriptHash _ = False + -- | Is script paying to a different type of witness address? isPayWitness :: ScriptOutput -> Bool isPayWitness (PayWitness _ _) = True isPayWitness _ = False + -- | Is script a data carrier output? isDataCarrier :: ScriptOutput -> Bool isDataCarrier (DataCarrier _) = True isDataCarrier _ = False -{- | Tries to decode a 'ScriptOutput' from a 'Script'. This can fail if the - script is not recognized as any of the standard output types. --} + +-- | Tries to decode a 'ScriptOutput' from a 'Script'. This can fail if the +-- script is not recognized as any of the standard output types. decodeOutput :: Script -> Either String ScriptOutput decodeOutput s = case scriptOps s of -- Pay to PubKey @@ -179,6 +173,7 @@ decodeOutput s = case scriptOps s of -- Pay to MultiSig Keys _ -> matchPayMulSig s + witnessVersionOp :: Word8 -> Maybe ScriptOp witnessVersionOp 0 = Just OP_0 witnessVersionOp 1 = Just OP_1 @@ -199,6 +194,7 @@ witnessVersionOp 15 = Just OP_15 witnessVersionOp 16 = Just OP_16 witnessVersionOp _ = Nothing + opWitnessVersion :: ScriptOp -> Maybe Word8 opWitnessVersion OP_0 = Just 0 opWitnessVersion OP_1 = Just 1 @@ -219,10 +215,12 @@ opWitnessVersion OP_15 = Just 15 opWitnessVersion OP_16 = Just 16 opWitnessVersion _ = Nothing + -- | Similar to 'decodeOutput' but decodes from a 'ByteString'. decodeOutputBS :: ByteString -> Either String ScriptOutput decodeOutputBS = decodeOutput <=< runGetS deserialize + -- | Computes a 'Script' from a standard 'ScriptOutput'. encodeOutput :: ScriptOutput -> Script encodeOutput s = Script $ case s of @@ -261,18 +259,22 @@ encodeOutput s = Script $ case s of -- Provably unspendable output (DataCarrier d) -> [OP_RETURN, opPushData d] + -- | Similar to 'encodeOutput' but encodes to a ByteString encodeOutputBS :: ScriptOutput -> ByteString encodeOutputBS = runPutS . serialize . encodeOutput + -- | Encode script as pay-to-script-hash script toP2SH :: Script -> ScriptOutput toP2SH = PayScriptHash . addressHash . runPutS . serialize + -- | Encode script as a pay-to-witness-script-hash script toP2WSH :: Script -> ScriptOutput toP2WSH = PayWitnessScriptHash . sha256 . runPutS . serialize + -- | Match @[OP_N, PubKey1, ..., PubKeyM, OP_M, OP_CHECKMULTISIG]@ matchPayMulSig :: Script -> Either String ScriptOutput matchPayMulSig (Script ops) = case splitAt (length ops - 2) ops of @@ -282,24 +284,24 @@ matchPayMulSig (Script ops) = case splitAt (length ops - 2) ops of then liftM2 PayMulSig (go xs) (return intM) else Left "matchPayMulSig: Invalid M or N parameters" _ -> Left "matchPayMulSig: script did not match output template" - where - go (OP_PUSHDATA bs _ : xs) = liftM2 (:) (runGetS deserialize bs) (go xs) - go [] = return [] - go _ = Left "matchPayMulSig: invalid multisig opcode" - -{- | Sort the public keys of a multisig output in ascending order by comparing - their compressed serialized representations. Refer to BIP-67. --} + where + go (OP_PUSHDATA bs _ : xs) = liftM2 (:) (runGetS deserialize bs) (go xs) + go [] = return [] + go _ = Left "matchPayMulSig: invalid multisig opcode" + + +-- | Sort the public keys of a multisig output in ascending order by comparing +-- their compressed serialized representations. Refer to BIP-67. sortMulSig :: ScriptOutput -> ScriptOutput sortMulSig out = case out of PayMulSig keys r -> PayMulSig (sortBy (compare `on` (runPutS . serialize)) keys) r _ -> error "Can only call orderMulSig on PayMulSig scripts" -{- | Data type describing standard transaction input scripts. Input scripts - provide the signing data required to unlock the coins of the output they are - trying to spend, except in pay-to-witness-public-key-hash and - pay-to-script-hash transactions. --} + +-- | Data type describing standard transaction input scripts. Input scripts +-- provide the signing data required to unlock the coins of the output they are +-- trying to spend, except in pay-to-witness-public-key-hash and +-- pay-to-script-hash transactions. data SimpleInput = SpendPK { -- | transaction signature @@ -317,35 +319,38 @@ data SimpleInput } deriving (Eq, Show, Generic, NFData) -{- | Returns true if the input script is spending from a pay-to-public-key - output. --} + +-- | Returns true if the input script is spending from a pay-to-public-key +-- output. isSpendPK :: ScriptInput -> Bool isSpendPK (RegularInput (SpendPK _)) = True isSpendPK _ = False -{- | Returns true if the input script is spending from a pay-to-public-key-hash - output. --} + +-- | Returns true if the input script is spending from a pay-to-public-key-hash +-- output. isSpendPKHash :: ScriptInput -> Bool isSpendPKHash (RegularInput (SpendPKHash _ _)) = True isSpendPKHash _ = False + -- | Returns true if the input script is spending a multisig output. isSpendMulSig :: ScriptInput -> Bool isSpendMulSig (RegularInput (SpendMulSig _)) = True isSpendMulSig _ = False + -- | Returns true if the input script is spending a pay-to-script-hash output. isScriptHashInput :: ScriptInput -> Bool isScriptHashInput (ScriptHashInput _ _) = True isScriptHashInput _ = False -{- | A redeem script is the output script serialized into the spending input - script. It must be included in inputs that spend pay-to-script-hash outputs. --} + +-- | A redeem script is the output script serialized into the spending input +-- script. It must be included in inputs that spend pay-to-script-hash outputs. type RedeemScript = ScriptOutput + -- | Standard input script high-level representation. data ScriptInput = RegularInput @@ -360,50 +365,52 @@ data ScriptInput } 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 (runGetS deserialize 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. --} + where + matchPK [op] = SpendPK <$> f op + matchPK _ = Nothing + matchPKHash [op, OP_PUSHDATA pub _] = + SpendPKHash <$> f op <*> eitherToMaybe (runGetS deserialize 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'. --} + 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 <=< runGetS deserialize + -- | Encode a standard input into a script. encodeInput :: ScriptInput -> Script encodeInput s = case s of @@ -412,12 +419,13 @@ encodeInput s = case s of Script $ scriptOps (encodeSimpleInput i) ++ [opPushData $ encodeOutputBS o] -{- | Similar to 'encodeInput' but encodes directly to a serialized script - 'ByteString'. --} + +-- | Similar to 'encodeInput' but encodes directly to a serialized script +-- 'ByteString'. encodeInputBS :: ScriptInput -> ByteString encodeInputBS = runPutS . serialize . encodeInput + -- | Encode a standard 'SimpleInput' into opcodes as an input 'Script'. encodeSimpleInput :: SimpleInput -> Script encodeSimpleInput s = @@ -426,6 +434,6 @@ encodeSimpleInput s = SpendPK ts -> [f ts] SpendPKHash ts p -> [f ts, opPushData $ runPutS $ serialize p] SpendMulSig xs -> OP_0 : map f xs - where - f TxSignatureEmpty = OP_0 - f ts = opPushData $ encodeTxSig ts + where + f TxSignatureEmpty = OP_0 + f ts = opPushData $ encodeTxSig ts diff --git a/src/Haskoin/Transaction/Builder.hs b/src/Haskoin/Transaction/Builder.hs index 68af9c91..b1113876 100644 --- a/src/Haskoin/Transaction/Builder.hs +++ b/src/Haskoin/Transaction/Builder.hs @@ -2,17 +2,16 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{- | -Module : Haskoin.Transaction.Builder -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Code to simplify transaction creation, signing, fee calculation and coin -selection. --} +-- | +--Module : Haskoin.Transaction.Builder +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX +-- +--Code to simplify transaction creation, signing, fee calculation and coin +--selection. module Haskoin.Transaction.Builder ( -- * Transaction Builder buildAddrTx, @@ -30,38 +29,17 @@ module Haskoin.Transaction.Builder ( 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 Control.Monad.Trans.Identity (runIdentityT) import Crypto.Secp256k1 import qualified Data.ByteString as B import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial -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) @@ -90,182 +68,27 @@ import Haskoin.Transaction.Segwit ( ) import Haskoin.Util -{- | Any type can be used as a Coin if it can provide a value in Satoshi. - The value is used in coin selection algorithms. --} + +-- | Any type can be used as a Coin if it can provide a value in Satoshi. +-- The value is used in coin selection algorithms. class Coin c where coinValue :: c -> Word64 -{- | Coin selection algorithm for normal (non-multisig) transactions. This - function returns the selected coins together with the amount of change to - send back to yourself, taking the fee into account. --} -chooseCoins :: - Coin c => - -- | value to send - Word64 -> - -- | fee per byte - Word64 -> - -- | number of outputs (including change) - Int -> - -- | try to find better solutions - Bool -> - -- | list of ordered coins to choose from - [c] -> - -- | coin selection and change - Either String ([c], Word64) -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) => - -- | value to send - Word64 -> - -- | fee per byte - Word64 -> - -- | number of outputs (including change) - Int -> - -- | try to find better solution - Bool -> - -- | coin selection and change - ConduitT c Void m (Either String ([c], Word64)) -chooseCoinsSink target fee nOut continue - | target > 0 = - maybeToEither err - <$> greedyAddSink target (guessTxFee fee nOut) continue - | otherwise = return $ Left "chooseCoins: Target must be > 0" - 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 => - -- | value to send - Word64 -> - -- | fee per byte - Word64 -> - -- | m of n multisig - (Int, Int) -> - -- | number of outputs (including change) - Int -> - -- | try to find better solution - Bool -> - [c] -> - -- | coin selection change amount - Either String ([c], Word64) -chooseMSCoins target fee ms nOut continue coins = - runIdentity . runConduit $ - sourceList coins .| chooseMSCoinsSink target fee ms nOut continue - -{- | Coin selection algorithm for multisig transactions. This function returns - the selected coins together with the amount of change to send back to - yourself, taking the fee into account. This function assumes all the coins - are script hash outputs that send funds to a multisignature address. This - version uses a Sink if you need conduit-based coin selection. --} -chooseMSCoinsSink :: - (Monad m, Coin c) => - -- | value to send - Word64 -> - -- | fee per byte - Word64 -> - -- | m of n multisig - (Int, Int) -> - -- | number of outputs (including change) - Int -> - -- | try to find better solution - Bool -> - -- | coin selection and change - ConduitT c Void m (Either String ([c], Word64)) -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) => - -- | value to send - Word64 -> - -- | coin count to fee function - (Int -> Word64) -> - -- | try to find better solutions - Bool -> - -- | coin selection and change - ConduitT c Void m (Maybe ([c], Word64)) -greedyAddSink target guessFee continue = - go [] 0 [] 0 - where - -- The goal is the value we must reach (including the fee) for a certain - -- amount of selected coins. - goal c = target + guessFee c - go acc aTot ps pTot = - await >>= \case - -- A coin is available in the stream - Just coin -> do - let val = coinValue coin - -- We have reached the goal using this coin - if val + aTot >= goal (length acc + 1) - then -- If we want to continue searching for better solutions - - if continue - then -- This solution is the first one or - -- This solution is better than the previous one - - if pTot == 0 || val + aTot < pTot - then -- Continue searching for better solutions in the stream - go [] 0 (coin : acc) (val + aTot) - else -- Otherwise, we stop here and return the previous - -- solution - return $ Just (ps, pTot - goal (length ps)) - else -- Otherwise, return this solution - - return $ - Just (coin : acc, val + aTot - goal (length acc + 1)) - else -- We have not yet reached the goal. Add the coin to the - -- accumulator - go (coin : acc) (val + aTot) ps pTot - -- We reached the end of the stream - Nothing -> - return $ - if null ps - then -- If no solution was found, return Nothing - Nothing - else -- If we have a solution, return it - Just (ps, pTot - goal (length ps)) -- | Estimate tranasction fee to pay based on transaction size estimation. guessTxFee :: Word64 -> Int -> Int -> Word64 guessTxFee byteFee nOut nIn = byteFee * fromIntegral (guessTxSize nIn [] nOut 0) + -- | Same as 'guessTxFee' but for multisig transactions. guessMSTxFee :: Word64 -> (Int, Int) -> Int -> Int -> Word64 guessMSTxFee byteFee ms nOut nIn = byteFee * fromIntegral (guessTxSize 0 (replicate nIn ms) nOut 0) -{- | Computes an upper bound on the size of a transaction based on some known - properties of the transaction. --} + +-- | Computes an upper bound on the size of a transaction based on some known +-- properties of the transaction. guessTxSize :: -- | number of regular transaction inputs Int -> @@ -279,30 +102,31 @@ guessTxSize :: Int guessTxSize pki msi pkout msout = 8 + inpLen + inp + outLen + out - where - inpLen = - B.length - . runPutS - . serialize - . VarInt - . fromIntegral - $ length msi + pki - outLen = - B.length - . runPutS - . serialize - . VarInt - . fromIntegral - $ pkout + msout - inp = pki * 148 + sum (map guessMSSize msi) - -- (20: hash160) + (5: opcodes) + - -- (1: script len) + (8: Word64) - out = - pkout * 34 - + - -- (20: hash160) + (3: opcodes) + - -- (1: script len) + (8: Word64) - msout * 32 + where + inpLen = + B.length + . runPutS + . serialize + . VarInt + . fromIntegral + $ length msi + pki + outLen = + B.length + . runPutS + . serialize + . VarInt + . fromIntegral + $ pkout + msout + inp = pki * 148 + sum (map guessMSSize msi) + -- (20: hash160) + (5: opcodes) + + -- (1: script len) + (8: Word64) + out = + pkout * 34 + + + -- (20: hash160) + (3: opcodes) + + -- (1: script len) + (8: Word64) + msout * 32 + -- | Size of a multisig P2SH input. guessMSSize :: (Int, Int) -> Int @@ -311,54 +135,54 @@ guessMSSize (m, n) = 40 + fromIntegral (B.length $ runPutS . serialize $ VarInt $ fromIntegral scp) + scp - where - -- OP_M + n*PubKey + OP_N + OP_CHECKMULTISIG + where + -- OP_M + n*PubKey + OP_N + OP_CHECKMULTISIG + + rdm = + fromIntegral $ + B.length $ runPutS $ serialize $ opPushData $ B.replicate (n * 34 + 3) 0 + -- Redeem + m*sig + OP_0 + scp = rdm + m * 73 + 1 - rdm = - fromIntegral $ - B.length $ runPutS $ serialize $ opPushData $ B.replicate (n * 34 + 3) 0 - -- Redeem + m*sig + OP_0 - scp = rdm + m * 73 + 1 {- Build a new Tx -} -{- | Build a transaction by providing a list of outpoints as inputs - and a list of recipient addresses and amounts as outputs. --} +-- | Build a transaction by providing a list of outpoints as inputs +-- and a list of recipient addresses and amounts as outputs. buildAddrTx :: Network -> [OutPoint] -> [(Text, Word64)] -> Either String Tx buildAddrTx net ops rcps = buildTx ops <$> mapM f rcps - where - f (aTxt, v) = - maybeToEither ("buildAddrTx: Invalid address " <> cs aTxt) $ do - a <- textToAddr net aTxt - let o = addressToOutput a - return (o, v) - -{- | Build a transaction by providing a list of outpoints as inputs - and a list of 'ScriptOutput' and amounts as outputs. --} + where + f (aTxt, v) = + maybeToEither ("buildAddrTx: Invalid address " <> cs aTxt) $ do + a <- textToAddr net aTxt + let o = addressToOutput a + return (o, v) + + +-- | Build a transaction by providing a list of outpoints as inputs +-- and a list of 'ScriptOutput' and amounts as outputs. buildTx :: [OutPoint] -> [(ScriptOutput, Word64)] -> Tx buildTx ops rcpts = Tx 1 (toIn <$> ops) (toOut <$> rcpts) [] 0 - where - toIn op = TxIn op B.empty maxBound - toOut (o, v) = TxOut v $ encodeOutputBS o - -{- | Sign a transaction by providing the 'SigInput' signing parameters and a - list of private keys. The signature is computed deterministically as defined - in RFC-6979. - - Example: P2SH-P2WKH - - > sigIn = SigInput (PayWitnessPKHash h) 100000 op sigHashAll Nothing - > signedTx = signTx btc unsignedTx [sigIn] [key] - - Example: P2SH-P2WSH multisig - - > sigIn = SigInput (PayWitnessScriptHash h) 100000 op sigHashAll (Just $ PayMulSig [p1,p2,p3] 2) - > signedTx = signTx btc unsignedTx [sigIn] [k1,k3] --} + where + toIn op = TxIn op B.empty maxBound + toOut (o, v) = TxOut v $ encodeOutputBS o + + +-- | Sign a transaction by providing the 'SigInput' signing parameters and a +-- list of private keys. The signature is computed deterministically as defined +-- in RFC-6979. +-- +-- Example: P2SH-P2WKH +-- +-- > sigIn = SigInput (PayWitnessPKHash h) 100000 op sigHashAll Nothing +-- > signedTx = signTx btc unsignedTx [sigIn] [key] +-- +-- Example: P2SH-P2WSH multisig +-- +-- > sigIn = SigInput (PayWitnessScriptHash h) 100000 op sigHashAll (Just $ PayMulSig [p1,p2,p3] 2) +-- > signedTx = signTx btc unsignedTx [sigIn] [k1,k3] signTx :: Network -> -- | transaction to sign @@ -370,12 +194,12 @@ signTx :: -- | signed transaction Either String Tx signTx net tx si = S.signTx net tx $ notNested <$> si - where - notNested s = (s, False) + where + notNested s = (s, False) -{- | This function differs from 'signTx' by assuming all segwit inputs are - P2SH-nested. Use the same signing parameters for segwit inputs as in 'signTx'. --} + +-- | This function differs from 'signTx' by assuming all segwit inputs are +-- P2SH-nested. Use the same signing parameters for segwit inputs as in 'signTx'. signNestedWitnessTx :: Network -> -- | transaction to sign @@ -387,31 +211,33 @@ signNestedWitnessTx :: -- | signed transaction Either String Tx 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) + 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. --} + +-- | Order the 'SigInput' with respect to the transaction inputs. This allows +-- the user to provide the 'SigInput' in any order. Users can also provide only +-- a partial set of 'SigInput' entries. findSigInput :: [SigInput] -> [TxIn] -> [(SigInput, Int)] findSigInput = S.findInputIndex sigInputOP + {- Merge multisig transactions -} -{- | Merge partially-signed multisig transactions. This function does not - support segwit and P2SH-segwit inputs. Use PSBTs to merge transactions with - segwit inputs. --} +-- | Merge partially-signed multisig transactions. This function does not +-- support segwit and P2SH-segwit inputs. Use PSBTs to merge transactions with +-- segwit inputs. mergeTxs :: Network -> [Tx] -> [(ScriptOutput, Word64, OutPoint)] -> Either String Tx mergeTxs net txs os @@ -419,20 +245,20 @@ mergeTxs net txs os | 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. --} + 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] -> @@ -448,33 +274,34 @@ mergeTxInput net txs tx ((so, val), i) = do 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 + 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 -} @@ -482,10 +309,11 @@ mergeTxInput net txs tx ((so, val), i) = do 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 + 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 @@ -496,62 +324,63 @@ verifyStdInput net tx i so0 val fromRight False $ (verifyLegacyInput so0 <$> decodeInputBS net inp) <|> (nestedScriptOutput >>= \so -> verifyNestedInput so0 so <$> wp so) - where - inp = scriptInput $ txIn tx !! i - theTxSigHash so = S.makeSigHash net tx i so val - - ws :: WitnessStack - ws - | length (txWitness tx) > i = txWitness tx !! i - | otherwise = [] - - wp :: ScriptOutput -> Either String (Maybe ScriptOutput, SimpleInput) - wp so = decodeWitnessInput net =<< viewWitnessProgram net so ws - - nestedScriptOutput :: Either String ScriptOutput - nestedScriptOutput = - scriptOps <$> runGetS deserialize inp >>= \case - [OP_PUSHDATA bs _] -> decodeOutputBS bs - _ -> Left "nestedScriptOutput: not a nested output" - - verifyLegacyInput :: ScriptOutput -> ScriptInput -> Bool - verifyLegacyInput so si = case (so, si) of - (PayPK pub, RegularInput (SpendPK (TxSignature sig sh))) -> - verifyHashSig (theTxSigHash so sh Nothing) sig (pubKeyPoint pub) - (PayPKHash h, RegularInput (SpendPKHash (TxSignature sig sh) pub)) -> - pubKeyAddr pub == p2pkhAddr h - && verifyHashSig (theTxSigHash so sh Nothing) sig (pubKeyPoint pub) - (PayMulSig pubs r, RegularInput (SpendMulSig sigs)) -> - countMulSig net tx out val i (pubKeyPoint <$> pubs) sigs == r - (PayScriptHash h, ScriptHashInput si' rdm) -> - payToScriptAddress rdm == p2shAddr h && verifyLegacyInput rdm (RegularInput si') - _ -> False - where - out = encodeOutput so - - verifySegwitInput :: - ScriptOutput -> (Maybe ScriptOutput, SimpleInput) -> Bool - verifySegwitInput so (rdm, si) = case (so, rdm, si) of - (PayWitnessPKHash h, Nothing, SpendPKHash (TxSignature sig sh) pub) -> - pubKeyWitnessAddr pub == p2wpkhAddr h - && verifyHashSig (theTxSigHash so sh Nothing) sig (pubKeyPoint pub) - (PayWitnessScriptHash h, Just rdm'@(PayPK pub), SpendPK (TxSignature sig sh)) -> - payToWitnessScriptAddress rdm' == p2wshAddr h - && verifyHashSig (theTxSigHash so sh $ Just rdm') sig (pubKeyPoint pub) - (PayWitnessScriptHash h, Just rdm'@(PayPKHash kh), SpendPKHash (TxSignature sig sh) pub) -> - payToWitnessScriptAddress rdm' == p2wshAddr h - && addressHash (runPutS (serialize pub)) == kh - && verifyHashSig (theTxSigHash so sh $ Just rdm') sig (pubKeyPoint pub) - (PayWitnessScriptHash h, Just rdm'@(PayMulSig pubs r), SpendMulSig sigs) -> - payToWitnessScriptAddress rdm' == p2wshAddr h - && countMulSig' (\sh -> theTxSigHash so sh $ Just rdm') (pubKeyPoint <$> pubs) sigs == r - _ -> False - - verifyNestedInput :: - ScriptOutput -> ScriptOutput -> (Maybe RedeemScript, SimpleInput) -> Bool - verifyNestedInput so so' x = case so of - PayScriptHash h -> payToScriptAddress so' == p2shAddr h && verifySegwitInput so' x - _ -> False + where + inp = scriptInput $ txIn tx !! i + theTxSigHash so = S.makeSigHash net tx i so val + + ws :: WitnessStack + ws + | length (txWitness tx) > i = txWitness tx !! i + | otherwise = [] + + wp :: ScriptOutput -> Either String (Maybe ScriptOutput, SimpleInput) + wp so = decodeWitnessInput net =<< viewWitnessProgram net so ws + + nestedScriptOutput :: Either String ScriptOutput + nestedScriptOutput = + scriptOps <$> runGetS deserialize inp >>= \case + [OP_PUSHDATA bs _] -> decodeOutputBS bs + _ -> Left "nestedScriptOutput: not a nested output" + + verifyLegacyInput :: ScriptOutput -> ScriptInput -> Bool + verifyLegacyInput so si = case (so, si) of + (PayPK pub, RegularInput (SpendPK (TxSignature sig sh))) -> + verifyHashSig (theTxSigHash so sh Nothing) sig (pubKeyPoint pub) + (PayPKHash h, RegularInput (SpendPKHash (TxSignature sig sh) pub)) -> + pubKeyAddr pub == p2pkhAddr h + && verifyHashSig (theTxSigHash so sh Nothing) sig (pubKeyPoint pub) + (PayMulSig pubs r, RegularInput (SpendMulSig sigs)) -> + countMulSig net tx out val i (pubKeyPoint <$> pubs) sigs == r + (PayScriptHash h, ScriptHashInput si' rdm) -> + payToScriptAddress rdm == p2shAddr h && verifyLegacyInput rdm (RegularInput si') + _ -> False + where + out = encodeOutput so + + verifySegwitInput :: + ScriptOutput -> (Maybe ScriptOutput, SimpleInput) -> Bool + verifySegwitInput so (rdm, si) = case (so, rdm, si) of + (PayWitnessPKHash h, Nothing, SpendPKHash (TxSignature sig sh) pub) -> + pubKeyWitnessAddr pub == p2wpkhAddr h + && verifyHashSig (theTxSigHash so sh Nothing) sig (pubKeyPoint pub) + (PayWitnessScriptHash h, Just rdm'@(PayPK pub), SpendPK (TxSignature sig sh)) -> + payToWitnessScriptAddress rdm' == p2wshAddr h + && verifyHashSig (theTxSigHash so sh $ Just rdm') sig (pubKeyPoint pub) + (PayWitnessScriptHash h, Just rdm'@(PayPKHash kh), SpendPKHash (TxSignature sig sh) pub) -> + payToWitnessScriptAddress rdm' == p2wshAddr h + && addressHash (runPutS (serialize pub)) == kh + && verifyHashSig (theTxSigHash so sh $ Just rdm') sig (pubKeyPoint pub) + (PayWitnessScriptHash h, Just rdm'@(PayMulSig pubs r), SpendMulSig sigs) -> + payToWitnessScriptAddress rdm' == p2wshAddr h + && countMulSig' (\sh -> theTxSigHash so sh $ Just rdm') (pubKeyPoint <$> pubs) sigs == r + _ -> False + + verifyNestedInput :: + ScriptOutput -> ScriptOutput -> (Maybe RedeemScript, SimpleInput) -> Bool + verifyNestedInput so so' x = case so of + PayScriptHash h -> payToScriptAddress so' == p2shAddr h && verifySegwitInput so' x + _ -> False + -- | Count the number of valid signatures for a multi-signature transaction. countMulSig :: @@ -565,8 +394,9 @@ countMulSig :: Int countMulSig net tx out val i = countMulSig' h - where - h = txSigHash net tx out val i + where + h = txSigHash net tx out val i + countMulSig' :: (SigHash -> Hash256) -> [PubKey] -> [TxSignature] -> Int countMulSig' _ [] _ = 0 diff --git a/src/Haskoin/Transaction/Builder/Sign.hs b/src/Haskoin/Transaction/Builder/Sign.hs index adc4f245..7073f955 100644 --- a/src/Haskoin/Transaction/Builder/Sign.hs +++ b/src/Haskoin/Transaction/Builder/Sign.hs @@ -3,16 +3,15 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{- | -Module : Haskoin.Transaction.Builder.Sign -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Types and logic for signing transactions. --} +-- | +--Module : Haskoin.Transaction.Builder.Sign +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX +-- +--Types and logic for signing transactions. module Haskoin.Transaction.Builder.Sign ( SigInput (..), makeSignature, @@ -26,17 +25,6 @@ module Haskoin.Transaction.Builder.Sign ( import Control.DeepSeq (NFData) import Control.Monad (foldM, when) -import Data.Aeson ( - FromJSON, - ToJSON (..), - object, - pairs, - parseJSON, - withObject, - (.:), - (.:?), - (.=), - ) import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial @@ -66,11 +54,11 @@ import Haskoin.Transaction.Common import Haskoin.Transaction.Segwit import Haskoin.Util (matchTemplate, updateIndex) -{- | Data type used to specify the signing parameters of a transaction input. - To sign an input, the previous output script, outpoint and sighash are - required. When signing a pay to script hash output, an additional redeem - script is required. --} + +-- | Data type used to specify the signing parameters of a transaction input. +-- To sign an input, the previous output script, outpoint and sighash are +-- required. When signing a pay to script hash output, an additional redeem +-- script is required. data SigInput = SigInput { -- | output script to spend -- ^ output script value @@ -89,36 +77,10 @@ data SigInput = SigInput } 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 - <> maybe mempty ("redeem" .=) rdm - -instance FromJSON SigInput where - parseJSON = - withObject "SigInput" $ \o -> - SigInput <$> o .: "pkscript" - <*> o .: "value" - <*> o .: "outpoint" - <*> o .: "sighash" - <*> o .:? "redeem" -{- | Sign a transaction by providing the 'SigInput' signing parameters and a - list of private keys. The signature is computed deterministically as defined - in RFC-6979. --} +-- | Sign a transaction by providing the 'SigInput' signing parameters and a +-- list of private keys. The signature is computed deterministically as defined +-- in RFC-6979. signTx :: Network -> -- | transaction to sign @@ -132,15 +94,15 @@ signTx :: 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 + 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. --} +-- | Sign a single input in a transaction deterministically (RFC-6979). The +-- nesting flag only affects the behavior of segwit inputs. signInput :: Network -> Tx -> @@ -158,30 +120,31 @@ signInput net tx i (sigIn@(SigInput so val _ _ rdmM), nest) key = do { txIn = nextTxIn so si , txWitness = w } - where - f si x = x{scriptInput = encodeInputBS si} - g so' x = x{scriptInput = runPutS . serialize . 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) + where + f si x = x{scriptInput = encodeInputBS si} + g so' x = x{scriptInput = runPutS . serialize . 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 --} +-- | 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 + 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 :: @@ -194,14 +157,14 @@ findInputIndex :: [(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 + 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'. --} +-- | Find from the list of provided private keys which one is required to sign +-- the 'ScriptOutput'. sigKeys :: ScriptOutput -> Maybe RedeemScript -> @@ -218,20 +181,20 @@ sigKeys so rdmM 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 + 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. --} + +-- | Construct an input for a transaction given a signature, public key and data +-- about the previous output. buildInput :: Network -> -- | transaction where input will be added @@ -255,51 +218,52 @@ buildInput net tx i so val rdmM sig pub = do (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 + 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 --} +-- | 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) + 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 + where + m = makeSigHash net tx i so val sh rdmM -{- | A function which selects the digest algorithm and parameters as appropriate - @since 0.11.0.0 --} +-- | A function which selects the digest algorithm and parameters as appropriate +-- +-- @since 0.11.0.0 makeSigHash :: Network -> Tx -> @@ -310,10 +274,10 @@ makeSigHash :: 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 + 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 index 052bb5ab..e67633a1 100644 --- a/src/Haskoin/Transaction/Common.hs +++ b/src/Haskoin/Transaction/Common.hs @@ -2,16 +2,15 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{- | -Module : Haskoin.Transaction.Common -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -Code related to transactions parsing and serialization. --} +-- | +--Module : Haskoin.Transaction.Common +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX +-- +--Code related to transactions parsing and serialization. module Haskoin.Transaction.Common ( -- * Transactions Tx (..), @@ -41,9 +40,6 @@ import Control.Monad ( when, (<=<), ) -import Data.Aeson as A -import Data.Aeson.Encoding (unsafeToEncoding) -import Data.Binary (Binary (..)) import Data.ByteString (ByteString) import qualified Data.ByteString as B import Data.ByteString.Builder (char7) @@ -53,7 +49,6 @@ import Data.Bytes.Put import Data.Bytes.Serial import Data.Hashable (Hashable) import Data.Maybe (fromMaybe) -import Data.Serialize (Serialize (..)) import Data.String (IsString, fromString) import Data.String.Conversions (cs) import Data.Text (Text) @@ -64,43 +59,27 @@ import Haskoin.Network.Common import Haskoin.Util import Text.Read as R + -- | Transaction id: hash of transaction excluding witness data. newtype TxHash = TxHash {getTxHash :: Hash256} deriving (Eq, Ord, Generic, Hashable, Serial, NFData) -instance Serialize TxHash where - put = serialize - get = deserialize - -instance Binary TxHash where - put = serialize - get = deserialize instance Show TxHash where showsPrec _ = shows . txHashToHex + instance Read TxHash where readPrec = do R.String str <- R.lexP maybe R.pfail return $ hexToTxHash $ cs str + instance IsString TxHash where fromString s = let e = error "Could not read transaction hash from hex string" in fromMaybe e $ hexToTxHash $ cs s -instance FromJSON TxHash where - parseJSON = - withText "txid" $ - maybe mzero return . hexToTxHash - -instance ToJSON TxHash where - toJSON = A.String . txHashToHex - toEncoding h = - unsafeToEncoding $ - char7 '"' - <> hexBuilder (BL.reverse (runPutL (serialize h))) - <> char7 '"' -- | Transaction hash excluding signatures. nosigTxHash :: Tx -> TxHash @@ -109,13 +88,15 @@ nosigTxHash tx = doubleSHA256 $ runPutS $ serialize tx{txIn = map clearInput $ txIn tx} - where - clearInput ti = ti{scriptInput = B.empty} + where + clearInput ti = ti{scriptInput = B.empty} + -- | Convert transaction hash to hex form, reversing bytes. txHashToHex :: TxHash -> Text txHashToHex (TxHash h) = encodeHex (B.reverse (runPutS (serialize h))) + -- | Convert transaction hash from hex, reversing bytes. hexToTxHash :: Text -> Maybe TxHash hexToTxHash hex = do @@ -123,15 +104,19 @@ hexToTxHash hex = do h <- either (const Nothing) Just (runGetS deserialize bs) return $ TxHash h + -- | Witness stack for SegWit transactions. type WitnessData = [WitnessStack] + -- | Witness stack for SegWit transactions. type WitnessStack = [WitnessStackItem] + -- | Witness stack item for SegWit transactions. type WitnessStackItem = ByteString + -- | Data type representing a transaction. data Tx = Tx { -- | transaction data format version @@ -147,15 +132,18 @@ data Tx = Tx } deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + -- | Compute transaction hash. txHash :: Tx -> TxHash txHash tx = TxHash . doubleSHA256 . runPutS $ serialize tx{txWitness = []} + instance IsString Tx where fromString = fromMaybe e . (eitherToMaybe . runGetS deserialize <=< decodeHex) . cs - where - e = error "Could not read transaction from hex string" + where + e = error "Could not read transaction from hex string" + instance Serial Tx where deserialize = @@ -164,13 +152,6 @@ instance Serial Tx where | null (txWitness tx) = putLegacyTx tx | otherwise = putWitnessTx tx -instance Binary Tx where - put = serialize - get = deserialize - -instance Serialize Tx where - put = serialize - get = deserialize putInOut :: MonadPut m => Tx -> m () putInOut tx = do @@ -179,6 +160,7 @@ putInOut tx = do putVarInt $ length (txOut tx) forM_ (txOut tx) serialize + -- | Non-SegWit transaction serializer. putLegacyTx :: MonadPut m => Tx -> m () putLegacyTx tx = do @@ -186,6 +168,7 @@ putLegacyTx tx = do putInOut tx putWord32le (txLockTime tx) + -- | Witness transaciton serializer. putWitnessTx :: MonadPut m => Tx -> m () putWitnessTx tx = do @@ -196,6 +179,7 @@ putWitnessTx tx = do putWitnessData (txWitness tx) putWord32le (txLockTime tx) + isWitnessTx :: MonadGet m => m Bool isWitnessTx = lookAhead $ do _ <- getWord32le @@ -203,6 +187,7 @@ isWitnessTx = lookAhead $ do f <- getWord8 return (m == 0x00 && f == 0x01) + -- | Non-SegWit transaction deseralizer. parseLegacyTx :: MonadGet m => m Tx parseLegacyTx = do @@ -219,8 +204,9 @@ parseLegacyTx = do , txWitness = [] , txLockTime = l } - where - replicateList (VarInt c) = replicateM (fromIntegral c) deserialize + where + replicateList (VarInt c) = replicateM (fromIntegral c) deserialize + -- | Witness transaction deserializer. parseWitnessTx :: MonadGet m => m Tx @@ -235,58 +221,33 @@ parseWitnessTx = do l <- getWord32le return Tx{txVersion = v, txIn = is, txOut = os, txWitness = w, txLockTime = l} - where - replicateList (VarInt c) = replicateM (fromIntegral c) deserialize + where + replicateList (VarInt c) = replicateM (fromIntegral c) deserialize + -- | Witness data deserializer. Requires count of inputs. parseWitnessData :: MonadGet m => Int -> m WitnessData parseWitnessData n = replicateM n parseWitnessStack - where - parseWitnessStack = do - VarInt i <- deserialize - replicateM (fromIntegral i) parseWitnessStackItem - parseWitnessStackItem = do - VarInt i <- deserialize - getByteString $ fromIntegral i + where + parseWitnessStack = do + VarInt i <- deserialize + replicateM (fromIntegral i) parseWitnessStackItem + parseWitnessStackItem = do + VarInt i <- deserialize + getByteString $ fromIntegral i + -- | Witness data serializer. putWitnessData :: MonadPut m => WitnessData -> m () 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 = withObject "Tx" $ \o -> - Tx <$> o .: "version" - <*> o .: "inputs" - <*> o .: "outputs" - <*> (mapM (mapM f) =<< o .: "witnessdata") - <*> o .: "locktime" - where - f = maybe mzero return . decodeHex - -instance ToJSON Tx where - toJSON (Tx v i o w l) = - object - [ "version" .= v - , "inputs" .= i - , "outputs" .= o - , "witnessdata" .= fmap (fmap encodeHex) w - , "locktime" .= l - ] - toEncoding (Tx v i o w l) = - pairs - ( "version" .= v - <> "inputs" .= i - <> "outputs" .= o - <> "witnessdata" .= fmap (fmap encodeHex) w - <> "locktime" .= l - ) + where + putWitnessStack ws = do + putVarInt $ length ws + mapM_ putWitnessStackItem ws + putWitnessStackItem bs = do + putVarInt $ B.length bs + putByteString bs + -- | Data type representing a transaction input. data TxIn = TxIn @@ -299,11 +260,13 @@ data TxIn = TxIn } deriving (Eq, Show, Read, Ord, Generic, Hashable, NFData) + instance Serial TxIn where deserialize = TxIn <$> deserialize <*> (readBS =<< deserialize) <*> getWord32le - where - readBS (VarInt len) = getByteString $ fromIntegral len + where + readBS (VarInt len) = getByteString $ fromIntegral len + serialize (TxIn o s q) = do serialize o @@ -311,34 +274,6 @@ instance Serial TxIn where putByteString s putWord32le q -instance Binary TxIn where - get = deserialize - put = serialize - -instance Serialize TxIn where - get = deserialize - put = serialize - -instance FromJSON TxIn where - parseJSON = - withObject "TxIn" $ \o -> - TxIn <$> o .: "prevoutput" - <*> (maybe mzero return . decodeHex =<< o .: "inputscript") - <*> o .: "sequence" - -instance ToJSON TxIn where - toJSON (TxIn o s q) = - object - [ "prevoutput" .= o - , "inputscript" .= encodeHex s - , "sequence" .= q - ] - toEncoding (TxIn o s q) = - pairs - ( "prevoutput" .= o - <> "inputscript" .= encodeHex s - <> "sequence" .= q - ) -- | Data type representing a transaction output. data TxOut = TxOut @@ -349,36 +284,19 @@ data TxOut = TxOut } deriving (Eq, Show, Read, Ord, Generic, Hashable, NFData) + instance Serial TxOut where deserialize = do val <- getWord64le VarInt len <- deserialize TxOut val <$> getByteString (fromIntegral len) + serialize (TxOut o s) = do putWord64le o putVarInt $ B.length s putByteString s -instance Binary TxOut where - put = serialize - get = deserialize - -instance Serialize TxOut where - put = serialize - get = deserialize - -instance FromJSON TxOut where - parseJSON = - withObject "TxOut" $ \o -> - TxOut <$> o .: "value" - <*> (maybe mzero return . decodeHex =<< o .: "outputscript") - -instance ToJSON TxOut where - toJSON (TxOut o s) = - object ["value" .= o, "outputscript" .= encodeHex s] - toEncoding (TxOut o s) = - pairs ("value" .= o <> "outputscript" .= encodeHex s) -- | The 'OutPoint' refers to a transaction output being spent. data OutPoint = OutPoint @@ -389,28 +307,13 @@ data OutPoint = OutPoint } deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + instance Serial OutPoint where deserialize = do (h, i) <- liftM2 (,) deserialize getWord32le return $ OutPoint h i serialize (OutPoint h i) = serialize h >> putWord32le i -instance Binary OutPoint where - put = serialize - get = deserialize - -instance Serialize OutPoint where - put = serialize - get = deserialize - -instance FromJSON OutPoint where - parseJSON = - withObject "OutPoint" $ \o -> - OutPoint <$> o .: "txid" <*> o .: "index" - -instance ToJSON OutPoint where - toJSON (OutPoint h i) = object ["txid" .= h, "index" .= i] - toEncoding (OutPoint h i) = pairs ("txid" .= h <> "index" .= i) -- | Outpoint used in coinbase transactions. nullOutPoint :: OutPoint diff --git a/src/Haskoin/Transaction/Partial.hs b/src/Haskoin/Transaction/Partial.hs index 0bf7b0ed..e8fe5738 100644 --- a/src/Haskoin/Transaction/Partial.hs +++ b/src/Haskoin/Transaction/Partial.hs @@ -1,19 +1,17 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{- | -Module : Haskoin.Transaction.Partial -Copyright : No rights reserved -License : MIT -Maintainer : matt@bitnomial.com -Stability : experimental -Portability : POSIX - -Code related to PSBT parsing and serialization. --} +-- | +--Module : Haskoin.Transaction.Partial +--Copyright : No rights reserved +--License : MIT +--Maintainer : matt@bitnomial.com +--Stability : experimental +--Portability : POSIX +-- +--Code related to PSBT parsing and serialization. module Haskoin.Transaction.Partial ( -- * Partially-Signed Transactions PartiallySignedTransaction (..), @@ -54,8 +52,6 @@ import qualified Data.HashMap.Strict as HashMap import Data.Hashable (Hashable) import Data.List (foldl') import Data.Maybe (fromMaybe, isJust) -import Data.Serialize (Get, Put, Serialize) -import qualified Data.Serialize as S import GHC.Generics (Generic) import GHC.Word (Word32, Word8) import Haskoin.Address (Address (..), pubKeyAddr) @@ -112,14 +108,14 @@ import Haskoin.Transaction.Common ( import Haskoin.Transaction.Segwit (isSegwit) import Haskoin.Util (eitherToMaybe) -{- | PSBT data type as specified in - [BIP-174](https://github.com/bitcoin/bips/blob/master/bip-0174.mediawiki). - This contains an unsigned transaction, inputs and outputs, and unspecified - extra data. There is one input per input in the unsigned transaction, and one - output per output in the unsigned transaction. The inputs and outputs in the - 'PartiallySignedTransaction' line up by index with the inputs and outputs in - the unsigned transaction. --} + +-- | PSBT data type as specified in +-- [BIP-174](https://github.com/bitcoin/bips/blob/master/bip-0174.mediawiki). +-- This contains an unsigned transaction, inputs and outputs, and unspecified +-- extra data. There is one input per input in the unsigned transaction, and one +-- output per output in the unsigned transaction. The inputs and outputs in the +-- 'PartiallySignedTransaction' line up by index with the inputs and outputs in +-- the unsigned transaction. data PartiallySignedTransaction = PartiallySignedTransaction { unsignedTransaction :: Tx , globalUnknown :: UnknownMap @@ -128,11 +124,12 @@ data PartiallySignedTransaction = PartiallySignedTransaction } deriving (Show, Eq, Generic) + instance NFData PartiallySignedTransaction -{- | Inputs contain all of the data needed to sign a transaction and all of the - resulting signature data after signing. --} + +-- | Inputs contain all of the data needed to sign a transaction and all of the +-- resulting signature data after signing. data Input = Input { nonWitnessUtxo :: Maybe Tx , witnessUtxo :: Maybe TxOut @@ -147,8 +144,10 @@ data Input = Input } deriving (Show, Eq, Generic) + instance NFData Input + -- | Outputs can contain information needed to spend the output at a later date. data Output = Output { outputRedeemScript :: Maybe Script @@ -158,17 +157,20 @@ data Output = Output } deriving (Show, Eq, Generic) + instance NFData Output -{- | A map of raw PSBT keys to byte strings for extra data. The 'keyType' field - cannot overlap with any of the reserved 'keyType' fields specified in the - PSBT specification. --} + +-- | A map of raw PSBT keys to byte strings for extra data. The 'keyType' field +-- cannot overlap with any of the reserved 'keyType' fields specified in the +-- PSBT specification. newtype UnknownMap = UnknownMap {unknownMap :: HashMap Key ByteString} deriving (Show, Eq, Semigroup, Monoid, Generic) + instance NFData UnknownMap + -- | Raw keys for the map type used in PSBTs. data Key = Key { keyType :: Word8 @@ -176,13 +178,15 @@ data Key = Key } deriving (Show, Eq, Generic) + instance NFData Key + instance Hashable Key -{- | Take two 'PartiallySignedTransaction's and merge them. The - 'unsignedTransaction' field in both must be the same. --} + +-- | Take two 'PartiallySignedTransaction's and merge them. The +-- 'unsignedTransaction' field in both must be the same. merge :: PartiallySignedTransaction -> PartiallySignedTransaction -> @@ -197,14 +201,15 @@ merge psbt1 psbt2 } merge _ _ = Nothing -{- | A version of 'merge' for a collection of PSBTs. - @since 0.21.0 --} +-- | A version of 'merge' for a collection of PSBTs. +-- +-- @since 0.21.0 mergeMany :: [PartiallySignedTransaction] -> Maybe PartiallySignedTransaction mergeMany (psbt : psbts) = foldM merge psbt psbts mergeMany _ = Nothing + mergeInput :: Input -> Input -> Input mergeInput a b = Input @@ -231,8 +236,9 @@ mergeInput a b = , finalScriptWitness = finalScriptWitness a <|> finalScriptWitness b } - where - witUtx = witnessUtxo a <|> witnessUtxo b + where + witUtx = witnessUtxo a <|> witnessUtxo b + mergeOutput :: Output -> Output -> Output mergeOutput a b = @@ -247,12 +253,12 @@ mergeOutput a b = outputUnknown a <> outputUnknown b } -{- | A abstraction which covers varying key configurations. Use the 'Semigroup' - instance to create signers for sets of keys: `signerA <> signerB` can sign - anything for which `signerA` or `signerB` could sign. - @since 0.21@ --} +-- | A abstraction which covers varying key configurations. Use the 'Semigroup' +-- instance to create signers for sets of keys: `signerA <> signerB` can sign +-- anything for which `signerA` or `signerB` could sign. +-- +-- @since 0.21@ newtype PsbtSigner = PsbtSigner { unPsbtSigner :: PubKeyI -> @@ -260,77 +266,79 @@ newtype PsbtSigner = PsbtSigner Maybe SecKey } + instance Semigroup PsbtSigner where PsbtSigner signer1 <> PsbtSigner signer2 = PsbtSigner $ \pubKey origin -> signer1 pubKey origin <|> signer2 pubKey origin + instance Monoid PsbtSigner where mempty = PsbtSigner $ \_ _ -> Nothing -{- | Fetch the secret key for the given 'PubKeyI' if possible. - @since 0.21@ --} +-- | Fetch the secret key for the given 'PubKeyI' if possible. +-- +-- @since 0.21@ getSignerKey :: PsbtSigner -> PubKeyI -> Maybe (Fingerprint, DerivPath) -> Maybe SecKey getSignerKey = unPsbtSigner -{- | This signer can sign for one key. - @since 0.21@ --} +-- | This signer can sign for one key. +-- +-- @since 0.21@ secKeySigner :: SecKey -> PsbtSigner secKeySigner theSecKey = PsbtSigner signer - where - signer requiredKey _ - | pubKeyPoint requiredKey == derivePubKey theSecKey = Just theSecKey - | otherwise = Nothing + where + signer requiredKey _ + | pubKeyPoint requiredKey == derivePubKey theSecKey = Just theSecKey + | otherwise = Nothing -{- | This signer can sign with any child key, provided that derivation information is present. - @since 0.21@ --} +-- | This signer can sign with any child key, provided that derivation information is present. +-- +-- @since 0.21@ xPrvSigner :: XPrvKey -> -- | Origin data, if the input key is explicitly a child key Maybe (Fingerprint, DerivPath) -> PsbtSigner xPrvSigner xprv origin = PsbtSigner signer - where - signer pubKey (Just hdData) - | result@(Just theSecKey) <- maybe noOrigin onOrigin origin hdData - , pubKeyPoint pubKey == derivePubKey theSecKey = - result - signer _ _ = Nothing - - noOrigin (fp, path) - | thisFP == fp = Just $ deriveSecKey path - | otherwise = Nothing - - onOrigin (originFP, originPath) (fp, path) - | thisFP == fp = Just $ deriveSecKey path - | originFP == fp = - deriveSecKey <$> adjustPath (pathToList originPath) (pathToList path) - | otherwise = Nothing - - deriveSecKey path = xPrvKey $ derivePath path xprv - - thisFP = xPubFP $ deriveXPubKey xprv - - -- The origin path should be a prefix of the target path if we match the - -- origin fingerprint. We need to remove this prefix. - adjustPath :: [KeyIndex] -> [KeyIndex] -> Maybe DerivPath - adjustPath (originIx : originTail) (thisIx : thisTail) - | originIx == thisIx = adjustPath originTail thisTail - | otherwise = Nothing - adjustPath [] thePath = Just $ listToPath thePath - adjustPath _ _ = Nothing - -{- | Update a PSBT with signatures when possible. This function uses - 'inputHDKeypaths' in order to calculate secret keys. - - @since 0.21@ --} + where + signer pubKey (Just hdData) + | result@(Just theSecKey) <- maybe noOrigin onOrigin origin hdData + , pubKeyPoint pubKey == derivePubKey theSecKey = + result + signer _ _ = Nothing + + noOrigin (fp, path) + | thisFP == fp = Just $ deriveSecKey path + | otherwise = Nothing + + onOrigin (originFP, originPath) (fp, path) + | thisFP == fp = Just $ deriveSecKey path + | originFP == fp = + deriveSecKey <$> adjustPath (pathToList originPath) (pathToList path) + | otherwise = Nothing + + deriveSecKey path = xPrvKey $ derivePath path xprv + + thisFP = xPubFP $ deriveXPubKey xprv + + -- The origin path should be a prefix of the target path if we match the + -- origin fingerprint. We need to remove this prefix. + adjustPath :: [KeyIndex] -> [KeyIndex] -> Maybe DerivPath + adjustPath (originIx : originTail) (thisIx : thisTail) + | originIx == thisIx = adjustPath originTail thisTail + | otherwise = Nothing + adjustPath [] thePath = Just $ listToPath thePath + adjustPath _ _ = Nothing + + +-- | Update a PSBT with signatures when possible. This function uses +-- 'inputHDKeypaths' in order to calculate secret keys. +-- +-- @since 0.21@ signPSBT :: Network -> PsbtSigner -> @@ -340,14 +348,16 @@ signPSBT net signer psbt = psbt { inputs = addSigsForInput net signer tx <$> zip [0 :: Int ..] (inputs psbt) } - where - tx = unsignedTransaction psbt + where + tx = unsignedTransaction psbt + addSigsForInput :: Network -> PsbtSigner -> Tx -> (Int, Input) -> Input addSigsForInput net signer tx (ix, input) = maybe input (onPrevTxOut net signer tx ix input) $ Left <$> nonWitnessUtxo input <|> Right <$> witnessUtxo input + onPrevTxOut :: Network -> PsbtSigner -> @@ -360,43 +370,44 @@ onPrevTxOut net signer tx ix input prevTxData = input { partialSigs = newSigs <> partialSigs input } - where - newSigs = HM.mapWithKey sigForInput sigKeys - sigForInput thePubKey theSecKey = - encodeTxSig . makeSignature net tx ix theSigInput $ - SecKeyI theSecKey (pubKeyCompressed thePubKey) - - theSigInput = - SigInput - { -- Must be the segwit input script for segwit spends (even nested) - sigInputScript = fromMaybe theInputScript segwitInput - , sigInputValue = outValue prevTxOut - , sigInputOP = thePrevOutPoint - , sigInputSH = fromMaybe sigHashAll $ sigHashType input - , -- Must be the witness script for segwit spends (even nested) - sigInputRedeem = theWitnessScript <|> theRedeemScript - } + where + newSigs = HM.mapWithKey sigForInput sigKeys + sigForInput thePubKey theSecKey = + encodeTxSig . makeSignature net tx ix theSigInput $ + SecKeyI theSecKey (pubKeyCompressed thePubKey) + + theSigInput = + SigInput + { -- Must be the segwit input script for segwit spends (even nested) + sigInputScript = fromMaybe theInputScript segwitInput + , sigInputValue = outValue prevTxOut + , sigInputOP = thePrevOutPoint + , sigInputSH = fromMaybe sigHashAll $ sigHashType input + , -- Must be the witness script for segwit spends (even nested) + sigInputRedeem = theWitnessScript <|> theRedeemScript + } - prevTxOut = either ((!! (fromIntegral . outPointIndex) thePrevOutPoint) . txOut) id prevTxData - thePrevOutPoint = prevOutput $ txIn tx !! ix + prevTxOut = either ((!! (fromIntegral . outPointIndex) thePrevOutPoint) . txOut) id prevTxData + thePrevOutPoint = prevOutput $ txIn tx !! ix - segwitInput = justWhen isSegwit theInputScript <|> (justWhen isSegwit =<< theRedeemScript) + segwitInput = justWhen isSegwit theInputScript <|> (justWhen isSegwit =<< theRedeemScript) - theInputScript = fromRight inputScriptErr $ (decodeOutputBS . scriptOutput) prevTxOut - inputScriptErr = error "addSigsForInput: Unable to decode input script" + theInputScript = fromRight inputScriptErr $ (decodeOutputBS . scriptOutput) prevTxOut + inputScriptErr = error "addSigsForInput: Unable to decode input script" - theRedeemScript = case decodeOutput <$> inputRedeemScript input of - Just (Right script) -> Just script - Just Left{} -> error "addSigsForInput: Unable to decode redeem script" - _ -> Nothing + theRedeemScript = case decodeOutput <$> inputRedeemScript input of + Just (Right script) -> Just script + Just Left{} -> error "addSigsForInput: Unable to decode redeem script" + _ -> Nothing - theWitnessScript = case decodeOutput <$> inputWitnessScript input of - Just (Right script) -> Just script - Just Left{} -> error "addSigsForInput: Unable to decode witness script" - _ -> Nothing + theWitnessScript = case decodeOutput <$> inputWitnessScript input of + Just (Right script) -> Just script + Just Left{} -> error "addSigsForInput: Unable to decode witness script" + _ -> Nothing + + sigKeys = HM.mapMaybeWithKey getSignerKey $ inputHDKeypaths input + getSignerKey pubKey (fp, ixs) = unPsbtSigner signer pubKey $ Just (fp, listToPath ixs) - sigKeys = HM.mapMaybeWithKey getSignerKey $ inputHDKeypaths input - getSignerKey pubKey (fp, ixs) = unPsbtSigner signer pubKey $ Just (fp, listToPath ixs) -- | Take partial signatures from all of the 'Input's and finalize the signature. complete :: @@ -409,42 +420,43 @@ complete psbt = (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) = pruneInputFields $ completeSig input script - - -- If we have final scripts, we can get rid of data for signing following - -- the Bitcoin Core implementation. - pruneInputFields input - | isJust (finalScriptSig input) || isJust (finalScriptWitness input) = - input - { partialSigs = mempty - , inputHDKeypaths = mempty - , inputRedeemScript = Nothing - , inputWitnessScript = Nothing - , sigHashType = Nothing - } - | otherwise = input + 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) = pruneInputFields $ completeSig input script + + -- If we have final scripts, we can get rid of data for signing following + -- the Bitcoin Core implementation. + pruneInputFields input + | isJust (finalScriptSig input) || isJust (finalScriptWitness input) = + input + { partialSigs = mempty + , inputHDKeypaths = mempty + , inputRedeemScript = Nothing + , inputWitnessScript = Nothing + , sigHashType = Nothing + } + | otherwise = input + + indexed :: [a] -> [(Word32, a)] + indexed = zip [0 ..] - indexed :: [a] -> [(Word32, a)] - indexed = zip [0 ..] completeSig :: Input -> ScriptOutput -> Input completeSig input (PayPK k) = @@ -467,24 +479,24 @@ completeSig input (PayPKHash h) completeSig input (PayMulSig pubKeys m) | length sigs >= m = input{finalScriptSig = Just finalSig} - where - sigs = collectSigs m pubKeys input - finalSig = Script $ OP_0 : map opPushData sigs + where + sigs = collectSigs m pubKeys input + finalSig = Script $ OP_0 : map opPushData sigs completeSig input (PayScriptHash h) | Just rdmScript <- inputRedeemScript input , PayScriptHash h == toP2SH rdmScript , Right decodedScript <- decodeOutput rdmScript , not (isPayScriptHash decodedScript) = pushScript rdmScript $ completeSig input decodedScript - where - pushScript rdmScript updatedInput = - updatedInput - { finalScriptSig = - Just $ - fromMaybe (Script mempty) (finalScriptSig updatedInput) - `scriptAppend` serializedRedeemScript rdmScript - } - scriptAppend (Script script1) (Script script2) = Script $ script1 <> script2 + where + pushScript rdmScript updatedInput = + updatedInput + { finalScriptSig = + Just $ + fromMaybe (Script mempty) (finalScriptSig updatedInput) + `scriptAppend` serializedRedeemScript rdmScript + } + scriptAppend (Script script1) (Script script2) = Script $ script1 <> script2 completeSig input (PayWitnessPKHash h) | [(k, sig)] <- HashMap.toList (partialSigs input) , PubKeyAddress h == pubKeyAddr k = @@ -496,54 +508,57 @@ completeSig input (PayWitnessScriptHash h) completeWitnessSig input decodedScript completeSig input _ = input + serializedRedeemScript :: Script -> Script serializedRedeemScript = Script . pure . opPushData . runPutS . serialize + completeWitnessSig :: Input -> ScriptOutput -> Input completeWitnessSig input script@(PayMulSig pubKeys m) | length sigs >= m = input{finalScriptWitness = Just finalWit} - where - sigs = collectSigs m pubKeys input - finalWit = mempty : sigs <> [encodeOutputBS script] + where + sigs = collectSigs m pubKeys 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. --} + 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) = - ( txInput{scriptInput = maybe mempty (runPutS . serialize) $ finalScriptSig psbtInput} : ins - , fromMaybe [] (finalScriptWitness psbtInput) : witData - ) - -{- | Take an unsigned transaction and produce an empty - 'PartiallySignedTransaction' --} + 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) = + ( txInput{scriptInput = maybe mempty (runPutS . serialize) $ finalScriptSig psbtInput} : ins + , fromMaybe [] (finalScriptWitness psbtInput) : witData + ) + + +-- | Take an unsigned transaction and produce an empty +-- 'PartiallySignedTransaction' emptyPSBT :: Tx -> PartiallySignedTransaction emptyPSBT tx = PartiallySignedTransaction @@ -553,6 +568,7 @@ emptyPSBT tx = , outputs = replicate (length (txOut tx)) emptyOutput } + emptyInput :: Input emptyInput = Input @@ -567,222 +583,10 @@ emptyInput = Nothing (UnknownMap HashMap.empty) + emptyOutput :: Output emptyOutput = Output Nothing Nothing HashMap.empty (UnknownMap HashMap.empty) -instance Serialize PartiallySignedTransaction where - get = do - magic <- S.getBytes 4 - guard $ magic == "psbt" - headerSep <- S.getWord8 - guard $ headerSep == 0xff - - keySize <- S.getWord8 - guard $ keySize == 1 - globalUnsignedTxType <- S.getWord8 - guard $ globalUnsignedTxType == 0x00 - unsignedTransaction <- getSizedBytes deserialize - guard $ all (B.null . scriptInput) (txIn unsignedTransaction) - guard $ null (txWitness unsignedTransaction) - - globalUnknown <- S.get - globalEnd <- S.getWord8 - guard $ globalEnd == 0x00 - - inputs <- - replicateM - (length (txIn unsignedTransaction)) - S.get - outputs <- - replicateM - (length (txOut unsignedTransaction)) - S.get - - return - PartiallySignedTransaction - { unsignedTransaction - , globalUnknown - , inputs - , outputs - } - - put - PartiallySignedTransaction - { unsignedTransaction - , globalUnknown - , inputs - , outputs - } = do - S.putByteString "psbt" - S.putWord8 0xff -- Header separator - S.putWord8 0x01 -- Key size - S.putWord8 0x00 -- Unsigned Transaction type - putSizedBytes $ serialize unsignedTransaction - S.put globalUnknown - S.putWord8 0x00 -- Global end - mapM_ S.put inputs - mapM_ S.put outputs - -instance Serialize Key where - get = do - VarInt keySize <- deserialize - guard $ keySize > 0 - t <- S.getWord8 - k <- S.getBytes (fromIntegral keySize - 1) - return (Key t k) - - put (Key t k) = do - putVarInt $ 1 + B.length k - S.putWord8 t - S.putByteString k - -instance Serialize UnknownMap where - get = go HashMap.empty - where - getItem m = do - k <- S.get - VarString v <- deserialize - go $ HashMap.insert k v m - go m = do - isEnd <- S.lookAhead S.getWord8 - if isEnd == 0x00 - then return (UnknownMap m) - else getItem m - - put (UnknownMap m) = - void $ - HashMap.traverseWithKey - (\k v -> S.put k >> serialize (VarString v)) - m - -instance Serialize Input where - get = - getMap getInputItem setInputUnknown emptyInput - 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 . serialize) - nonWitnessUtxo - whenJust - (putKeyValue InWitnessUtxo . serialize) - witnessUtxo - putPartialSig partialSigs - whenJust - putSigHash - sigHashType - whenJust - (putKeyValue InRedeemScript . serialize) - inputRedeemScript - whenJust - (putKeyValue InWitnessScript . serialize) - inputWitnessScript - putHDPath InBIP32Derivation inputHDKeypaths - whenJust - (putKeyValue InFinalScriptSig . serialize) - finalScriptSig - whenJust - (putKeyValue InFinalScriptWitness . putFinalScriptWitness) - finalScriptWitness - S.put inputUnknown - S.putWord8 0x00 - where - putPartialSig = - putPubKeyMap serialize InPartialSig . fmap VarString - putSigHash sigHash = do - putKey InSigHashType - S.putWord8 0x04 - S.putWord32le (fromIntegral sigHash) - putFinalScriptWitness witnessStack = do - S.put $ (VarInt . fromIntegral . length) witnessStack - mapM_ (serialize . VarString) witnessStack - -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 . serialize) - outputRedeemScript - whenJust - (putKeyValue OutWitnessScript . serialize) - outputWitnessScript - putHDPath - OutBIP32Derivation - outputHDKeypaths - S.put outputUnknown - S.putWord8 0x00 - -putSizedBytes :: Put -> Put -putSizedBytes f = do - putVarInt (B.length bs) - S.putByteString bs - where - bs = S.runPut f - -getSizedBytes :: Get a -> Get a -getSizedBytes = - S.getNested - (fromIntegral . getVarInt <$> deserialize) - -putKeyValue :: Enum t => t -> Put -> Put -putKeyValue t v = do - putKey t - putSizedBytes v - -putKey :: Enum t => t -> Put -putKey t = do - putVarInt (1 :: Word8) - S.putWord8 (enumWord8 t) - -getMap :: - (Bounded t, Enum t) => - (Int -> a -> t -> Get a) -> - ((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 <- S.getBytes (fromIntegral keySize - 1) - VarString v <- deserialize - go $ setUnknown (HashMap.insert (Key t k) v) m - go m = do - keySize <- getVarInt <$> deserialize - if keySize == 0 - then return m - else getItem keySize m . word8Enum =<< S.getWord8 data InputType = InNonWitnessUtxo @@ -796,130 +600,39 @@ data InputType | InFinalScriptWitness deriving (Show, Eq, Enum, Bounded, Generic) + instance NFData InputType + data OutputType = OutRedeemScript | OutWitnessScript | OutBIP32Derivation deriving (Show, Eq, Enum, Bounded, Generic) + instance NFData OutputType -getInputItem :: Int -> Input -> InputType -> Get Input -getInputItem 0 input@Input{nonWitnessUtxo = Nothing} InNonWitnessUtxo = do - utxo <- getSizedBytes deserialize - return input{nonWitnessUtxo = Just utxo} -getInputItem 0 input@Input{witnessUtxo = Nothing} InWitnessUtxo = do - utxo <- getSizedBytes deserialize - return input{witnessUtxo = Just utxo} -getInputItem keySize input InPartialSig = do - (k, v) <- getPartialSig - return - input - { partialSigs = HashMap.insert k v (partialSigs input) - } - where - getPartialSig = - (,) - <$> S.isolate keySize deserialize - <*> (getVarString <$> deserialize) -getInputItem 0 input@Input{sigHashType = Nothing} InSigHashType = do - VarInt size <- deserialize - guard $ size == 0x04 - sigHash <- fromIntegral <$> S.getWord32le - return $ input{sigHashType = Just sigHash} -getInputItem 0 input@Input{inputRedeemScript = Nothing} InRedeemScript = do - script <- getSizedBytes deserialize - return $ input{inputRedeemScript = Just script} -getInputItem 0 input@Input{inputWitnessScript = Nothing} InWitnessScript = do - script <- getSizedBytes deserialize - 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 deserialize - return $ input{finalScriptSig = Just script} -getInputItem 0 input@Input{finalScriptWitness = Nothing} InFinalScriptWitness = do - scripts <- map getVarString <$> getVarIntList - return $ input{finalScriptWitness = Just scripts} - where - getVarIntList = getSizedBytes $ do - VarInt n <- deserialize -- Item count - replicateM (fromIntegral n) deserialize -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 deserialize - return $ output{outputRedeemScript = Just script} -getOutputItem 0 output@Output{outputWitnessScript = Nothing} OutWitnessScript = do - script <- getSizedBytes deserialize - 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 = - (,) - <$> S.isolate keySize deserialize - <*> (unPSBTHDPath <$> S.get) - -putHDPath :: Enum t => t -> HashMap PubKeyI (Fingerprint, [KeyIndex]) -> Put -putHDPath t = putPubKeyMap S.put t . fmap PSBTHDPath newtype PSBTHDPath = PSBTHDPath {unPSBTHDPath :: (Fingerprint, [KeyIndex])} deriving (Show, Eq, Generic) + instance NFData PSBTHDPath -instance Serialize PSBTHDPath where - get = do - VarInt valueSize <- deserialize - guard $ valueSize `mod` 4 == 0 - let numIndices = (fromIntegral valueSize - 4) `div` 4 - PSBTHDPath - <$> S.isolate - (fromIntegral valueSize) - ((,) <$> S.get <*> getKeyIndexList numIndices) - where - getKeyIndexList n = replicateM n S.getWord32le - - put (PSBTHDPath (fp, kis)) = do - putVarInt (B.length bs) - S.putByteString bs - where - bs = S.runPut $ S.put fp >> mapM_ S.putWord32le kis - -putPubKeyMap :: Enum t => (a -> Put) -> t -> HashMap PubKeyI a -> Put -putPubKeyMap f t = - void . HashMap.traverseWithKey putItem - where - putItem k v = do - S.put $ Key (enumWord8 t) (runPutS (serialize k)) - f v enumWord8 :: Enum a => a -> Word8 enumWord8 = fromIntegral . fromEnum + word8Enum :: forall a. (Bounded a, Enum a) => Word8 -> Either Word8 a word8Enum n | n <= enumWord8 (maxBound :: a) = Right . toEnum $ fromIntegral n word8Enum n = Left n + whenJust :: Monad m => (a -> m ()) -> Maybe a -> m () whenJust = maybe (return ()) + justWhen :: (a -> Bool) -> a -> Maybe a justWhen test x = if test x then Just x else Nothing diff --git a/src/Haskoin/Transaction/Taproot.hs b/src/Haskoin/Transaction/Taproot.hs index b6332f92..664fd80e 100644 --- a/src/Haskoin/Transaction/Taproot.hs +++ b/src/Haskoin/Transaction/Taproot.hs @@ -3,17 +3,16 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} -{- | -Module : Haskoin.Transaction.Taproot -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -This module provides support for reperesenting full taproot outputs and parsing -taproot witnesses. For reference see BIPS 340, 341, and 342. --} +-- | +--Module : Haskoin.Transaction.Taproot +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX +-- +--This module provides support for reperesenting full taproot outputs and parsing +--taproot witnesses. For reference see BIPS 340, 341, and 342. module Haskoin.Transaction.Taproot ( XOnlyPubKey (..), TapLeafVersion, @@ -40,20 +39,17 @@ import Crypto.Hash ( hashUpdate, hashUpdates, ) -import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), withText) -import Data.Binary (Binary (..)) import Data.Bits ((.&.), (.|.)) import Data.Bool (bool) import qualified Data.ByteArray as BA import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import Data.Bytes.Get (getBytes, runGetS) +import Data.Bytes.Get (getByteString, getBytes, getWord8, runGetS) import Data.Bytes.Put (putByteString, runPutS) import Data.Bytes.Serial (Serial (..), deserialize, serialize) import Data.Bytes.VarInt (VarInt (VarInt)) import Data.Foldable (foldl') import Data.Maybe (fromMaybe, mapMaybe) -import Data.Serialize (Serialize, get, getByteString, getWord8, put) import Data.Word (Word8) import Haskoin.Crypto (PubKey, initTaggedHash, tweak, tweakAddPubKey) import Haskoin.Keys.Common (PubKeyI (PubKeyI), pubKeyPoint) @@ -62,18 +58,20 @@ import Haskoin.Script.Standard (ScriptOutput (PayWitness)) import Haskoin.Transaction.Common (WitnessStack) import Haskoin.Util (decodeHex, eitherToMaybe, encodeHex) -{- | An x-only pubkey corresponds to the keys @(x,y)@ and @(x, -y)@. The -equality test only checks the x-coordinate. An x-only pubkey serializes to 32 -bytes. -@since 0.21.0 --} +-- | An x-only pubkey corresponds to the keys @(x,y)@ and @(x, -y)@. The +--equality test only checks the x-coordinate. An x-only pubkey serializes to 32 +--bytes. +-- +-- @since 0.21.0 newtype XOnlyPubKey = XOnlyPubKey {xOnlyPubKey :: PubKey} deriving (Show) + instance Eq XOnlyPubKey where k1 == k2 = runPutS (serialize k1) == runPutS (serialize k2) + instance Serial XOnlyPubKey where serialize (XOnlyPubKey pk) = putByteString @@ -87,61 +85,43 @@ instance Serial XOnlyPubKey where . BS.cons 0x02 =<< getBytes 32 -instance Serialize XOnlyPubKey where - put = serialize - get = deserialize - -instance Binary XOnlyPubKey where - put = serialize - get = deserialize - --- | Hex encoding -instance FromJSON XOnlyPubKey where - parseJSON = - withText "XOnlyPubKey" $ - either fail pure - . (runGetS deserialize <=< maybe (Left "Unable to decode hex") Right . decodeHex) - --- | Hex encoding -instance ToJSON XOnlyPubKey where - toJSON = toJSON . encodeHex . runPutS . serialize -- | @since 0.21.0 type TapLeafVersion = Word8 -{- | Merklized Abstract Syntax Tree. This type can represent trees where only a -subset of the leaves are known. Note that the tree is invariant under swapping -branches at an internal node. -@since 0.21.0 --} +-- | Merklized Abstract Syntax Tree. This type can represent trees where only a +--subset of the leaves are known. Note that the tree is invariant under swapping +--branches at an internal node. +-- +-- @since 0.21.0 data MAST = MASTBranch MAST MAST | MASTLeaf TapLeafVersion Script | MASTCommitment (Digest SHA256) deriving (Show) -{- | Get the inclusion proofs for the leaves in the tree. The proof is ordered -leaf-to-root. -@since 0.21.0 --} +-- | Get the inclusion proofs for the leaves in the tree. The proof is ordered +--leaf-to-root. +-- +-- @since 0.21.0 getMerkleProofs :: MAST -> [(TapLeafVersion, Script, [Digest SHA256])] getMerkleProofs = getProofs mempty - where - getProofs proof = \case - MASTBranch branchL branchR -> - (updateProof proof (mastCommitment branchR) <$> getMerkleProofs branchL) - <> (updateProof proof (mastCommitment branchL) <$> getMerkleProofs branchR) - MASTLeaf v s -> [(v, s, proof)] - MASTCommitment{} -> mempty - updateProof proofInit branchCommitment (v, s, proofTail) = - (v, s, reverse $ proofInit <> (branchCommitment : proofTail)) - -{- | Calculate the root hash for this tree. - -@since 0.21.0 --} + where + getProofs proof = \case + MASTBranch branchL branchR -> + (updateProof proof (mastCommitment branchR) <$> getMerkleProofs branchL) + <> (updateProof proof (mastCommitment branchL) <$> getMerkleProofs branchR) + MASTLeaf v s -> [(v, s, proof)] + MASTCommitment{} -> mempty + updateProof proofInit branchCommitment (v, s, proofTail) = + (v, s, reverse $ proofInit <> (branchCommitment : proofTail)) + + +-- | Calculate the root hash for this tree. +-- +-- @since 0.21.0 mastCommitment :: MAST -> Digest SHA256 mastCommitment = \case MASTBranch leftBranch rightBranch -> @@ -149,6 +129,7 @@ mastCommitment = \case MASTLeaf leafVersion leafScript -> leafHash leafVersion leafScript MASTCommitment theCommitment -> theCommitment + hashBranch :: Digest SHA256 -> Digest SHA256 -> Digest SHA256 hashBranch hashA hashB = hashFinalize $ @@ -158,6 +139,7 @@ hashBranch hashA hashB = , max hashA hashB ] + leafHash :: TapLeafVersion -> Script -> Digest SHA256 leafHash leafVersion leafScript = hashFinalize @@ -167,26 +149,28 @@ leafHash leafVersion leafScript = serialize leafVersion serialize $ VarInt (BS.length scriptBytes) putByteString scriptBytes - where - scriptBytes = runPutS $ serialize leafScript + where + scriptBytes = runPutS $ serialize leafScript -{- | Representation of a full taproot output. -@since 0.21.0 --} +-- | Representation of a full taproot output. +-- +-- @since 0.21.0 data TaprootOutput = TaprootOutput { taprootInternalKey :: PubKey , taprootMAST :: Maybe MAST } deriving (Show) + -- | @since 0.21.0 taprootOutputKey :: TaprootOutput -> PubKey taprootOutputKey TaprootOutput{taprootInternalKey, taprootMAST} = fromMaybe keyFail $ tweak commitment >>= tweakAddPubKey taprootInternalKey - where - commitment = taprootCommitment taprootInternalKey $ mastCommitment <$> taprootMAST - keyFail = error "haskoin-core taprootOutputKey: key derivation failed" + where + commitment = taprootCommitment taprootInternalKey $ mastCommitment <$> taprootMAST + keyFail = error "haskoin-core taprootOutputKey: key derivation failed" + taprootCommitment :: PubKey -> Maybe (Digest SHA256) -> ByteString taprootCommitment internalKey merkleRoot = @@ -194,26 +178,27 @@ taprootCommitment internalKey merkleRoot = . maybe id (flip hashUpdate) merkleRoot . (`hashUpdate` keyBytes) $ initTaggedHash "TapTweak" - where - keyBytes = runPutS . serialize $ XOnlyPubKey internalKey + where + keyBytes = runPutS . serialize $ XOnlyPubKey internalKey -{- | Generate the output script for a taproot output -@since 0.21.0 --} +-- | Generate the output script for a taproot output +-- +-- @since 0.21.0 taprootScriptOutput :: TaprootOutput -> ScriptOutput taprootScriptOutput = PayWitness 0x01 . runPutS . serialize . XOnlyPubKey . taprootOutputKey -{- | Comprehension of taproot witness data -@since 0.21.0 --} +-- | Comprehension of taproot witness data +-- +-- @since 0.21.0 data TaprootWitness = -- | Signature KeyPathSpend ByteString | ScriptPathSpend ScriptPathData deriving (Eq, Show) + -- | @since 0.21.0 data ScriptPathData = ScriptPathData { scriptPathAnnex :: Maybe ByteString @@ -227,10 +212,10 @@ data ScriptPathData = ScriptPathData } deriving (Eq, Show) -{- | Try to interpret a 'WitnessStack' as taproot witness data. -@since 0.21.0 --} +-- | Try to interpret a 'WitnessStack' as taproot witness data. +-- +-- @since 0.21.0 viewTaprootWitness :: WitnessStack -> Maybe TaprootWitness viewTaprootWitness witnessStack = case reverse witnessStack of [sig] -> Just $ KeyPathSpend sig @@ -238,33 +223,33 @@ viewTaprootWitness witnessStack = case reverse witnessStack of | 0x50 : _ <- BS.unpack annexA -> parseSpendPathData (Just annexA) remainingStack remainingStack -> parseSpendPathData Nothing remainingStack - where - parseSpendPathData scriptPathAnnex = \case - scriptBytes : controlBytes : scriptPathStack -> do - scriptPathScript <- eitherToMaybe $ runGetS deserialize scriptBytes - (v, scriptPathInternalKey, scriptPathControl) <- deconstructControl controlBytes - pure . ScriptPathSpend $ - ScriptPathData - { scriptPathAnnex - , scriptPathStack - , scriptPathScript - , scriptPathExternalIsOdd = odd v - , scriptPathLeafVersion = v .&. 0xFE - , scriptPathInternalKey - , scriptPathControl - } - _ -> Nothing - deconstructControl = eitherToMaybe . runGetS deserializeControl - deserializeControl = do - v <- getWord8 - k <- xOnlyPubKey <$> deserialize - proof <- many $ getByteString 32 - pure (v, k, proof) - -{- | Transform the high-level representation of taproot witness data into a witness stack - -@since 0.21.0 --} + where + parseSpendPathData scriptPathAnnex = \case + scriptBytes : controlBytes : scriptPathStack -> do + scriptPathScript <- eitherToMaybe $ runGetS deserialize scriptBytes + (v, scriptPathInternalKey, scriptPathControl) <- deconstructControl controlBytes + pure . ScriptPathSpend $ + ScriptPathData + { scriptPathAnnex + , scriptPathStack + , scriptPathScript + , scriptPathExternalIsOdd = odd v + , scriptPathLeafVersion = v .&. 0xFE + , scriptPathInternalKey + , scriptPathControl + } + _ -> Nothing + deconstructControl = eitherToMaybe . runGetS deserializeControl + deserializeControl = do + v <- getWord8 + k <- xOnlyPubKey <$> deserialize + proof <- many $ getByteString 32 + pure (v, k, proof) + + +-- | Transform the high-level representation of taproot witness data into a witness stack +-- +-- @since 0.21.0 encodeTaprootWitness :: TaprootWitness -> WitnessStack encodeTaprootWitness = \case KeyPathSpend signature -> pure signature @@ -278,13 +263,13 @@ encodeTaprootWitness = \case ] , fromMaybe mempty $ scriptPathAnnex scriptPathData ] - where - parity = bool 0 1 . scriptPathExternalIsOdd + where + parity = bool 0 1 . scriptPathExternalIsOdd -{- | Verify that the script path spend is valid, except for script execution. -@since 0.21.0 --} +-- | Verify that the script path spend is valid, except for script execution. +-- +-- @since 0.21.0 verifyScriptPathData :: -- | Output key PubKey -> @@ -292,17 +277,18 @@ verifyScriptPathData :: Bool verifyScriptPathData outputKey scriptPathData = fromMaybe False $ do tweak commitment >>= fmap onComputedKey . tweakAddPubKey (scriptPathInternalKey scriptPathData) - where - onComputedKey computedKey = - XOnlyPubKey outputKey == XOnlyPubKey computedKey - && expectedParity == keyParity computedKey - commitment = taprootCommitment (scriptPathInternalKey scriptPathData) (Just merkleRoot) - merkleRoot = - foldl' hashBranch theLeafHash - . mapMaybe (digestFromByteString @SHA256) - $ scriptPathControl scriptPathData - theLeafHash = (leafHash <$> (.&. 0xFE) . scriptPathLeafVersion <*> scriptPathScript) scriptPathData - expectedParity = bool 0 1 $ scriptPathExternalIsOdd scriptPathData + where + onComputedKey computedKey = + XOnlyPubKey outputKey == XOnlyPubKey computedKey + && expectedParity == keyParity computedKey + commitment = taprootCommitment (scriptPathInternalKey scriptPathData) (Just merkleRoot) + merkleRoot = + foldl' hashBranch theLeafHash + . mapMaybe (digestFromByteString @SHA256) + $ scriptPathControl scriptPathData + theLeafHash = (leafHash <$> (.&. 0xFE) . scriptPathLeafVersion <*> scriptPathScript) scriptPathData + expectedParity = bool 0 1 $ scriptPathExternalIsOdd scriptPathData + keyParity :: PubKey -> Word8 keyParity key = case BS.unpack . runPutS . serialize $ PubKeyI key True of diff --git a/src/Haskoin/Util.hs b/src/Haskoin/Util.hs index 4923d7eb..2feb8808 100644 --- a/src/Haskoin/Util.hs +++ b/src/Haskoin/Util.hs @@ -2,16 +2,15 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{- | -Module : Haskoin.Util -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX - -This module defines various utility functions used across the library. --} +-- | +--Module : Haskoin.Util +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX +-- +--This module defines various utility functions used across the library. module Haskoin.Util ( -- * ByteString Helpers bsToInteger, @@ -26,7 +25,6 @@ module Haskoin.Util ( -- * Maybe & Either Helpers eitherToMaybe, maybeToEither, - liftEither, liftMaybe, -- * Other Helpers @@ -39,10 +37,6 @@ module Haskoin.Util ( snd3, lst3, - -- * JSON Utilities - dropFieldLabel, - dropSumLabels, - -- * Serialization Helpers putList, getList, @@ -63,13 +57,7 @@ module Haskoin.Util ( ) where import Control.Monad -import Control.Monad.Except (ExceptT (..), liftEither) -import Data.Aeson.Types ( - Options (..), - SumEncoding (..), - defaultOptions, - defaultTaggedObject, - ) +import Control.Monad.Trans.Except (ExceptT (..)) import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -91,13 +79,15 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as EL import Data.Word + -- ByteString helpers -- | Decode a big endian 'Integer' from a 'ByteString'. bsToInteger :: ByteString -> Integer bsToInteger = BS.foldr f 0 . BS.reverse - where - f w n = toInteger w .|. shiftL n 8 + where + f w n = toInteger w .|. shiftL n 8 + -- | Encode an 'Integer' to a 'ByteString' as big endian. integerToBS :: Integer -> ByteString @@ -105,65 +95,71 @@ 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) + where + f 0 = Nothing + f x = Just (fromInteger x :: Word8, x `shiftR` 8) + hexBuilder :: BL.ByteString -> Builder hexBuilder = lazyByteStringHex + encodeHex :: ByteString -> Text encodeHex = B16.encodeBase16 + -- | Encode as string of human-readable hex characters. encodeHexLazy :: BL.ByteString -> TL.Text encodeHexLazy = BL16.encodeBase16 + decodeHex :: Text -> Maybe ByteString decodeHex = eitherToMaybe . B16.decodeBase16 . E.encodeUtf8 + -- | Decode string of human-readable hex characters. decodeHexLazy :: TL.Text -> Maybe BL.ByteString decodeHexLazy = eitherToMaybe . BL16.decodeBase16 . EL.encodeUtf8 -{- | Obtain 'Int' bits from beginning of 'ByteString'. Resulting 'ByteString' - will be smallest required to hold that many bits, padded with zeroes to the - right. --} + +-- | Obtain 'Int' bits from beginning of 'ByteString'. Resulting 'ByteString' +-- will be smallest required to hold that many bits, padded with zeroes to the +-- right. getBits :: Int -> ByteString -> ByteString getBits b bs | r == 0 = BS.take q bs | 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 + 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. --} +-- | Transform an 'Either' value into a 'Maybe' value. 'Right' is mapped to +-- 'Just' and 'Left' is mapped to 'Nothing'. The value inside 'Left' is lost. eitherToMaybe :: Either a b -> Maybe b eitherToMaybe (Right b) = Just b eitherToMaybe _ = Nothing -{- | Transform a 'Maybe' value into an 'Either' value. 'Just' is mapped to - 'Right' and 'Nothing' is mapped to 'Left'. Default 'Left' required. --} + +-- | Transform a 'Maybe' value into an 'Either' value. 'Just' is mapped to +-- 'Right' and 'Nothing' is mapped to 'Left'. Default 'Left' required. maybeToEither :: b -> Maybe a -> Either b a maybeToEither err = maybe (Left err) Right + -- | Lift a 'Maybe' computation into the 'ExceptT' monad. liftMaybe :: Monad m => b -> Maybe a -> ExceptT b m a -liftMaybe err = liftEither . maybeToEither err +liftMaybe err = ExceptT . pure . maybeToEither err + -- Various helpers -{- | Applies a function to only one element of a list defined by its index. If - the index is out of the bounds of the list, the original list is returned. --} +-- | Applies a function to only one element of a list defined by its index. If +-- the index is out of the bounds of the list, the original list is returned. updateIndex :: -- | index of the element to change Int -> @@ -176,14 +172,14 @@ updateIndex :: 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. --} + where + (l, h : r) = splitAt i xs + + +-- | Use the list @[b]@ as a template and try to match the elements of @[a]@ +-- against it. For each element of @[b]@ return the (first) matching element of +-- @[a]@, or 'Nothing'. Output list has same size as @[b]@ and contains results +-- in same order. Elements of @[a]@ can only appear once. matchTemplate :: -- | input list [a] -> @@ -198,64 +194,49 @@ 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'. --} + +-- | 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) + where + (xacc, xbits, xout) = foldl' outer (0, 0, []) i + (yout, rem') + | pad && xbits /= 0 = + let xout' = (xacc `shiftL` (tobits - xbits)) .&. maxv : xout + in (xout', False) + | pad = (xout, False) + | xbits /= 0 = (xout, True) + | otherwise = (xout, False) + maxv = 1 `shiftL` tobits - 1 + max_acc = 1 `shiftL` (frombits + tobits - 1) - 1 + outer (acc, bits, out) it = + let acc' = ((acc `shiftL` frombits) .|. it) .&. max_acc + bits' = bits + frombits + (out', bits'') = inner acc' out bits' + in (acc', bits'', out') + inner acc out bits + | bits >= tobits = + let bits' = bits - tobits + out' = ((acc `shiftR` bits') .&. maxv) : out + in inner acc out' bits' + | otherwise = (out, bits) + -- -- Serialization helpers @@ -266,6 +247,7 @@ putInt32be n | n < 0 = putWord32be (complement (fromIntegral (abs n)) + 1) | otherwise = putWord32be (fromIntegral (abs n)) + getInt32be :: MonadGet m => m Int32 getInt32be = do n <- getWord32be @@ -273,11 +255,13 @@ getInt32be = do then return (negate (complement (fromIntegral n) + 1)) else return (fromIntegral n) + putInt64be :: MonadPut m => Int64 -> m () putInt64be n | n < 0 = putWord64be (complement (fromIntegral (abs n)) + 1) | otherwise = putWord64be (fromIntegral (abs n)) + getInt64be :: MonadGet m => m Int64 getInt64be = do n <- getWord64be @@ -285,6 +269,7 @@ getInt64be = do then return (negate (complement (fromIntegral n) + 1)) else return (fromIntegral n) + putInteger :: MonadPut m => Integer -> m () putInteger n | n >= lo && n <= hi = do @@ -296,9 +281,10 @@ putInteger n let len = (nrBits (abs n) + 7) `div` 8 putWord64be (fromIntegral len) mapM_ putWord8 (unroll (abs n)) - where - lo = fromIntegral (minBound :: Int32) - hi = fromIntegral (maxBound :: Int32) + where + lo = fromIntegral (minBound :: Int32) + hi = fromIntegral (maxBound :: Int32) + getInteger :: MonadGet m => m Integer getInteger = @@ -308,12 +294,14 @@ getInteger = sign <- getWord8 bytes <- getList getWord8 let v = roll bytes - return $! if sign == 0x01 then v else - v + return $! if sign == 0x01 then v else -v + putMaybe :: MonadPut m => (a -> m ()) -> Maybe a -> m () putMaybe f Nothing = putWord8 0x00 putMaybe f (Just x) = putWord8 0x01 >> f x + getMaybe :: MonadGet m => m a -> m (Maybe a) getMaybe f = getWord8 >>= \case @@ -321,29 +309,34 @@ getMaybe f = 0x01 -> Just <$> f _ -> fail "Not a Maybe" + putLengthBytes :: MonadPut m => ByteString -> m () putLengthBytes bs = do putWord64be (fromIntegral (BS.length bs)) putByteString bs + getLengthBytes :: MonadGet m => m ByteString getLengthBytes = do len <- fromIntegral <$> getWord64be getByteString len + -- -- Fold and unfold an Integer to and from a list of its bytes -- unroll :: (Integral a, Bits a) => a -> [Word8] unroll = unfoldr step - where - step 0 = Nothing - step i = Just (fromIntegral i, i `shiftR` 8) + where + step 0 = Nothing + step i = Just (fromIntegral i, i `shiftR` 8) + roll :: (Integral a, Bits a) => [Word8] -> a roll = foldr unstep 0 - where - unstep b a = a `shiftL` 8 .|. fromIntegral b + where + unstep b a = a `shiftL` 8 .|. fromIntegral b + nrBits :: (Ord a, Integral a) => a -> Int nrBits k = @@ -353,28 +346,35 @@ nrBits k = | mid == lo = hi | 2 ^ mid <= k = findNr mid hi | 2 ^ mid > k = findNr lo mid - where - mid = (lo + hi) `div` 2 + | otherwise = error "impossible: law of excluded middle" + where + mid = (lo + hi) `div` 2 in findNr (expMax `div` 2) expMax + -- | Read as a list of pairs of int and element. getIntMap :: MonadGet m => m Int -> m a -> m (IntMap a) getIntMap i m = IntMap.fromList <$> getList (getTwo i m) + putIntMap :: MonadPut m => (Int -> m ()) -> (a -> m ()) -> IntMap a -> m () putIntMap f g = putList (putTwo f g) . IntMap.toAscList + putTwo :: MonadPut m => (a -> m ()) -> (b -> m ()) -> (a, b) -> m () putTwo f g (x, y) = f x >> g y + getTwo :: MonadGet m => m a -> m b -> m (a, b) getTwo f g = (,) <$> f <*> g + putList :: MonadPut m => (a -> m ()) -> [a] -> m () putList f ls = do putWord64be (fromIntegral (length ls)) mapM_ f ls + getList :: MonadGet m => m a -> m [a] getList f = do l <- fromIntegral <$> getWord64be diff --git a/src/Haskoin/Util/Arbitrary/Address.hs b/src/Haskoin/Util/Arbitrary/Address.hs index 368af4e9..f7f1357a 100644 --- a/src/Haskoin/Util/Arbitrary/Address.hs +++ b/src/Haskoin/Util/Arbitrary/Address.hs @@ -1,13 +1,12 @@ {-# LANGUAGE TupleSections #-} -{- | -Module : Haskoin.Test.Address -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} +-- | +--Module : Haskoin.Test.Address +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX module Haskoin.Util.Arbitrary.Address where import qualified Data.ByteString as B @@ -18,10 +17,12 @@ import Haskoin.Util.Arbitrary.Crypto import Haskoin.Util.Arbitrary.Util import Test.QuickCheck + -- | Arbitrary pay-to-public-key-hash or pay-to-script-hash address. arbitraryAddress :: Gen Address arbitraryAddress = oneof [arbitraryPubKeyAddress, arbitraryScriptAddress] + -- | Arbitrary address including pay-to-witness arbitraryAddressAll :: Gen Address arbitraryAddressAll = @@ -33,30 +34,34 @@ arbitraryAddressAll = , arbitraryWitnessAddress ] + -- | Arbitrary valid combination of (Network, Address) arbitraryNetAddress :: Gen (Network, Address) arbitraryNetAddress = do net <- arbitraryNetwork - if net `elem` [bch, bchTest, bchTest4, bchRegTest] - then (net,) <$> arbitraryAddress - else (net,) <$> arbitraryAddressAll + (net,) <$> arbitraryAddress + -- | Arbitrary pay-to-public-key-hash address. arbitraryPubKeyAddress :: Gen Address arbitraryPubKeyAddress = PubKeyAddress <$> arbitraryHash160 + -- | Arbitrary pay-to-script-hash address. arbitraryScriptAddress :: Gen Address arbitraryScriptAddress = ScriptAddress <$> arbitraryHash160 + -- | Arbitrary pay-to-witness public key hash arbitraryWitnessPubKeyAddress :: Gen Address arbitraryWitnessPubKeyAddress = WitnessPubKeyAddress <$> arbitraryHash160 + -- | Arbitrary pay-to-witness script hash arbitraryWitnessScriptAddress :: Gen Address arbitraryWitnessScriptAddress = WitnessPubKeyAddress <$> arbitraryHash160 + arbitraryWitnessAddress :: Gen Address arbitraryWitnessAddress = do ver <- choose (1, 16) diff --git a/src/Haskoin/Util/Arbitrary/Transaction.hs b/src/Haskoin/Util/Arbitrary/Transaction.hs index a6d6e296..ab721db1 100644 --- a/src/Haskoin/Util/Arbitrary/Transaction.hs +++ b/src/Haskoin/Util/Arbitrary/Transaction.hs @@ -1,11 +1,10 @@ -{- | -Module : Haskoin.Test.Transaction -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} +-- | +--Module : Haskoin.Test.Transaction +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX module Haskoin.Util.Arbitrary.Transaction where import Control.Monad @@ -25,31 +24,34 @@ import Haskoin.Util.Arbitrary.Script import Haskoin.Util.Arbitrary.Util import Test.QuickCheck + -- | Wrapped coin value for testing. newtype TestCoin = TestCoin {getTestCoin :: Word64} deriving (Eq, Show) -instance Coin TestCoin where - coinValue = getTestCoin -- | Arbitrary transaction hash (for non-existent transaction). arbitraryTxHash :: Gen TxHash arbitraryTxHash = TxHash <$> arbitraryHash256 + -- | Arbitrary amount of Satoshi as 'Word64' (Between 1 and 21e14) arbitrarySatoshi :: Network -> Gen TestCoin arbitrarySatoshi net = TestCoin <$> choose (1, getMaxSatoshi net) + -- | Arbitrary 'OutPoint'. arbitraryOutPoint :: Gen OutPoint arbitraryOutPoint = OutPoint <$> arbitraryTxHash <*> arbitrary + -- | Arbitrary 'TxOut'. arbitraryTxOut :: Network -> Gen TxOut arbitraryTxOut net = TxOut <$> (getTestCoin <$> arbitrarySatoshi net) <*> (encodeOutputBS <$> arbitraryScriptOutput net) + -- | Arbitrary 'TxIn'. arbitraryTxIn :: Network -> Gen TxIn arbitraryTxIn net = @@ -57,18 +59,22 @@ arbitraryTxIn net = <*> (encodeInputBS <$> arbitraryScriptInput net) <*> arbitrary + -- | Arbitrary transaction. Can be regular or with witnesses. arbitraryTx :: Network -> Gen Tx arbitraryTx net = oneof [arbitraryLegacyTx net, arbitraryWitnessTx net] + -- | Arbitrary regular transaction. arbitraryLegacyTx :: Network -> Gen Tx arbitraryLegacyTx net = arbitraryWLTx net False + -- | Arbitrary witness transaction (witness data is fake). arbitraryWitnessTx :: Network -> Gen Tx arbitraryWitnessTx net = arbitraryWLTx net True + -- | Arbitrary witness or legacy transaction. arbitraryWLTx :: Network -> Bool -> Gen Tx arbitraryWLTx net wit = do @@ -83,10 +89,10 @@ arbitraryWLTx net wit = do else return [] Tx <$> arbitrary <*> pure uniqueInps <*> pure outs <*> pure w <*> arbitrary -{- | Arbitrary transaction containing only inputs of type 'SpendPKHash', - 'SpendScriptHash' (multisig) and outputs of type 'PayPKHash' and 'PaySH'. - Only compressed public keys are used. --} + +-- | Arbitrary transaction containing only inputs of type 'SpendPKHash', +-- 'SpendScriptHash' (multisig) and outputs of type 'PayPKHash' and 'PaySH'. +-- Only compressed public keys are used. arbitraryAddrOnlyTx :: Network -> Gen Tx arbitraryAddrOnlyTx net = do ni <- choose (1, 5) @@ -95,6 +101,7 @@ arbitraryAddrOnlyTx net = do outs <- vectorOf no (arbitraryAddrOnlyTxOut net) Tx <$> arbitrary <*> pure inps <*> pure outs <*> pure [] <*> arbitrary + -- | Like 'arbitraryAddrOnlyTx' without empty signatures in the inputs. arbitraryAddrOnlyTxFull :: Network -> Gen Tx arbitraryAddrOnlyTxFull net = do @@ -104,14 +111,15 @@ arbitraryAddrOnlyTxFull net = do outs <- vectorOf no (arbitraryAddrOnlyTxOut net) Tx <$> arbitrary <*> pure inps <*> pure outs <*> pure [] <*> arbitrary -{- | Arbitrary TxIn that can only be of type 'SpendPKHash' or 'SpendScriptHash' - (multisig). Only compressed public keys are used. --} + +-- | Arbitrary TxIn that can only be of type 'SpendPKHash' or 'SpendScriptHash' +-- (multisig). Only compressed public keys are used. arbitraryAddrOnlyTxIn :: Network -> Gen TxIn arbitraryAddrOnlyTxIn net = do inp <- oneof [arbitraryPKHashInput net, arbitraryMulSigSHInput net] TxIn <$> arbitraryOutPoint <*> pure (encodeInputBS inp) <*> arbitrary + -- | like 'arbitraryAddrOnlyTxIn' with no empty signatures. arbitraryAddrOnlyTxInFull :: Network -> Gen TxIn arbitraryAddrOnlyTxInFull net = do @@ -119,6 +127,7 @@ arbitraryAddrOnlyTxInFull net = do oneof [arbitraryPKHashInputFullC net, arbitraryMulSigSHInputFullC net] TxIn <$> arbitraryOutPoint <*> pure (encodeInputBS inp) <*> arbitrary + -- | Arbitrary 'TxOut' that can only be of type 'PayPKHash' or 'PaySH'. arbitraryAddrOnlyTxOut :: Network -> Gen TxOut arbitraryAddrOnlyTxOut net = do @@ -126,9 +135,9 @@ arbitraryAddrOnlyTxOut net = do out <- oneof [arbitraryPKHashOutput, arbitrarySHOutput] return $ TxOut v $ encodeOutputBS out -{- | Arbitrary 'SigInput' with the corresponding private keys used - to generate the 'ScriptOutput' or 'RedeemScript'. --} + +-- | Arbitrary 'SigInput' with the corresponding private keys used +-- to generate the 'ScriptOutput' or 'RedeemScript'. arbitrarySigInput :: Network -> Gen (SigInput, [SecKeyI]) arbitrarySigInput net = oneof @@ -140,14 +149,17 @@ arbitrarySigInput net = , arbitraryWSHSigInput net ] + -- | Arbitrary 'SigInput' with a 'ScriptOutput' of type 'PayPK'. arbitraryPKSigInput :: Network -> Gen (SigInput, SecKeyI) arbitraryPKSigInput net = arbitraryAnyInput net False + -- | Arbitrary 'SigInput' with a 'ScriptOutput' of type 'PayPKHash'. arbitraryPKHashSigInput :: Network -> Gen (SigInput, SecKeyI) arbitraryPKHashSigInput net = arbitraryAnyInput net True + -- | Arbitrary 'SigInput'. arbitraryAnyInput :: Network -> Bool -> Gen (SigInput, SecKeyI) arbitraryAnyInput net pkh = do @@ -158,6 +170,7 @@ arbitraryAnyInput net pkh = do (val, op, sh) <- arbitraryInputStuff net return (SigInput out val op sh Nothing, k) + -- | Arbitrary value, out point and sighash for an input. arbitraryInputStuff :: Network -> Gen (Word64, OutPoint, SigHash) arbitraryInputStuff net = do @@ -166,6 +179,7 @@ arbitraryInputStuff net = do sh <- arbitraryValidSigHash net return (val, op, sh) + -- | Arbitrary 'SigInput' with a 'ScriptOutput' of type 'PayMulSig'. arbitraryMSSigInput :: Network -> Gen (SigInput, [SecKeyI]) arbitraryMSSigInput net = do @@ -177,9 +191,9 @@ arbitraryMSSigInput net = do let ksPerm = map fst $ take m $ permutations ks !! perm return (SigInput out val op sh Nothing, ksPerm) -{- | Arbitrary 'SigInput' with 'ScriptOutput' of type 'PaySH' and a - 'RedeemScript'. --} + +-- | Arbitrary 'SigInput' with 'ScriptOutput' of type 'PaySH' and a +-- 'RedeemScript'. arbitrarySHSigInput :: Network -> Gen (SigInput, [SecKeyI]) arbitrarySHSigInput net = do (SigInput rdm val op sh _, ks) <- @@ -191,6 +205,7 @@ arbitrarySHSigInput net = do let out = PayScriptHash $ getAddrHash160 $ payToScriptAddress rdm return (SigInput out val op sh $ Just rdm, ks) + arbitraryWPKHSigInput :: Network -> Gen (SigInput, SecKeyI) arbitraryWPKHSigInput net = do (k, p) <- arbitraryKeyPair @@ -198,6 +213,7 @@ arbitraryWPKHSigInput net = do let out = PayWitnessPKHash . getAddrHash160 $ pubKeyAddr p return (SigInput out val op sh Nothing, k) + arbitraryWSHSigInput :: Network -> Gen (SigInput, [SecKeyI]) arbitraryWSHSigInput net = do (SigInput rdm val op sh _, ks) <- @@ -209,9 +225,9 @@ arbitraryWSHSigInput net = do let out = PayWitnessScriptHash . getAddrHash256 $ payToWitnessScriptAddress rdm return (SigInput out val op sh $ Just rdm, ks) -{- | Arbitrary 'Tx' (empty 'TxIn'), 'SigInputs' and private keys that can be - passed to 'signTx' or 'detSignTx' to fully sign the 'Tx'. --} + +-- | Arbitrary 'Tx' (empty 'TxIn'), 'SigInputs' and private keys that can be +-- passed to 'signTx' or 'detSignTx' to fully sign the 'Tx'. arbitrarySigningData :: Network -> Gen (Tx, [SigInput], [SecKeyI]) arbitrarySigningData net = do v <- arbitrary @@ -227,6 +243,7 @@ arbitrarySigningData net = do keys = concatMap snd uSigis return (tx, map fst uSigis, keys) + -- | Arbitrary transaction with empty inputs. arbitraryEmptyTx :: Network -> Gen Tx arbitraryEmptyTx net = do @@ -239,6 +256,7 @@ arbitraryEmptyTx net = do s <- arbitrary return $ Tx v (map (\op -> TxIn op BS.empty s) (nub ops)) outs [] t + -- | Arbitrary partially-signed transactions. arbitraryPartialTxs :: Network -> Gen ([Tx], [(ScriptOutput, Word64, OutPoint, Int, Int)]) @@ -250,32 +268,33 @@ arbitraryPartialTxs net = do 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 - ) - ] + 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/src/Haskoin/Util/Arbitrary/Util.hs b/src/Haskoin/Util/Arbitrary/Util.hs index 26f3bdce..4c5a0988 100644 --- a/src/Haskoin/Util/Arbitrary/Util.hs +++ b/src/Haskoin/Util/Arbitrary/Util.hs @@ -1,14 +1,13 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-} -{- | -Module : Haskoin.Test.Util -Copyright : No rights reserved -License : MIT -Maintainer : jprupp@protonmail.ch -Stability : experimental -Portability : POSIX --} +-- | +--Module : Haskoin.Test.Util +--Copyright : No rights reserved +--License : MIT +--Maintainer : jprupp@protonmail.ch +--Stability : experimental +--Portability : POSIX module Haskoin.Util.Arbitrary.Util ( arbitraryBS, arbitraryBS1, @@ -20,25 +19,17 @@ module Haskoin.Util.Arbitrary.Util ( arbitraryNetwork, arbitraryUTCTime, SerialBox (..), - JsonBox (..), - NetBox (..), ReadBox (..), - testIdentity, testSerial, testRead, - testJson, - testNetJson, arbitraryNetData, genNetData, ) where import Control.Monad (forM_, (<=<)) -import qualified Data.Aeson as A -import qualified Data.Aeson.Encoding as A -import qualified Data.Aeson.Types as A import Data.ByteString (ByteString, pack) -import qualified Data.ByteString.Short as BSS import Data.ByteString.Lazy (fromStrict, toStrict) +import qualified Data.ByteString.Short as BSS import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial @@ -54,36 +45,44 @@ import Test.Hspec (Spec, describe, shouldBe, shouldSatisfy) import Test.Hspec.QuickCheck (prop) import Test.QuickCheck + -- | Arbitrary strict 'ByteString'. arbitraryBS :: Gen ByteString arbitraryBS = pack <$> arbitrary + -- | Arbitrary non-empty strict 'ByteString' arbitraryBS1 :: Gen ByteString arbitraryBS1 = pack <$> listOf1 arbitrary + -- | Arbitrary strict 'ByteString' of a given length arbitraryBSn :: Int -> Gen ByteString arbitraryBSn n = pack <$> vectorOf n arbitrary + -- | Arbitrary 'ShortByteString'. arbitraryBSS :: Gen BSS.ShortByteString arbitraryBSS = BSS.pack <$> arbitrary + -- | Arbitrary non-empty 'ShortByteString' arbitraryBSS1 :: Gen BSS.ShortByteString arbitraryBSS1 = BSS.pack <$> listOf1 arbitrary + -- | Arbitrary 'ShortByteString' of a given length arbitraryBSSn :: Int -> Gen BSS.ShortByteString arbitraryBSSn n = BSS.pack <$> vectorOf n arbitrary + -- | Arbitrary UTCTime that generates dates after 01 Jan 1970 01:00:00 CET arbitraryUTCTime :: Gen UTCTime arbitraryUTCTime = do w <- arbitrary :: Gen Word32 return $ posixSecondsToUTCTime $ realToFrac w + -- | Generate a Maybe from a Gen a arbitraryMaybe :: Gen a -> Gen (Maybe a) arbitraryMaybe g = @@ -92,10 +91,12 @@ arbitraryMaybe g = , (5, Just <$> g) ] + -- | Generate an Network arbitraryNetwork :: Gen Network arbitraryNetwork = elements allNets + -- Helpers for creating Serial and JSON Identity tests data SerialBox @@ -103,36 +104,12 @@ data SerialBox (Show a, Eq a, T.Typeable a, Serial a) => SerialBox (Gen a) + data ReadBox = forall a. (Read a, Show a, Eq a, T.Typeable a) => ReadBox (Gen a) -data JsonBox - = forall a. - (Show a, Eq a, T.Typeable a, A.ToJSON a, A.FromJSON a) => - JsonBox (Gen a) - -data NetBox - = forall a. - (Show a, Eq a, T.Typeable a) => - NetBox - ( Network -> a -> A.Value - , Network -> a -> A.Encoding - , Network -> A.Value -> A.Parser a - , Gen (Network, a) - ) - -testIdentity :: [SerialBox] -> [ReadBox] -> [JsonBox] -> [NetBox] -> Spec -testIdentity serialVals readVals jsonVals netVals = do - describe "Binary Encoding" $ - forM_ serialVals $ \(SerialBox g) -> testSerial g - describe "Read/Show Encoding" $ - forM_ readVals $ \(ReadBox g) -> testRead g - describe "Data.Aeson Encoding" $ - forM_ jsonVals $ \(JsonBox g) -> testJson g - describe "Data.Aeson Encoding with Network" $ - forM_ netVals $ \(NetBox (j, e, p, g)) -> testNetJson j e p g -- | Generate binary identity tests testSerial :: @@ -144,10 +121,11 @@ testSerial gen = (runGetL deserialize . fromStrict . runPutS . serialize) x `shouldBe` x (runGetS deserialize . runPutS . serialize) x `shouldBe` Right x (runGetS deserialize . toStrict . runPutL . serialize) x `shouldBe` Right x - where - name = show $ T.typeRep $ proxy gen - proxy :: Gen a -> Proxy a - proxy = const Proxy + where + name = show $ T.typeRep $ proxy gen + proxy :: Gen a -> Proxy a + proxy = const Proxy + -- | Generate Read/Show identity tests testRead :: @@ -155,48 +133,11 @@ testRead :: testRead gen = prop ("read/show identity for " <> name) $ forAll gen $ \x -> (read . show) x `shouldBe` x - where - name = show $ T.typeRep $ proxy gen - proxy :: Gen a -> Proxy a - proxy = const Proxy - --- | Generate Data.Aeson identity tests -testJson :: - (Eq a, Show a, T.Typeable a, A.ToJSON a, A.FromJSON a) => Gen a -> Spec -testJson gen = do - prop ("Data.Aeson toJSON/fromJSON identity for " <> name) $ - forAll gen (`shouldSatisfy` jsonID) - prop ("Data.Aeson toEncoding/fromJSON identity for " <> name) $ - forAll gen (`shouldSatisfy` encodingID) - where - name = show $ T.typeRep $ proxy gen - proxy :: Gen a -> Proxy a - proxy = const Proxy - jsonID x = (A.fromJSON . A.toJSON) (toMap x) == A.Success (toMap x) - encodingID x = - (A.decode . A.encodingToLazyByteString . A.toEncoding) (toMap x) - == Just (toMap x) - --- | Generate Data.Aeson identity tests for type that need the @Network@ -testNetJson :: - (Eq a, Show a, T.Typeable a) => - (Network -> a -> A.Value) -> - (Network -> a -> A.Encoding) -> - (Network -> A.Value -> A.Parser a) -> - Gen (Network, a) -> - Spec -testNetJson j e p g = do - prop ("Data.Aeson toJSON/fromJSON identity (with network) for " <> name) $ - forAll g $ \(net, x) -> dec net (encVal net x) `shouldBe` Just x - prop ("Data.Aeson toEncoding/fromJSON identity (with network) for " <> name) $ - forAll g $ \(net, x) -> dec net (encEnc net x) `shouldBe` Just x - where - encVal net = A.encode . toMap . j net - encEnc net = A.encodingToLazyByteString . toMapE . e net - dec net = A.parseMaybe (p net) . fromMap <=< A.decode - name = show $ T.typeRep $ proxy j - proxy :: (Network -> a -> A.Value) -> Proxy a - proxy = const Proxy + where + name = show $ T.typeRep $ proxy gen + proxy :: Gen a -> Proxy a + proxy = const Proxy + arbitraryNetData :: Arbitrary a => Gen (Network, a) arbitraryNetData = do @@ -204,17 +145,17 @@ arbitraryNetData = do x <- arbitrary return (net, x) + genNetData :: Gen a -> Gen (Network, a) genNetData gen = do net <- arbitraryNetwork x <- gen return (net, x) + toMap :: a -> Map.Map String a toMap = Map.singleton "object" -toMapE :: A.Encoding -> A.Encoding -toMapE = A.pairs . A.pair "object" fromMap :: Map.Map String a -> a fromMap = (Map.! "object") diff --git a/stack.yaml b/stack.yaml index 65de78f5..e0f67230 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,5 @@ -resolver: lts-19.3 +resolver: lts-19.22 +system-ghc: true nix: packages: - secp256k1 diff --git a/stack.yaml.lock b/stack.yaml.lock index 729c2194..6ab576eb 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,7 @@ packages: [] snapshots: - completed: - size: 617368 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/3.yaml - sha256: a209d3455279ee76eb45f01f73bbb960ceaaa8dfad8891435384689df4dcb653 - original: lts-19.3 + size: 619399 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/22.yaml + sha256: 5098594e71bdefe0c13e9e6236f12e3414ef91a2b89b029fd30e8fc8087f3a07 + original: lts-19.22 diff --git a/test/Haskoin/Address/CashAddrSpec.hs b/test/Haskoin/Address/CashAddrSpec.hs deleted file mode 100644 index 11c640c0..00000000 --- a/test/Haskoin/Address/CashAddrSpec.hs +++ /dev/null @@ -1,347 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Haskoin.Address.CashAddrSpec (spec) where - -import Control.Monad -import qualified Data.ByteString.Char8 as C -import Data.Maybe -import Data.String.Conversions -import Data.Text (Text) -import Haskoin.Address -import Haskoin.Constants -import Haskoin.Util -import Test.HUnit -import Test.Hspec - -spec :: Spec -spec = do - describe "cashaddr checksum test vectors" $ do - it "prefix:x64nx6hz" $ do - let mpb = cash32decode "prefix:x64nx6hz" - mpb `shouldBe` Just ("prefix", "") - it "p:gpf8m4h7" $ do - let mpb = cash32decode "p:gpf8m4h7" - mpb `shouldBe` Just ("p", "") - it "bitcoincash:qpzry9x8gf2tvdw0s3jn54khce6mua7lcw20ayyn" $ do - let mpb = - cash32decode - "bitcoincash:qpzry9x8gf2tvdw0s3jn54khce6mua7lcw20ayyn" - mpb - `shouldBe` Just - ( "bitcoincash" - , "\NULD2\DC4\199BT\182\&5\207\132e:V\215\198u\190w\223" - ) - it "bchtest:testnetaddress4d6njnut" $ do - let mpb = cash32decode "bchtest:testnetaddress4d6njnut" - mpb `shouldBe` Just ("bchtest", "^`\185\229}kG\152") - it "bchreg:555555555555555555555555555555555555555555555udxmlmrz" $ do - let mpb = - cash32decode - "bchreg:555555555555555555555555555555555555555555555udxmlmrz" - mpb - `shouldBe` Just - ( "bchreg" - , "\165)JR\148\165)JR\148\165)JR\148\165)JR\148\165)JR\148\165)J" - ) - describe "cashaddr to base58 translation test vectors" $ do - it "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu" $ do - let addr = - addrToText bch - =<< textToAddr btc "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu" - addr - `shouldBe` Just "bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a" - it "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR" $ do - let addr = - addrToText bch - =<< textToAddr btc "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR" - addr - `shouldBe` Just "bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy" - it "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb" $ do - let addr = - addrToText bch - =<< textToAddr btc "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb" - addr - `shouldBe` Just "bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r" - it "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC" $ do - let addr = - addrToText bch - =<< textToAddr btc "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC" - addr - `shouldBe` Just "bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq" - it "3LDsS579y7sruadqu11beEJoTjdFiFCdX4" $ do - let addr = - addrToText bch - =<< textToAddr btc "3LDsS579y7sruadqu11beEJoTjdFiFCdX4" - addr - `shouldBe` Just "bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e" - it "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw" $ do - let addr = - addrToText bch - =<< textToAddr btc "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw" - addr - `shouldBe` Just "bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37" - describe "base58 to cashaddr translation test vectors" $ do - it "bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a" $ do - let addr = - addrToText btc - =<< textToAddr - bch - "bitcoincash:qpm2qsznhks23z7629mms6s4cwef74vcwvy22gdx6a" - addr `shouldBe` Just "1BpEi6DfDAUFd7GtittLSdBeYJvcoaVggu" - it "bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy" $ do - let addr = - addrToText btc - =<< textToAddr - bch - "bitcoincash:qr95sy3j9xwd2ap32xkykttr4cvcu7as4y0qverfuy" - addr `shouldBe` Just "1KXrWXciRDZUpQwQmuM1DbwsKDLYAYsVLR" - it "bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r" $ do - let addr = - addrToText btc - =<< textToAddr - bch - "bitcoincash:qqq3728yw0y47sqn6l2na30mcw6zm78dzqre909m2r" - addr `shouldBe` Just "16w1D5WRVKJuZUsSRzdLp9w3YGcgoxDXb" - it "bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq" $ do - let addr = - addrToText btc - =<< textToAddr - bch - "bitcoincash:ppm2qsznhks23z7629mms6s4cwef74vcwvn0h829pq" - addr `shouldBe` Just "3CWFddi6m4ndiGyKqzYvsFYagqDLPVMTzC" - it "bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e" $ do - let addr = - addrToText btc - =<< textToAddr - bch - "bitcoincash:pr95sy3j9xwd2ap32xkykttr4cvcu7as4yc93ky28e" - addr `shouldBe` Just "3LDsS579y7sruadqu11beEJoTjdFiFCdX4" - it "bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37" $ do - let addr = - addrToText btc - =<< textToAddr - bch - "bitcoincash:pqq3728yw0y47sqn6l2na30mcw6zm78dzq5ucqzc37" - addr `shouldBe` Just "31nwvkZwyPdgzjBJZXfDmSWsC4ZLKpYyUw" - describe "cashaddr larger test vectors" $ - forM_ (zip [0 ..] vectors) $ \(i, vec) -> - it ("cashaddr test vector " <> show (i :: Int)) $ testCashAddr vec - -{- Various utilities -} - -testCashAddr :: (Int, CashVersion, Cash32, Text) -> Assertion -testCashAddr (len, typ, addr, hex) = do - let mbs = decodeHex hex - assertBool "Could not decode hex payload from test vector" (isJust mbs) - let mlow = cash32decode addr - assertBool "Could not decode low level address" (isJust mlow) - let Just (_, lbs) = mlow - assertEqual "Low-level payload size incorrect" len (C.length lbs - 1) - assertEqual "Low-level payload doesn't match" bs (C.tail lbs) - let mdec = cash32decodeType addr - assertBool ("Could not decode test address: " <> cs addr) (isJust mdec) - assertEqual "Length doesn't match" len (C.length pay) - assertEqual "Version doesn't match" typ ver - assertEqual "Payload doesn't match" bs pay - where - Just bs = decodeHex hex - Just (_, ver, pay) = cash32decodeType addr - -{- | All vectors starting with @pref@ had the wrong version in the spec - document. --} -vectors :: [(Int, CashVersion, Text, Text)] -vectors = - [ - ( 20 - , 0 - , "bitcoincash:qr6m7j9njldwwzlg9v7v53unlr4jkmx6eylep8ekg2" - , "F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9" - ) - , - ( 20 - , 1 - , "bchtest:pr6m7j9njldwwzlg9v7v53unlr4jkmx6eyvwc0uz5t" - , "F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9" - ) - , - ( 20 - , 1 - , "pref:pr6m7j9njldwwzlg9v7v53unlr4jkmx6ey65nvtks5" - , "F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9" - ) - , - ( 20 - , 15 - , "prefix:0r6m7j9njldwwzlg9v7v53unlr4jkmx6ey3qnjwsrf" - , "F5BF48B397DAE70BE82B3CCA4793F8EB2B6CDAC9" - ) - , - ( 24 - , 0 - , "bitcoincash:q9adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2ws4mr9g0" - , "7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA" - ) - , - ( 24 - , 1 - , "bchtest:p9adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2u94tsynr" - , "7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA" - ) - , - ( 24 - , 1 - , "pref:p9adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2khlwwk5v" - , "7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA" - ) - , - ( 24 - , 15 - , "prefix:09adhakpwzztepkpwp5z0dq62m6u5v5xtyj7j3h2p29kc2lp" - , "7ADBF6C17084BC86C1706827B41A56F5CA32865925E946EA" - ) - , - ( 28 - , 0 - , "bitcoincash:qgagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkcw59jxxuz" - , "3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B" - ) - , - ( 28 - , 1 - , "bchtest:pgagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkcvs7md7wt" - , "3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B" - ) - , - ( 28 - , 1 - , "pref:pgagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkcrsr6gzkn" - , "3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B" - ) - , - ( 28 - , 15 - , "prefix:0gagf7w02x4wnz3mkwnchut2vxphjzccwxgjvvjmlsxqwkc5djw8s9g" - , "3A84F9CF51AAE98A3BB3A78BF16A6183790B18719126325BFC0C075B" - ) - , - ( 32 - , 0 - , "bitcoincash:qvch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxq5nlegake" - , "3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060" - ) - , - ( 32 - , 1 - , "bchtest:pvch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxq7fqng6m6" - , "3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060" - ) - , - ( 32 - , 1 - , "pref:pvch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxq4k9m7qf9" - , "3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060" - ) - , - ( 32 - , 15 - , "prefix:0vch8mmxy0rtfrlarg7ucrxxfzds5pamg73h7370aa87d80gyhqxqsh6jgp6w" - , "3173EF6623C6B48FFD1A3DCC0CC6489B0A07BB47A37F47CFEF4FE69DE825C060" - ) - , - ( 40 - , 0 - , "bitcoincash:qnq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklv39gr3uvz" - , "C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB" - ) - , - ( 40 - , 1 - , "bchtest:pnq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklvmgm6ynej" - , "C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB" - ) - , - ( 40 - , 1 - , "pref:pnq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklv0vx5z0w3" - , "C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB" - ) - , - ( 40 - , 15 - , "prefix:0nq8zwpj8cq05n7pytfmskuk9r4gzzel8qtsvwz79zdskftrzxtar994cgutavfklvwsvctzqy" - , "C07138323E00FA4FC122D3B85B9628EA810B3F381706385E289B0B25631197D194B5C238BEB136FB" - ) - , - ( 48 - , 0 - , "bitcoincash:qh3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqex2w82sl" - , "E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C" - ) - , - ( 48 - , 1 - , "bchtest:ph3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqnzf7mt6x" - , "E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C" - ) - , - ( 48 - , 1 - , "pref:ph3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqjntdfcwg" - , "E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C" - ) - , - ( 48 - , 15 - , "prefix:0h3krj5607v3qlqh5c3wq3lrw3wnuxw0sp8dv0zugrrt5a3kj6ucysfz8kxwv2k53krr7n933jfsunqakcssnmn" - , "E361CA9A7F99107C17A622E047E3745D3E19CF804ED63C5C40C6BA763696B98241223D8CE62AD48D863F4CB18C930E4C" - ) - , - ( 56 - , 0 - , "bitcoincash:qmvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqscw8jd03f" - , "D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041" - ) - , - ( 56 - , 1 - , "bchtest:pmvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqs6kgdsg2g" - , "D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041" - ) - , - ( 56 - , 1 - , "pref:pmvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqsammyqffl" - , "D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041" - ) - , - ( 56 - , 15 - , "prefix:0mvl5lzvdm6km38lgga64ek5jhdl7e3aqd9895wu04fvhlnare5937w4ywkq57juxsrhvw8ym5d8qx7sz7zz0zvcypqsgjrqpnw8" - , "D9FA7C4C6EF56DC4FF423BAAE6D495DBFF663D034A72D1DC7D52CBFE7D1E6858F9D523AC0A7A5C34077638E4DD1A701BD017842789982041" - ) - , - ( 64 - , 0 - , "bitcoincash:qlg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96mtky5sv5w" - , "D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B" - ) - , - ( 64 - , 1 - , "bchtest:plg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96mc773cwez" - , "D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B" - ) - , - ( 64 - , 1 - , "pref:plg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96mg7pj3lh8" - , "D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B" - ) - , - ( 64 - , 15 - , "prefix:0lg0x333p4238k0qrc5ej7rzfw5g8e4a4r6vvzyrcy8j3s5k0en7calvclhw46hudk5flttj6ydvjc0pv3nchp52amk97tqa5zygg96ms92w6845" - , "D0F346310D5513D9E01E299978624BA883E6BDA8F4C60883C10F28C2967E67EC77ECC7EEEAEAFC6DA89FAD72D11AC961E164678B868AEEEC5F2C1DA08884175B" - ) - ] diff --git a/test/Haskoin/BlockSpec.hs b/test/Haskoin/BlockSpec.hs index 4b744373..7530b47f 100644 --- a/test/Haskoin/BlockSpec.hs +++ b/test/Haskoin/BlockSpec.hs @@ -22,6 +22,7 @@ import Test.Hspec.QuickCheck import Test.QuickCheck import Text.Printf (printf) + serialVals :: [SerialBox] serialVals = [ SerialBox (arbitraryBlock =<< arbitraryNetwork) @@ -34,6 +35,7 @@ serialVals = , SerialBox arbitraryBlockNode ] + readVals :: [ReadBox] readVals = [ ReadBox (arbitraryBlock =<< arbitraryNetwork) @@ -46,6 +48,7 @@ readVals = , ReadBox arbitraryBlockNode ] + jsonVals :: [JsonBox] jsonVals = [ JsonBox (arbitraryBlock =<< arbitraryNetwork) @@ -53,43 +56,26 @@ jsonVals = , JsonBox arbitraryBlockHeader ] + myTime :: Timestamp myTime = 1499083075 + withChain :: Network -> State HeaderMemory a -> a withChain net f = evalState f (initialChain net) + chain :: BlockHeaders m => Network -> BlockHeader -> Int -> m () chain net bh i = do bnsE <- connectBlocks net myTime bhs either error (const $ return ()) bnsE - where - bhs = appendBlocks net 6 bh i + where + bhs = appendBlocks net 6 bh i + spec :: Spec spec = do testIdentity serialVals readVals jsonVals [] - describe "blockchain headers" $ do - it "gets best block on bchRegTest" $ - let net = bchRegTest - bb = - withChain net $ do - chain net (getGenesisHeader net) 100 - getBestBlockHeader - in nodeHeight bb `shouldBe` 100 - it "builds a block locator on bchRegTest" $ - let net = bchRegTest - loc = - withChain net $ do - chain net (getGenesisHeader net) 100 - bb <- getBestBlockHeader - blockLocatorNodes bb - heights = map nodeHeight loc - in heights `shouldBe` [100, 99 .. 90] <> [88, 84, 76, 60, 28, 0] - it "follows split chains on bchRegTest" $ - let net = bchRegTest - bb = withChain net $ splitChain net >> getBestBlockHeader - in nodeHeight bb `shouldBe` 4035 describe "block hash" $ do prop "encodes and decodes block hash" $ forAll arbitraryBlockHash $ \h -> @@ -120,6 +106,7 @@ spec = do it "computes bitcoin block subsidy correctly" (testSubsidy btc) it "computes regtest block subsidy correctly" (testSubsidy btcRegTest) + -- 0 → → 2015 → → → → → → → 4031 -- ↓ -- → → 2035 → → → → → → 4035* @@ -147,37 +134,41 @@ splitChain net = do 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 + 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) + 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 @@ -188,6 +179,7 @@ testCompact = do assertEqual "vector 5" 0x05c0de00 (encodeCompact (-0x40de000000)) assertEqual "vector 6" (-0x40de000000, False) (decodeCompact 0x05c0de00) + testCompactBitcoinCore :: Assertion testCompactBitcoinCore = do assertEqual "zero" (0, False) (decodeCompact 0x00000000) @@ -268,12 +260,14 @@ testCompactBitcoinCore = do "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 + where + f = fromJust . hexToTxHash + merkleVectors :: [(Text, [Text])] merkleVectors = @@ -369,22 +363,26 @@ merkleVectors = ) ] + 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) + 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) + data AsertBlock = AsertBlock Int Integer Integer Word32 + data AsertVector = AsertVector String Integer Integer Word32 [AsertBlock] + readAsertVector :: FilePath -> IO AsertVector readAsertVector p = do (d : ah : apt : ab : _ : _ : _ : _ : xs) <- lines <$> readFile ("data/" ++ p) @@ -400,15 +398,17 @@ readAsertVector p = do anchor_parent_time anchor_nbits blocks - where - f [i, h, t, g] = AsertBlock (read i) (read h) (read t) (read g) - f _ = undefined + where + f [i, h, t, g] = AsertBlock (read i) (read h) (read t) (read g) + f _ = undefined + asertTests :: FilePath -> SpecWith () asertTests file = do v@(AsertVector d _ _ _ _) <- runIO $ readAsertVector file it d $ testAsertBits v + testAsertBits :: AsertVector -> Assertion testAsertBits (AsertVector _ anchor_height anchor_parent_time anchor_bits blocks) = forM_ blocks $ \(AsertBlock _ h t g) -> diff --git a/test/Haskoin/ScriptSpec.hs b/test/Haskoin/ScriptSpec.hs index 5c3d07ff..9c6724b0 100644 --- a/test/Haskoin/ScriptSpec.hs +++ b/test/Haskoin/ScriptSpec.hs @@ -31,12 +31,14 @@ import Test.Hspec.QuickCheck import Test.QuickCheck import Text.Read + serialVals :: [SerialBox] serialVals = [ SerialBox arbitraryScriptOp , SerialBox arbitraryScript ] + readVals :: [ReadBox] readVals = [ ReadBox arbitrarySigHash @@ -47,6 +49,7 @@ readVals = , ReadBox (arbitraryScriptOutput =<< arbitraryNetwork) ] + jsonVals :: [JsonBox] jsonVals = [ JsonBox $ arbitraryScriptOutput =<< arbitraryNetwork @@ -55,11 +58,11 @@ jsonVals = , JsonBox $ fst <$> (arbitrarySigInput =<< arbitraryNetwork) ] + spec :: Spec spec = do testIdentity serialVals readVals jsonVals [] describe "btc scripts" $ props btc - describe "bch scripts" $ props bch describe "multi signatures" $ zipWithM_ (curry mapMulSigVector) mulSigVectors [0 ..] describe "signature decoding" $ @@ -70,6 +73,7 @@ spec = do describe "Script vectors" $ it "Can encode script vectors" encodeScriptVector + props :: Network -> Spec props net = do standardSpec net @@ -80,6 +84,7 @@ props net = do sigHashSpec net txSigHashSpec net + standardSpec :: Network -> Spec standardSpec net = do prop "has intToScriptOp . scriptOpToInt identity" $ @@ -112,6 +117,7 @@ standardSpec net = do decodeInput net (Script [OP_0, OP_0, OP_0, OP_0]) `shouldBe` Right (RegularInput (SpendMulSig $ replicate 3 TxSignatureEmpty)) + scriptSpec :: Network -> Spec scriptSpec net = when (getNetworkName net == "btc") $ @@ -162,6 +168,7 @@ scriptSpec net = "OK" -> assertBool desc $ ver decodedOutput _ -> assertBool desc (not $ ver decodedOutput) + forkIdScriptSpec :: Network -> Spec forkIdScriptSpec net = when (isJust (getSigHashForkId net)) $ @@ -196,44 +203,49 @@ forkIdScriptSpec net = "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 = runPutS $ serialize $ Script [OP_0, OP_0] - , txInSequence = maxBound - } + where + txO = TxOut{outValue = val, scriptOutput = scriptPubKey} + txI = + TxIn + { prevOutput = nullOutPoint + , scriptInput = runPutS $ serialize $ 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 - } + 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 + 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 $ runPutS $ serialize (opcode :: ScriptOp)) _ -> str + strictSigSpec :: Network -> Spec strictSigSpec net = when (getNetworkName net == "btc") $ do @@ -250,6 +262,7 @@ strictSigSpec net = forM_ vectors $ \sig -> decodeTxSig net sig `shouldSatisfy` isLeft + txSigHashSpec :: Network -> Spec txSigHashSpec net = when (getNetworkName net == "btc") $ @@ -276,6 +289,7 @@ txSigHashSpec net = =<< decodeHex (cs resStr) Just (txSigHash net tx s 0 i sh) `shouldBe` res + txSigHashForkIdSpec :: Network -> Spec txSigHashForkIdSpec net = when (getNetworkName net == "btc") $ @@ -301,6 +315,7 @@ txSigHashForkIdSpec net = res = eitherToMaybe . runGetS deserialize =<< decodeHex (cs resStr) Just (txSigHashForkId net tx s val i sh) `shouldBe` res + sigHashSpec :: Network -> Spec sigHashSpec net = do it "can correctly show" $ do @@ -353,44 +368,49 @@ sigHashSpec net = do 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 + where + res = txSigHash net tx s val (length (txIn tx) - 1) (f sigHashSingle) + one = "0100000000000000000000000000000000000000000000000000000000000000" + f = + if acp + then setAnyoneCanPayFlag + else id + {- 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 + 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 $ runGetS deserialize s' - b = do - o <- s - d <- eitherToMaybe $ decodeOutput o - addrToText btc $ payToScriptAddress d + where + s = do + s' <- decodeHex ops + eitherToMaybe $ runGetS deserialize s' + b = do + o <- s + d <- eitherToMaybe $ decodeOutput o + addrToText btc $ payToScriptAddress d + sigDecodeMap :: Network -> (Text, Int) -> Spec sigDecodeMap net (_, i) = it ("check signature " ++ show i) func - where - func = testSigDecode net $ scriptSigSignatures !! i + where + func = testSigDecode net $ scriptSigSignatures !! i + testSigDecode :: Network -> Text -> Assertion testSigDecode net str = @@ -404,6 +424,7 @@ testSigDecode net str = ) $ isRight eitherSig + mulSigVectors :: [(Text, Text)] mulSigVectors = [ @@ -418,6 +439,7 @@ mulSigVectors = ) ] + scriptSigSignatures :: [Text] scriptSigSignatures = -- Signature in input of txid @@ -434,30 +456,31 @@ scriptSigSignatures = -- \e18fe1e7d1510db501" ] + encodeScriptVector :: Assertion encodeScriptVector = assertEqual "Encode script" res (encodeHex $ runPutS $ serialize s) - where - res = - "514104cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef58b\ - \bfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d11fcdd0d\ - \348ac4410461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2f\ - \cfdeb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39f58b\ - \25c15342af52ae" - s = - Script - [ OP_1 - , opPushData $ - d - "04cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef5\ - \8bbfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d\ - \11fcdd0d348ac4" - , opPushData $ - d - "0461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2fcf\ - \deb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39\ - \f58b25c15342af" - , OP_2 - , OP_CHECKMULTISIG - ] - d = fromJust . decodeHex + where + res = + "514104cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef58b\ + \bfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d11fcdd0d\ + \348ac4410461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2f\ + \cfdeb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39f58b\ + \25c15342af52ae" + s = + Script + [ OP_1 + , opPushData $ + d + "04cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef5\ + \8bbfbfaff7d8a473e7e2e6d317b87bafe8bde97e3cf8f065dec022b51d\ + \11fcdd0d348ac4" + , opPushData $ + d + "0461cbdcc5409fb4b4d42b51d33381354d80e550078cb532a34bfa2fcf\ + \deb7d76519aecc62770f5b0e4ef8551946d8a540911abe3e7854a26f39\ + \f58b25c15342af" + , OP_2 + , OP_CHECKMULTISIG + ] + d = fromJust . decodeHex