From 1210f3c59fa1da0d019fb055f3eb7a7dafcb35d5 Mon Sep 17 00:00:00 2001 From: Ian Shipman Date: Tue, 4 Oct 2022 21:28:11 -0500 Subject: [PATCH 1/2] Add hlint rules - Regularize qualifications --- .hlint.yaml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/.hlint.yaml b/.hlint.yaml index fd6694d4..fc47c28c 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -9,3 +9,9 @@ - "-fdefer-typed-holes" - "-Wno-typed-holes" within: [] + +- modules: + - name: Data.ByteString + as: BS + - name: Data.ByteString.Lazy + as: BSL From 49b948c6bfdde610545aac2346ea94c39e015d0e Mon Sep 17 00:00:00 2001 From: Ian Shipman Date: Mon, 10 Oct 2022 00:06:14 -0500 Subject: [PATCH 2/2] Overhauls serialization code --- CHANGELOG.md | 4 +- benchmark/Main.hs | 9 +- bitcoin.cabal | 15 +- package.yaml | 8 +- src/Bitcoin/Address.hs | 160 ++++---- src/Bitcoin/Address/Base58.hs | 47 ++- src/Bitcoin/Address/Bech32.hs | 4 +- src/Bitcoin/Block/Common.hs | 183 +++------ src/Bitcoin/Block/Headers.hs | 99 ++--- src/Bitcoin/Block/Merkle.hs | 58 ++- src/Bitcoin/Constants.hs | 25 +- src/Bitcoin/Crypto/Hash.hs | 122 +++--- src/Bitcoin/Crypto/Signature.hs | 32 +- src/Bitcoin/Data.hs | 12 +- src/Bitcoin/Keys/Common.hs | 78 ++-- src/Bitcoin/Keys/Extended.hs | 314 ++++++++------- src/Bitcoin/Keys/Extended/Internal.hs | 35 +- src/Bitcoin/Keys/Mnemonic.hs | 5 +- src/Bitcoin/Network/Bloom.hs | 119 ++---- src/Bitcoin/Network/Common.hs | 494 +++++++----------------- src/Bitcoin/Network/Message.hs | 162 ++++---- src/Bitcoin/Script/Common.hs | 55 +-- src/Bitcoin/Script/SigHash.hs | 98 +++-- src/Bitcoin/Script/Standard.hs | 81 ++-- src/Bitcoin/Transaction/Builder.hs | 69 +++- src/Bitcoin/Transaction/Builder/Sign.hs | 37 +- src/Bitcoin/Transaction/Common.hs | 233 +++++------ src/Bitcoin/Transaction/Partial.hs | 198 +++++----- src/Bitcoin/Transaction/Segwit.hs | 39 +- src/Bitcoin/Transaction/Taproot.hs | 77 ++-- src/Bitcoin/Util.hs | 127 +++--- src/Bitcoin/Util/Arbitrary/Address.hs | 4 +- src/Bitcoin/Util/Arbitrary/Crypto.hs | 18 +- src/Bitcoin/Util/Arbitrary/Network.hs | 64 ++- src/Bitcoin/Util/Arbitrary/Script.hs | 4 +- src/Bitcoin/Util/Arbitrary/Util.hs | 16 +- stack.yaml | 1 + stack.yaml.lock | 7 + test/Bitcoin/Address/Bech32Spec.hs | 4 +- test/Bitcoin/AddressSpec.hs | 71 ++-- test/Bitcoin/BlockSpec.hs | 77 +++- test/Bitcoin/Crypto/HashSpec.hs | 62 ++- test/Bitcoin/Crypto/SignatureSpec.hs | 76 +++- test/Bitcoin/Keys/ExtendedSpec.hs | 120 +++--- test/Bitcoin/Keys/MnemonicSpec.hs | 166 ++++---- test/Bitcoin/KeysSpec.hs | 121 ++++-- test/Bitcoin/NetworkSpec.hs | 78 +++- test/Bitcoin/Orphans.hs | 162 ++++---- test/Bitcoin/ScriptSpec.hs | 143 +++++-- test/Bitcoin/Transaction/PartialSpec.hs | 113 ++++-- test/Bitcoin/Transaction/TaprootSpec.hs | 24 +- test/Bitcoin/TransactionSpec.hs | 89 +++-- test/Bitcoin/UtilSpec.hs | 65 ++-- test/Spec.hs | 36 +- 54 files changed, 2373 insertions(+), 2147 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 5a64cb80..33f50440 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,9 +5,9 @@ All notable changes to this project will be documented in this file. The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). -## 0.1.0 +## 0.1.0 - Forked from `haskoin-core` 0.21.2 ### Changed -- Forked from `haskoin-core` 0.21.1 - Removed Bitcoin Cash support +- Stripped down serialization code diff --git a/benchmark/Main.hs b/benchmark/Main.hs index a157810e..51796b4f 100644 --- a/benchmark/Main.hs +++ b/benchmark/Main.hs @@ -14,8 +14,6 @@ import qualified Data.Binary as Bin import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BSL import Data.Proxy (Proxy (..)) -import Data.Serialize (Serialize) -import qualified Data.Serialize as S import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.IO as TIO @@ -58,7 +56,7 @@ main = do roundTrip :: forall a. - (NFData a, Binary a, Serialize a) => + (NFData a, Binary a) => Proxy a -> String -> Text -> @@ -71,11 +69,6 @@ roundTrip _ label xHex = [ bench "encode" $ nf Bin.encode x , bench "decode" $ nf binDecode xBytes ] - , bgroup - "cereal" - [ bench "encode" $ nf S.encode x - , bench "decode" $ nf (S.decode @a) xBytes - ] ] where Just !xBytes = decodeHex $ Text.filter (/= '\n') xHex diff --git a/bitcoin.cabal b/bitcoin.cabal index 2087ffb9..f8acc0f2 100644 --- a/bitcoin.cabal +++ b/bitcoin.cabal @@ -104,11 +104,9 @@ library , 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 , containers >=0.6.2.1 - , cryptonite >=0.26 + , cryptonite >=0.30 , deepseq >=1.4.4.0 , entropy >=0.4.1.5 , hashable >=1.3.0.0 @@ -160,17 +158,13 @@ test-suite spec , base64 ==0.4.* , binary >=0.8.8 , bitcoin - , bytes >=0.17 , bytestring >=0.10.10.0 - , cereal >=0.5.8 , containers >=0.6.2.1 - , cryptonite >=0.26 + , cryptonite >=0.30 , deepseq >=1.4.4.0 , entropy >=0.4.1.5 , hashable >=1.3.0.0 , hspec >=2.7.1 - , lens >=4.18.1 - , lens-aeson >=1.1 , memory >=0.15.0 , murmur3 >=1.0.3 , network >=3.1.1.1 @@ -185,7 +179,6 @@ test-suite spec , unordered-containers >=0.2.10.0 , vector >=0.12.1.2 default-language: Haskell2010 - build-tool-depends: hspec-discover:hspec-discover benchmark benchmark type: exitcode-stdio-1.0 @@ -201,12 +194,10 @@ benchmark benchmark , base16 >=0.3.0.1 , binary >=0.8.8 , bitcoin - , bytes >=0.17 , bytestring >=0.10.10.0 - , cereal >=0.5.8 , containers >=0.6.2.1 , criterion >=1.5 && <1.7 - , cryptonite >=0.26 + , cryptonite >=0.30 , deepseq >=1.4.4.0 , entropy >=0.4.1.5 , hashable >=1.3.0.0 diff --git a/package.yaml b/package.yaml index 769060e9..f69cd2dc 100644 --- a/package.yaml +++ b/package.yaml @@ -24,11 +24,9 @@ dependencies: - 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 - containers >= 0.6.2.1 - - cryptonite >= 0.26 + - cryptonite >= 0.30 - deepseq >= 1.4.4.0 - entropy >= 0.4.1.5 - hashable >= 1.3.0.0 @@ -57,8 +55,6 @@ tests: spec: main: Spec.hs source-dirs: test - verbatim: - build-tool-depends: hspec-discover:hspec-discover dependencies: - aeson >= 1.4.6.0 - base64 ^>= 0.4 @@ -66,8 +62,6 @@ tests: - hspec >= 2.7.1 - HUnit >= 1.6.0.0 - QuickCheck >= 2.13.2 - - lens-aeson >= 1.1 - - lens >= 4.18.1 benchmarks: benchmark: main: Main.hs diff --git a/src/Bitcoin/Address.hs b/src/Bitcoin/Address.hs index 29f83a7c..a2e645ef 100644 --- a/src/Bitcoin/Address.hs +++ b/src/Bitcoin/Address.hs @@ -45,24 +45,36 @@ module Bitcoin.Address ( import Bitcoin.Address.Base58 import Bitcoin.Address.Bech32 -import Bitcoin.Crypto -import Bitcoin.Data -import Bitcoin.Keys.Common -import Bitcoin.Script -import Bitcoin.Util -import Control.Applicative +import Bitcoin.Crypto (Hash160, Hash256, addressHash, addressHashL, sha256) +import Bitcoin.Data (Network (..)) +import Bitcoin.Keys.Common (PubKeyI) +import Bitcoin.Script ( + Script, + ScriptInput (..), + ScriptOutput (..), + SimpleInput (SpendPKHash), + decodeOutput, + decodeOutputBS, + encodeOutput, + encodeOutputBS, + toP2WSH, + ) +import Bitcoin.Util (eitherToMaybe, encodeHex, maybeToEither) +import qualified Bitcoin.Util as U +import Control.Applicative ((<|>)) import Control.Arrow (second) -import Control.DeepSeq -import Control.Monad -import Data.Binary (Binary (..)) +import Control.DeepSeq (NFData) +import Control.Monad ((<=<)) +import Data.Binary (Binary (..), Get, Put) +import qualified Data.Binary as Bin +import Data.Binary.Get (runGet) +import qualified Data.Binary.Get as Get +import Data.Binary.Put (runPut) +import qualified Data.Binary.Put as Put import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Hashable -import Data.Maybe -import Data.Serialize (Serialize (..)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.Hashable (Hashable) import Data.Text (Text) import qualified Data.Text as T import Data.Word (Word8) @@ -100,50 +112,41 @@ data Address (Eq, Ord, Generic, Show, Read, Hashable, NFData) -instance Serial Address where - serialize (PubKeyAddress k) = do - putWord8 0x00 - serialize k - serialize (ScriptAddress s) = do - putWord8 0x01 - serialize s - serialize (WitnessPubKeyAddress h) = do - putWord8 0x02 - serialize h - serialize (WitnessScriptAddress s) = do - putWord8 0x03 - serialize s - serialize (WitnessAddress v d) = do - putWord8 0x04 - putWord8 v - putWord64be (fromIntegral (B.length d)) - putByteString d - - - deserialize = - getWord8 >>= \case - 0x00 -> PubKeyAddress <$> deserialize - 0x01 -> ScriptAddress <$> deserialize - 0x02 -> WitnessPubKeyAddress <$> deserialize - 0x03 -> WitnessScriptAddress <$> deserialize +instance Binary Address where + put = \case + PubKeyAddress k -> do + Put.putWord8 0x00 + put k + ScriptAddress s -> do + Put.putWord8 0x01 + put s + WitnessPubKeyAddress h -> do + Put.putWord8 0x02 + put h + WitnessScriptAddress s -> do + Put.putWord8 0x03 + put s + WitnessAddress v d -> do + Put.putWord8 0x04 + Put.putWord8 v + Put.putWord64be (fromIntegral (BS.length d)) + Put.putByteString d + + + get = + Get.getWord8 >>= \case + 0x00 -> PubKeyAddress <$> get + 0x01 -> ScriptAddress <$> get + 0x02 -> WitnessPubKeyAddress <$> get + 0x03 -> WitnessScriptAddress <$> get 0x04 -> WitnessAddress - <$> getWord8 - <*> (getByteString . fromIntegral =<< getWord64be) + <$> Get.getWord8 + <*> (Get.getByteString . fromIntegral =<< Get.getWord64be) b -> fail . T.unpack $ "Could not decode address type byte: " - <> encodeHex (B.singleton b) - - -instance Serialize Address where - put = serialize - get = deserialize - - -instance Binary Address where - put = serialize - get = deserialize + <> encodeHex (BS.singleton b) -- | 'Address' pays to a public key hash. @@ -178,17 +181,17 @@ isWitnessAddress _ = False -- | Convert address to human-readable string. Uses 'Base58', or 'Bech32' -- depending on network. addrToText :: Network -> Address -> Maybe Text -addrToText net a@PubKeyAddress{} = Just . encodeBase58Check . runPutS $ base58put net a -addrToText net a@ScriptAddress{} = Just . encodeBase58Check . runPutS $ base58put net a +addrToText net a@PubKeyAddress{} = Just . encodeBase58Check . Put.runPut $ base58put net a +addrToText net a@ScriptAddress{} = Just . encodeBase58Check . Put.runPut $ base58put net a addrToText net WitnessPubKeyAddress{getAddrHash160 = h} = do hrp <- getBech32Prefix net - segwitEncode hrp 0 (B.unpack (runPutS $ serialize h)) + segwitEncode hrp 0 . BSL.unpack $ Bin.encode h addrToText net WitnessScriptAddress{getAddrHash256 = h} = do hrp <- getBech32Prefix net - segwitEncode hrp 0 (B.unpack (runPutS $ serialize h)) + segwitEncode hrp 0 . BSL.unpack $ Bin.encode h addrToText net WitnessAddress{getAddrVersion = v, getAddrData = d} = do hrp <- getBech32Prefix net - segwitEncode hrp v (B.unpack d) + segwitEncode hrp v (BS.unpack d) -- | Parse 'Base58', or 'Bech32' address, depending on network. @@ -200,24 +203,24 @@ textToAddr net txt = bech32ToAddr :: Network -> Text -> Maybe Address bech32ToAddr net txt = do hrp <- getBech32Prefix net - (ver, bs) <- second B.pack <$> segwitDecode hrp txt + (ver, bs) <- second BS.pack <$> segwitDecode hrp txt case ver of - 0 -> case B.length bs of - 20 -> WitnessPubKeyAddress <$> eitherToMaybe (runGetS deserialize bs) - 32 -> WitnessScriptAddress <$> eitherToMaybe (runGetS deserialize bs) + 0 -> case BS.length bs of + 20 -> WitnessPubKeyAddress <$> (eitherToMaybe . U.decode . BSL.fromStrict) bs + 32 -> WitnessScriptAddress <$> (eitherToMaybe . U.decode . BSL.fromStrict) bs _ -> Nothing _ -> Just $ WitnessAddress ver bs base58ToAddr :: Network -> Text -> Maybe Address base58ToAddr net txt = - eitherToMaybe . runGetS (base58get net) =<< decodeBase58Check txt + eitherToMaybe . U.runGet (base58get net) =<< decodeBase58Check txt -base58get :: MonadGet m => Network -> m Address +base58get :: Network -> Get Address base58get net = do - pfx <- getWord8 - addr <- deserialize + pfx <- Get.getWord8 + addr <- get f pfx addr where f x a @@ -226,19 +229,19 @@ base58get net = do | otherwise = fail "Does not recognize address prefix" -base58put :: MonadPut m => Network -> Address -> m () +base58put :: Network -> Address -> Put base58put net (PubKeyAddress h) = do - putWord8 (getAddrPrefix net) - serialize h + Put.putWord8 (getAddrPrefix net) + put h base58put net (ScriptAddress h) = do - putWord8 (getScriptPrefix net) - serialize h + Put.putWord8 (getScriptPrefix net) + put h base58put _ _ = error "Cannot serialize this address as Base58" -- | Obtain a standard pay-to-public-key-hash address from a public key. pubKeyAddr :: PubKeyI -> Address -pubKeyAddr = PubKeyAddress . addressHash . runPutS . serialize +pubKeyAddr = PubKeyAddress . addressHashL . Bin.encode -- | Obtain a standard pay-to-public-key-hash (P2PKH) address from a 'Hash160'. @@ -249,7 +252,7 @@ p2pkhAddr = PubKeyAddress -- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a -- public key. pubKeyWitnessAddr :: PubKeyI -> Address -pubKeyWitnessAddr = WitnessPubKeyAddress . addressHash . runPutS . serialize +pubKeyWitnessAddr = WitnessPubKeyAddress . addressHashL . Bin.encode -- | Obtain a backwards-compatible SegWit P2SH-P2WPKH address from a public key. @@ -259,9 +262,8 @@ pubKeyCompatWitnessAddr = . addressHash . encodeOutputBS . PayWitnessPKHash - . addressHash - . runPutS - . serialize + . addressHashL + . Bin.encode -- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a @@ -316,7 +318,7 @@ addressToScript = encodeOutput . addressToOutput -- | Encode address as output script in 'ByteString' form. addressToScriptBS :: Address -> ByteString -addressToScriptBS = runPutS . serialize . addressToScript +addressToScriptBS = U.encodeS . addressToScript -- | Decode an output script into an 'Address' if it has such representation. diff --git a/src/Bitcoin/Address/Base58.hs b/src/Bitcoin/Address/Base58.hs index 314e11f7..2342833f 100644 --- a/src/Bitcoin/Address/Base58.hs +++ b/src/Bitcoin/Address/Base58.hs @@ -14,22 +14,21 @@ module Bitcoin.Address.Base58 ( decodeBase58Check, ) where -import Bitcoin.Crypto.Hash -import Bitcoin.Util -import Control.Monad -import Data.Array +import Bitcoin.Crypto.Hash (checkSum32) +import Bitcoin.Util (bsToInteger, integerToBS) +import Control.Monad (guard) +import Data.Array (Array, assocs, listArray, (!), (//)) +import qualified Data.Binary as Bin import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Char +import qualified Data.ByteString.Lazy as BSL +import Data.Char (chr, ord) import Data.Maybe (fromMaybe, isJust, listToMaybe) import Data.String.Conversions (cs) import Data.Text (Text) import qualified Data.Text as T -import Data.Word +import Data.Word (Word8) import Numeric (readInt, showIntAtBase) @@ -84,42 +83,42 @@ decodeBase58I s = -- | Encode an arbitrary 'ByteString' into a its 'Base58' representation, -- preserving leading zeroes. -encodeBase58 :: ByteString -> Base58 +encodeBase58 :: BSL.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 + (z, b) = BSL.span (== 0) bs + l = cs $ BSL.replicate (BSL.length z) (b58 0) -- preserve leading 0's r - | BS.null b = T.empty + | BSL.null b = T.empty | otherwise = encodeBase58I $ bsToInteger b -- | Decode a 'Base58'-encoded 'Text' to a 'ByteString'. -decodeBase58 :: Base58 -> Maybe ByteString +decodeBase58 :: Base58 -> Maybe BSL.ByteString decodeBase58 t = - BS.append prefix <$> r + BSL.append prefix <$> r where - (z, b) = BS.span (== b58 0) (cs t) - prefix = BS.replicate (BS.length z) 0 -- preserve leading 1's + (z, b) = BSL.span (== b58 0) (cs t) + prefix = BSL.replicate (BSL.length z) 0 -- preserve leading 1's r - | BS.null b = Just BS.empty - | otherwise = integerToBS <$> decodeBase58I (cs b) + | BSL.null b = Just mempty + | otherwise = BSL.fromStrict . integerToBS <$> decodeBase58I (cs b) -- | Computes a checksum for the input 'ByteString' and encodes the input and -- the checksum as 'Base58'. -encodeBase58Check :: ByteString -> Base58 +encodeBase58Check :: BSL.ByteString -> Base58 encodeBase58Check bs = - encodeBase58 $ BS.append bs $ runPutS $ serialize $ checkSum32 bs + encodeBase58 . BSL.append bs . Bin.encode $ checkSum32 bs -- | Decode a 'Base58'-encoded string that contains a checksum. This function -- returns 'Nothing' if the input string contains invalid 'Base58' characters or -- if the checksum fails. -decodeBase58Check :: Base58 -> Maybe ByteString +decodeBase58Check :: Base58 -> Maybe BSL.ByteString decodeBase58Check bs = do rs <- decodeBase58 bs - let (res, chk) = BS.splitAt (BS.length rs - 4) rs - guard $ chk == runPutS (serialize (checkSum32 res)) + let (res, chk) = BSL.splitAt (BSL.length rs - 4) rs + guard $ chk == Bin.encode (checkSum32 res) return res diff --git a/src/Bitcoin/Address/Bech32.hs b/src/Bitcoin/Address/Bech32.hs index a7ec0227..b2cc96bb 100644 --- a/src/Bitcoin/Address/Bech32.hs +++ b/src/Bitcoin/Address/Bech32.hs @@ -49,7 +49,7 @@ import Data.Bits ( (.&.), (.|.), ) -import qualified Data.ByteString as B +import qualified Data.ByteString as BS import Data.Char (toUpper) import Data.Foldable (foldl') import Data.Functor.Identity (Identity, runIdentity) @@ -143,7 +143,7 @@ bech32HRPExpand hrp = ++ [UnsafeWord5 0] ++ map word5 hrpBytes where - hrpBytes = B.unpack $ E.encodeUtf8 hrp + hrpBytes = BS.unpack $ E.encodeUtf8 hrp bech32Const :: Bech32Encoding -> Word diff --git a/src/Bitcoin/Block/Common.hs b/src/Bitcoin/Block/Common.hs index 50fc3eb9..6711574f 100644 --- a/src/Bitcoin/Block/Common.hs +++ b/src/Bitcoin/Block/Common.hs @@ -26,33 +26,26 @@ module Bitcoin.Block.Common ( encodeCompact, ) where -import Bitcoin.Crypto.Hash -import Bitcoin.Network.Common -import Bitcoin.Transaction.Common -import Bitcoin.Util -import Control.DeepSeq -import Control.Monad (forM_, liftM2, mzero, replicateM, (<=<)) -import Data.Binary (Binary (..)) -import Data.Bits (shiftL, shiftR, (.&.), (.|.)) -import qualified Data.ByteString as B -import Data.ByteString.Builder (char7) -import qualified Data.ByteString.Lazy as BL -import Data.Bytes.Get ( - MonadGet, - getWord32le, - runGetL, - runGetS, - ) -import Data.Bytes.Put ( - MonadPut, - putWord32le, - runPutL, - runPutS, +import Bitcoin.Crypto.Hash (Hash256, doubleSHA256L) +import Bitcoin.Network.Common (VarInt (VarInt), putVarInt) +import Bitcoin.Transaction.Common (Tx) +import Bitcoin.Util ( + decodeHex, + eitherToMaybe, + encodeHex, ) -import Data.Bytes.Serial (Serial (..)) +import qualified Bitcoin.Util as U +import Control.DeepSeq (NFData) +import Control.Monad (forM_, liftM2, replicateM, (>=>)) +import Data.Binary (Binary (..), Put) +import qualified Data.Binary as Bin +import Data.Binary.Get (getWord32le) +import Data.Binary.Put (putWord32le) +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL 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,43 +70,23 @@ data Block = Block deriving (Eq, Show, Read, Generic, Hashable, NFData) -instance Serial Block where - deserialize = do - header <- deserialize - (VarInt c) <- deserialize - txs <- replicateM (fromIntegral c) deserialize +instance Binary Block where + get = do + header <- get + (VarInt c) <- get + txs <- replicateM (fromIntegral c) get return $ Block header txs - serialize (Block h txs) = do - serialize h + put (Block h txs) = do + put h putVarInt $ length txs - forM_ txs serialize - - -instance Serialize Block where - get = deserialize - put = serialize - - -instance Binary Block where - get = deserialize - put = serialize + mapM_ put txs -- | Block header hash. To be serialized reversed for display purposes. newtype BlockHash = BlockHash { getBlockHash :: Hash256 } - deriving (Eq, Ord, Generic, Hashable, Serial, NFData) - - -instance Serialize BlockHash where - put = serialize - get = deserialize - - -instance Binary BlockHash where - put = serialize - get = deserialize + deriving (Eq, Ord, Generic, Hashable, Binary, NFData) instance Show BlockHash where @@ -135,16 +108,19 @@ instance IsString BlockHash where -- | 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))) +blockHashToHex = encodeHex . BS.reverse . U.encodeS . getBlockHash -- | 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 +hexToBlockHash = + decodeHex + >=> fmap BlockHash + . eitherToMaybe + . U.decode + . BSL.fromStrict + . BS.reverse -- | Data type recording information of a 'Block'. The hash of a block is @@ -174,11 +150,11 @@ data BlockHeader = BlockHeader deriving (Eq, Ord, Show, Read, Generic, Hashable, NFData) -instance Serial BlockHeader where - deserialize = do +instance Binary BlockHeader where + get = do v <- getWord32le - p <- deserialize - m <- deserialize + p <- get + m <- get t <- getWord32le b <- getWord32le n <- getWord32le @@ -191,28 +167,18 @@ instance Serial BlockHeader where , blockBits = b , bhNonce = n } - serialize (BlockHeader v p m bt bb n) = do + put (BlockHeader v p m bt bb n) = do putWord32le v - serialize p - serialize m + put p + put m putWord32le bt 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 +headerHash = BlockHash . doubleSHA256L . Bin.encode -- | A block locator is a set of block headers, denser towards the best block @@ -240,28 +206,23 @@ data GetBlocks = GetBlocks deriving (Eq, Show, Read, Generic, NFData) -instance Serial GetBlocks where - deserialize = +instance Binary GetBlocks where + get = GetBlocks <$> getWord32le - <*> (repList =<< deserialize) - <*> deserialize + <*> (repList =<< get) + <*> get 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 + repList (VarInt c) = replicateM (fromIntegral c) get + put (GetBlocks v xs h) = putGetBlockMsg v xs h -putGetBlockMsg :: MonadPut m => Word32 -> BlockLocator -> BlockHash -> m () +putGetBlockMsg :: Word32 -> BlockLocator -> BlockHash -> Put putGetBlockMsg v xs h = do putWord32le v putVarInt $ length xs - forM_ xs serialize - serialize h + mapM_ put xs + put h -- | Similar to the 'GetBlocks' message type but for retrieving block headers @@ -279,25 +240,15 @@ data GetHeaders = GetHeaders deriving (Eq, Show, Read, Generic, NFData) -instance Serial GetHeaders where - deserialize = +instance Binary GetHeaders where + get = GetHeaders <$> getWord32le - <*> (repList =<< deserialize) - <*> deserialize + <*> (repList =<< get) + <*> get 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 + repList (VarInt c) = replicateM (fromIntegral c) get + put (GetHeaders v xs h) = putGetBlockMsg v xs h -- | 'BlockHeader' type with a transaction count as 'VarInt' @@ -313,24 +264,14 @@ newtype Headers = Headers deriving (Eq, Show, Read, Generic, NFData) -instance Serial Headers where - deserialize = Headers <$> (repList =<< deserialize) +instance Binary Headers where + get = Headers <$> (repList =<< get) where repList (VarInt c) = replicateM (fromIntegral c) action - action = liftM2 (,) deserialize deserialize - serialize (Headers xs) = do + action = liftM2 (,) get get + put (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 + forM_ xs $ \(a, b) -> put a >> put b -- | Decode the compact number used in the difficulty target of a block. diff --git a/src/Bitcoin/Block/Headers.hs b/src/Bitcoin/Block/Headers.hs index 2190aec9..a4f11d31 100644 --- a/src/Bitcoin/Block/Headers.hs +++ b/src/Bitcoin/Block/Headers.hs @@ -60,36 +60,51 @@ module Bitcoin.Block.Headers ( lastSmallerOrEqual, ) where -import Bitcoin.Block.Common -import Bitcoin.Crypto -import Bitcoin.Data -import Bitcoin.Transaction.Genesis -import Bitcoin.Util +import Bitcoin.Block.Common ( + Block (Block), + BlockHash, + BlockHeader (..), + BlockHeight, + BlockLocator, + Timestamp, + decodeCompact, + encodeCompact, + headerHash, + ) +import Bitcoin.Crypto (sha256, sha256L) +import Bitcoin.Data ( + Network (..), + ) +import Bitcoin.Transaction.Genesis (genesisTx) +import Bitcoin.Util ( + bsToInteger, + eitherToMaybe, + getInteger, + putInteger, + ) +import qualified Bitcoin.Util as U import Control.Applicative ((<|>)) -import Control.DeepSeq +import Control.DeepSeq (NFData) import Control.Monad (guard, mzero, unless, when) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE) -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.State.Strict as State (StateT, get, gets, modify) +import Control.Monad.Trans.Maybe (MaybeT (..), maybeToExceptT) +import Control.Monad.Trans.State.Strict (StateT) +import qualified Control.Monad.Trans.State.Strict as State import Data.Binary (Binary (..)) +import qualified Data.Binary as Bin +import Data.Binary.Get (getWord32le) +import Data.Binary.Put (putWord32le) import Data.Bits (shiftL, shiftR, (.&.)) -import qualified Data.ByteString as B -import Data.ByteString.Short ( - ShortByteString, - fromShort, - toShort, - ) -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.ByteString.Short (ShortByteString, fromShort, toShort) import Data.Function (on) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.Hashable +import Data.Hashable (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) @@ -123,9 +138,9 @@ data BlockNode = BlockNode deriving (Show, Read, Generic, Hashable, NFData) -instance Serial BlockNode where - deserialize = do - nodeHeader <- deserialize +instance Binary BlockNode where + get = do + nodeHeader <- get nodeHeight <- getWord32le nodeWork <- getInteger if nodeHeight == 0 @@ -133,25 +148,15 @@ instance Serial BlockNode where let nodeSkip = headerHash nodeHeader return BlockNode{..} else do - nodeSkip <- deserialize + nodeSkip <- get return BlockNode{..} - serialize bn = do - serialize $ nodeHeader bn + put bn = do + put $ nodeHeader bn putWord32le $ nodeHeight bn putInteger $ nodeWork bn case nodeHeight bn of 0 -> return () - _ -> serialize $ nodeSkip bn - - -instance Serialize BlockNode where - put = serialize - get = deserialize - - -instance Binary BlockNode where - put = serialize - get = deserialize + _ -> put $ nodeSkip bn instance Eq BlockNode where @@ -194,10 +199,10 @@ class Monad m => BlockHeaders m where instance Monad m => BlockHeaders (StateT HeaderMemory m) where - addBlockHeader = modify . addBlockHeaderMemory + addBlockHeader = State.modify' . addBlockHeaderMemory getBlockHeader bh = getBlockHeaderMemory bh <$> State.get - getBestBlockHeader = gets memoryBestHeader - setBestBlockHeader bn = modify $ \s -> s{memoryBestHeader = bn} + getBestBlockHeader = State.gets memoryBestHeader + setBestBlockHeader bn = State.modify' $ \s -> s{memoryBestHeader = bn} -- | Initialize memory-based chain. @@ -214,7 +219,7 @@ genesisMap :: Network -> BlockMap genesisMap net = HashMap.singleton (shortBlockHash (headerHash (getGenesisHeader net))) - (toShort (runPutS (serialize (genesisNode net)))) + $ encodeToShort (genesisNode net) -- | Add block header to memory block map. @@ -228,7 +233,7 @@ addBlockHeaderMemory bn s@HeaderMemory{..} = getBlockHeaderMemory :: BlockHash -> HeaderMemory -> Maybe BlockNode getBlockHeaderMemory bh HeaderMemory{..} = do bs <- shortBlockHash bh `HashMap.lookup` memoryHeaderMap - eitherToMaybe . runGetS deserialize $ fromShort bs + eitherToMaybe . U.decode . BSL.fromStrict $ fromShort bs -- | Calculate short block hash taking eight non-zero bytes from the 16-byte @@ -236,7 +241,7 @@ getBlockHeaderMemory bh HeaderMemory{..} = do -- hash, making colissions between short block hashes difficult. shortBlockHash :: BlockHash -> ShortBlockHash shortBlockHash = - either error id . runGetS deserialize . B.take 8 . runPutS . serialize + either error id . U.decode . BSL.take 8 . Bin.encode -- | Add a block to memory-based block map. @@ -244,7 +249,7 @@ addBlockToMap :: BlockNode -> BlockMap -> BlockMap addBlockToMap node = HashMap.insert (shortBlockHash $ headerHash $ nodeHeader node) - (toShort $ runPutS $ serialize node) + $ encodeToShort node -- | Get the ancestor of the provided 'BlockNode' at the specified @@ -776,7 +781,7 @@ isValidPOW net h -- | Returns the proof of work of a block header hash as an 'Integer' number. blockPOW :: BlockHash -> Integer -blockPOW = bsToInteger . B.reverse . runPutS . serialize +blockPOW = bsToInteger . BSL.reverse . Bin.encode -- | Returns the work represented by this block. Work is defined as the number @@ -862,7 +867,7 @@ appendBlocks net seed bh i = bh { prevBlock = headerHash bh , -- Just to make it different in every header - merkleRoot = sha256 $ runPutS $ serialize seed + merkleRoot = sha256L $ Bin.encode seed } @@ -898,3 +903,7 @@ computeSubsidy net height = in if halvings >= 64 then 0 else ini `shiftR` fromIntegral halvings + + +encodeToShort :: Binary a => a -> ShortByteString +encodeToShort = toShort . U.encodeS diff --git a/src/Bitcoin/Block/Merkle.hs b/src/Bitcoin/Block/Merkle.hs index da0e44a3..a55853ef 100644 --- a/src/Bitcoin/Block/Merkle.hs +++ b/src/Bitcoin/Block/Merkle.hs @@ -29,25 +29,23 @@ module Bitcoin.Block.Merkle ( boolsToWord8, ) where -import Bitcoin.Block.Common -import Bitcoin.Crypto.Hash -import Bitcoin.Data -import Bitcoin.Network.Common -import Bitcoin.Transaction.Common -import Control.DeepSeq +import Bitcoin.Block.Common (BlockHeader (merkleRoot)) +import Bitcoin.Crypto.Hash (Hash256, doubleSHA256, doubleSHA256L) +import Bitcoin.Data (Network (getMaxBlockSize)) +import Bitcoin.Network.Common (VarInt (VarInt), putVarInt) +import Bitcoin.Transaction.Common (TxHash (..)) +import Control.DeepSeq (NFData) import Control.Monad (forM_, replicateM, when) import Data.Binary (Binary (..)) -import Data.Bits +import Data.Binary.Get (getWord32le, getWord8) +import Data.Binary.Put (putWord32le, putWord8, runPut) +import Data.Bits (Bits (setBit, shiftL, shiftR, testBit)) import qualified Data.ByteString as BS -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial import Data.Either (isRight) -import Data.Hashable -import Data.Maybe -import Data.Serialize (Serialize (..)) +import Data.Hashable (Hashable) +import Data.Maybe (fromMaybe, isNothing) import Data.Word (Word32, Word8) -import GHC.Generics +import GHC.Generics (Generic) -- | Hash of the block's Merkle root. @@ -77,35 +75,25 @@ data MerkleBlock = MerkleBlock deriving (Eq, Show, Read, Generic, Hashable, NFData) -instance Serial MerkleBlock where - deserialize = do - header <- deserialize +instance Binary MerkleBlock where + get = do + header <- get ntx <- getWord32le - (VarInt matchLen) <- deserialize - hashes <- replicateM (fromIntegral matchLen) deserialize - (VarInt flagLen) <- deserialize + (VarInt matchLen) <- get + hashes <- replicateM (fromIntegral matchLen) get + (VarInt flagLen) <- get ws <- replicateM (fromIntegral flagLen) getWord8 return $ MerkleBlock header ntx hashes (decodeMerkleFlags ws) - serialize (MerkleBlock h ntx hashes flags) = do - serialize h + put (MerkleBlock h ntx hashes flags) = do + put h putWord32le ntx putVarInt $ length hashes - forM_ hashes serialize + mapM_ put hashes let ws = encodeMerkleFlags flags putVarInt $ length ws - forM_ ws putWord8 - - -instance Binary MerkleBlock where - put = serialize - get = deserialize - - -instance Serialize MerkleBlock where - put = serialize - get = deserialize + mapM_ putWord8 ws -- | Unpack Merkle flags into 'FlagBits' structure. @@ -155,7 +143,7 @@ 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) +hash2 a b = doubleSHA256L . runPut $ put a >> put b -- | Computes the hash of a specific node in a Merkle tree. diff --git a/src/Bitcoin/Constants.hs b/src/Bitcoin/Constants.hs index d9483edc..e8c15aaf 100644 --- a/src/Bitcoin/Constants.hs +++ b/src/Bitcoin/Constants.hs @@ -17,24 +17,13 @@ module Bitcoin.Constants ( netByName, ) where -import Bitcoin.Block -import Bitcoin.Data -import Bitcoin.Network.Common -import Bitcoin.Transaction -import Control.DeepSeq -import Data.Binary (Binary (..)) -import Data.ByteString (ByteString) -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.List -import Data.Maybe -import Data.Serialize (Serialize (..)) -import Data.String -import Data.Text (Text) -import Data.Word (Word32, Word64, Word8) -import GHC.Generics (Generic) -import Text.Read +import Bitcoin.Block.Common (BlockHeader (BlockHeader)) +import Bitcoin.Block.Merkle (buildMerkleRoot) +import Bitcoin.Data (Network (..)) +import Bitcoin.Transaction.Common (txHash) +import Bitcoin.Transaction.Genesis (genesisTx) +import Data.List (find) +import Data.String (IsString) -- | Version of Bitcoin package. diff --git a/src/Bitcoin/Crypto/Hash.hs b/src/Bitcoin/Crypto/Hash.hs index a6daa3f5..1146b968 100644 --- a/src/Bitcoin/Crypto/Hash.hs +++ b/src/Bitcoin/Crypto/Hash.hs @@ -16,66 +16,63 @@ module Bitcoin.Crypto.Hash ( CheckSum32 (getCheckSum32), sha512, sha256, + sha256L, ripemd160, sha1, doubleSHA256, + doubleSHA256L, addressHash, + addressHashL, checkSum32, hmac512, + hmac512L, hmac256, split512, join512, initTaggedHash, ) where -import Bitcoin.Util -import Control.DeepSeq +import Bitcoin.Util (decodeHex, encodeHex) +import qualified Bitcoin.Util as U +import Control.DeepSeq (NFData) import Crypto.Hash ( Context, + Digest, + HashAlgorithm, RIPEMD160 (..), SHA1 (..), SHA256 (..), SHA512 (..), + hashFinalize, hashInit, hashUpdates, hashWith, ) -import Crypto.MAC.HMAC (HMAC, hmac) +import Crypto.MAC.HMAC (HMAC, hmac, hmacLazy) import Data.Binary (Binary (..)) +import qualified Data.Binary.Get as Get +import qualified Data.Binary.Put as Put import Data.ByteArray (ByteArrayAccess) import qualified Data.ByteArray as BA import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL import Data.ByteString.Short (ShortByteString) import qualified Data.ByteString.Short as BSS -import qualified Data.Bytes.Get as Get -import qualified Data.Bytes.Put as Put -import Data.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) import GHC.Generics (Generic) -import Text.Read as R +import qualified 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 + deriving (Eq, Ord, Binary, Show, Read, Hashable, Generic, NFData) -- | Type for 512-bit hashes. @@ -99,8 +96,8 @@ instance Show Hash512 where instance Read Hash512 where readPrec = do - R.String str <- lexP - maybe pfail (return . Hash512 . BSS.toShort) (decodeHex (cs str)) + R.String str <- R.lexP + maybe R.pfail (return . Hash512 . BSS.toShort) (decodeHex (cs str)) instance Show Hash256 where @@ -109,8 +106,8 @@ instance Show Hash256 where instance Read Hash256 where readPrec = do - R.String str <- lexP - maybe pfail (return . Hash256 . BSS.toShort) (decodeHex (cs str)) + R.String str <- R.lexP + maybe R.pfail (return . Hash256 . BSS.toShort) (decodeHex (cs str)) instance Show Hash160 where @@ -119,8 +116,8 @@ instance Show Hash160 where instance Read Hash160 where readPrec = do - R.String str <- lexP - maybe pfail (return . Hash160 . BSS.toShort) (decodeHex (cs str)) + R.String str <- R.lexP + maybe R.pfail (return . Hash160 . BSS.toShort) (decodeHex (cs str)) instance IsString Hash512 where @@ -135,19 +132,9 @@ instance IsString Hash512 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 + get = Hash512 . BSS.toShort <$> Get.getByteString 64 + put = Put.putByteString . BSS.fromShort . getHash512 instance IsString Hash256 where @@ -162,19 +149,9 @@ instance IsString Hash256 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 + get = Hash256 . BSS.toShort <$> Get.getByteString 32 + put = Put.putByteString . BSS.fromShort . getHash256 instance IsString Hash160 where @@ -189,19 +166,14 @@ instance IsString Hash160 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 + get = Hash160 . BSS.toShort <$> Get.getByteString 20 + put = Put.putByteString . BSS.fromShort . getHash160 -instance Binary Hash160 where - put = serialize - get = deserialize +-- | Use this function to produce hashes during the process of serialization +hashWithL :: HashAlgorithm alg => alg -> BSL.ByteString -> Digest alg +hashWithL _ = hashFinalize . hashUpdates hashInit . BSL.toChunks -- | Calculate SHA512 hash. @@ -214,6 +186,11 @@ sha256 :: ByteArrayAccess b => b -> Hash256 sha256 = Hash256 . BSS.toShort . BA.convert . hashWith SHA256 +-- | Calculate SHA256 hash, lazy version. +sha256L :: BSL.ByteString -> Hash256 +sha256L = Hash256 . BSS.toShort . BA.convert . hashWithL SHA256 + + -- | Calculate RIPEMD160 hash. ripemd160 :: ByteArrayAccess b => b -> Hash160 ripemd160 = Hash160 . BSS.toShort . BA.convert . hashWith RIPEMD160 @@ -230,23 +207,36 @@ doubleSHA256 = Hash256 . BSS.toShort . BA.convert . hashWith SHA256 . hashWith SHA256 +-- | Compute two rounds of SHA-256, lazy version. +doubleSHA256L :: BSL.ByteString -> Hash256 +doubleSHA256L = + Hash256 . BSS.toShort . BA.convert . hashWith SHA256 . hashWithL SHA256 + + -- | Compute SHA-256 followed by RIPMED-160. addressHash :: ByteArrayAccess b => b -> Hash160 addressHash = Hash160 . BSS.toShort . BA.convert . hashWith RIPEMD160 . hashWith SHA256 +-- | Compute SHA-256 followed by RIPMED-160, lazy version. +addressHashL :: BSL.ByteString -> Hash160 +addressHashL = + Hash160 . BSS.toShort . BA.convert . hashWith RIPEMD160 . hashWithL SHA256 + + {- CheckSum -} -- | Computes a 32 bit checksum. -checkSum32 :: ByteArrayAccess b => b -> CheckSum32 +checkSum32 :: BSL.ByteString -> CheckSum32 checkSum32 = fromRight (error "Could not decode bytes as CheckSum32") - . Get.runGetS deserialize + . U.decode + . BSL.fromStrict . BS.take 4 . BA.convert . hashWith SHA256 - . hashWith SHA256 + . hashWithL SHA256 {- HMAC -} @@ -257,6 +247,12 @@ hmac512 key msg = Hash512 $ BSS.toShort $ BA.convert (hmac key msg :: HMAC SHA512) +-- | Computes HMAC over SHA-512. +hmac512L :: ByteString -> BSL.ByteString -> Hash512 +hmac512L key = + Hash512 . BSS.toShort . BA.convert . hmacLazy @_ @SHA512 key + + -- | Computes HMAC over SHA-256. hmac256 :: (ByteArrayAccess k, ByteArrayAccess m) => k -> m -> Hash256 hmac256 key msg = diff --git a/src/Bitcoin/Crypto/Signature.hs b/src/Bitcoin/Crypto/Signature.hs index 8fec1102..655978bf 100644 --- a/src/Bitcoin/Crypto/Signature.hs +++ b/src/Bitcoin/Crypto/Signature.hs @@ -17,24 +17,34 @@ module Bitcoin.Crypto.Signature ( exportSig, ) where -import Bitcoin.Crypto.Hash +import Bitcoin.Crypto.Hash (Hash256) +import qualified Bitcoin.Util as U import Control.Monad (guard, unless, when) -import Crypto.Secp256k1 -import Data.Binary (Binary (..)) +import Crypto.Secp256k1 ( + CompactSig (getCompactSig), + Msg, + PubKey, + SecKey, + Sig, + exportCompactSig, + exportSig, + importSig, + msg, + normalizeSig, + signMsg, + verifySig, + ) +import Data.Binary.Get (Get, getByteString, getWord8, lookAhead) +import Data.Binary.Put (Put, putByteString) 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 Numeric (showHex) -- | Convert 256-bit hash into a 'Msg' for signing or verification. hashToMsg :: Hash256 -> Msg -hashToMsg = - fromMaybe e . msg . runPutS . serialize +hashToMsg = fromMaybe e . msg . U.encodeS where e = error "Could not convert 32-byte hash to secp256k1 message" @@ -52,7 +62,7 @@ verifyHashSig h s p = verifySig p norm (hashToMsg h) -- | Deserialize an ECDSA signature as commonly encoded in Bitcoin. -getSig :: MonadGet m => m Sig +getSig :: Get Sig getSig = do l <- lookAhead $ do @@ -72,7 +82,7 @@ getSig = do -- | Serialize an ECDSA signature for Bitcoin use. -putSig :: MonadPut m => Sig -> m () +putSig :: Sig -> Put putSig s = putByteString $ exportSig s diff --git a/src/Bitcoin/Data.hs b/src/Bitcoin/Data.hs index e920ec26..85573f6e 100644 --- a/src/Bitcoin/Data.hs +++ b/src/Bitcoin/Data.hs @@ -5,20 +5,12 @@ module Bitcoin.Data ( Network (..), ) where -import Bitcoin.Block.Common -import Control.DeepSeq -import Data.Binary (Binary (..)) +import Bitcoin.Block.Common (BlockHash, BlockHeader, BlockHeight) +import Control.DeepSeq (NFData) import Data.ByteString (ByteString) -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.List -import Data.Serialize (Serialize (..)) -import Data.String import Data.Text (Text) import Data.Word (Word32, Word64, Word8) import GHC.Generics (Generic) -import Text.Read -- | Network definition. diff --git a/src/Bitcoin/Keys/Common.hs b/src/Bitcoin/Keys/Common.hs index 5aa9f5e0..b256d5c8 100644 --- a/src/Bitcoin/Keys/Common.hs +++ b/src/Bitcoin/Keys/Common.hs @@ -31,23 +31,39 @@ module Bitcoin.Keys.Common ( toWif, ) where -import Bitcoin.Address.Base58 -import Bitcoin.Crypto.Hash -import Bitcoin.Data -import Bitcoin.Util -import Control.DeepSeq +import Bitcoin.Address.Base58 ( + Base58, + decodeBase58Check, + encodeBase58Check, + ) +import Bitcoin.Crypto.Hash (Hash256, sha256) +import Bitcoin.Data (Network (getSecretPrefix)) +import Bitcoin.Util (decodeHex, eitherToMaybe) +import qualified Bitcoin.Util as U +import Control.DeepSeq (NFData) import Control.Monad (guard, mzero, (<=<)) -import Crypto.Secp256k1 +import Crypto.Hash (hashWith) +import Crypto.Hash.Algorithms (SHA256 (SHA256)) +import Crypto.Secp256k1 ( + PubKey, + SecKey (..), + derivePubKey, + exportPubKey, + importPubKey, + secKey, + tweak, + tweakAddPubKey, + tweakAddSecKey, + ) import Data.Binary (Binary (..)) +import Data.Binary.Get (getByteString, getWord8, lookAhead) +import Data.Binary.Put (putByteString) +import qualified Data.ByteArray as BA import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import Data.ByteString.Builder (char7) -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Hashable +import qualified Data.ByteString.Lazy as BSL +import Data.Hashable (Hashable) import Data.Maybe (fromMaybe) -import Data.Serialize (Serialize (..)) import Data.String (IsString, fromString) import Data.String.Conversions (cs) import GHC.Generics (Generic) @@ -63,13 +79,13 @@ data PubKeyI = PubKeyI instance IsString PubKeyI where fromString str = - fromMaybe e $ eitherToMaybe . runGetS deserialize <=< decodeHex $ cs str + fromMaybe e $ eitherToMaybe . U.decode . BSL.fromStrict =<< decodeHex (cs str) where e = error "Could not decode public key" -instance Serial PubKeyI where - deserialize = +instance Binary PubKeyI where + get = s >>= \case True -> c False -> u @@ -91,17 +107,7 @@ instance Serial PubKeyI where PubKeyI <$> importPubKey bs <*> pure False - serialize pk = putByteString $ exportPubKey (pubKeyCompressed pk) (pubKeyPoint pk) - - -instance Serialize PubKeyI where - put = serialize - get = deserialize - - -instance Binary PubKeyI where - put = serialize - get = deserialize + put pk = putByteString $ (exportPubKey <$> pubKeyCompressed <*> pubKeyPoint) pk -- | Wrap a public key from secp256k1 library adding information about compression. @@ -117,7 +123,7 @@ 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)) +tweakPubKey p = tweakAddPubKey p <=< tweak . U.encodeS -- | Elliptic curve private key type with expected public key compression @@ -138,16 +144,16 @@ wrapSecKey c d = SecKeyI d c -- | Tweak a private key. tweakSecKey :: SecKey -> Hash256 -> Maybe SecKey -tweakSecKey key h = tweakAddSecKey key =<< tweak (runPutS (serialize h)) +tweakSecKey key = tweakAddSecKey key <=< tweak . U.encodeS -- | 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))) + wrapSecKey False <$> (secKey . BA.convert . hashWith SHA256) bs where - checkHash = runPutS $ serialize $ sha256 $ bs `BS.append` "?" + checkHash = BA.convert . hashWith SHA256 $ bs `BS.append` "?" checkShortKey = BS.length bs `elem` [22, 30] && BS.head checkHash == 0x00 @@ -156,14 +162,14 @@ fromWif :: Network -> Base58 -> Maybe SecKeyI fromWif net wif = do bs <- decodeBase58Check wif -- Check that this is a private key - guard (BS.head bs == getSecretPrefix net) - case BS.length bs of + guard (BSL.head bs == getSecretPrefix net) + case BSL.length bs of -- Uncompressed format - 33 -> wrapSecKey False <$> secKey (BS.tail bs) + 33 -> wrapSecKey False <$> (secKey . BSL.toStrict) (BSL.tail bs) -- Compressed format 34 -> do - guard $ BS.last bs == 0x01 - wrapSecKey True <$> secKey (BS.tail $ BS.init bs) + guard $ BSL.last bs == 0x01 + wrapSecKey True <$> (secKey . BS.tail . BS.init . BSL.toStrict) bs -- Bad length _ -> Nothing @@ -171,7 +177,7 @@ fromWif net wif = do -- | Encode private key into a WIF string. toWif :: Network -> SecKeyI -> Base58 toWif net (SecKeyI k c) = - encodeBase58Check . BS.cons (getSecretPrefix net) $ + encodeBase58Check . BSL.cons (getSecretPrefix net) . BSL.fromStrict $ if c then getSecKey k `BS.snoc` 0x01 else getSecKey k diff --git a/src/Bitcoin/Keys/Extended.hs b/src/Bitcoin/Keys/Extended.hs index 53172dd1..c0c2cf11 100644 --- a/src/Bitcoin/Keys/Extended.hs +++ b/src/Bitcoin/Keys/Extended.hs @@ -94,44 +94,82 @@ module Bitcoin.Keys.Extended ( concatBip32Segments, ) where -import Bitcoin.Address -import Bitcoin.Crypto.Hash -import Bitcoin.Data -import Bitcoin.Keys.Common +import Bitcoin.Address ( + Address, + Base58, + decodeBase58Check, + encodeBase58Check, + payToScriptAddress, + pubKeyAddr, + pubKeyCompatWitnessAddr, + pubKeyWitnessAddr, + ) +import Bitcoin.Crypto.Hash ( + Hash160, + Hash256, + getHash256, + hmac512, + hmac512L, + ripemd160, + sha256, + split512, + ) +import Bitcoin.Data (Network (..)) +import Bitcoin.Keys.Common ( + PubKeyI (pubKeyPoint), + toWif, + tweakPubKey, + tweakSecKey, + wrapPubKey, + wrapSecKey, + ) import Bitcoin.Keys.Extended.Internal ( Fingerprint (..), fingerprintToText, textToFingerprint, ) -import Bitcoin.Script -import Bitcoin.Util -import Control.Applicative -import Control.DeepSeq +import Bitcoin.Script ( + RedeemScript, + ScriptOutput (PayMulSig), + sortMulSig, + ) +import Bitcoin.Util (eitherToMaybe, getList, putList) +import qualified Bitcoin.Util as U +import Control.Applicative ((<|>)) +import Control.DeepSeq (NFData (..)) import Control.Exception (Exception, throw) import Control.Monad (guard, mzero, unless, (<=<)) -import Crypto.Secp256k1 -import Data.Binary (Binary (get, put)) +import Crypto.Hash (SHA256 (SHA256), hashWith) +import Crypto.Secp256k1 ( + PubKey, + SecKey, + derivePubKey, + exportPubKey, + getSecKey, + secKey, + ) +import Data.Binary (Binary, Get, Put, get, put) +import qualified Data.Binary as Bin +import qualified Data.Binary.Get as Get +import qualified Data.Binary.Put as Put import Data.Bits (clearBit, setBit, testBit) import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Short as BSS import Data.Either (fromRight) -import Data.Hashable +import Data.Hashable (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 import Data.Typeable (Typeable) import Data.Word (Word32, Word8) import GHC.Generics (Generic) -import Text.Read as R -import Text.Read.Lex +import qualified Text.Read as R +import Text.Read.Lex (numberToInteger) -- | A derivation exception is thrown in the very unlikely event that a @@ -169,32 +207,22 @@ data XPrvKey = XPrvKey deriving (Generic, Eq, Show, Read, NFData, Hashable) -instance Serial XPrvKey where - serialize k = do - putWord8 $ xPrvDepth k - serialize $ xPrvParent k - putWord32be $ xPrvIndex k - serialize $ xPrvChain k +instance Binary XPrvKey where + put k = do + Put.putWord8 $ xPrvDepth k + put $ xPrvParent k + Put.putWord32be $ xPrvIndex k + put $ xPrvChain k putPadPrvKey $ xPrvKey k - deserialize = + get = XPrvKey - <$> getWord8 - <*> deserialize - <*> getWord32be - <*> deserialize + <$> Get.getWord8 + <*> get + <*> Get.getWord32be + <*> get <*> getPadPrvKey -instance Binary XPrvKey where - put = serialize - get = deserialize - - -instance Serialize XPrvKey where - put = serialize - get = deserialize - - -- | Data type representing an extended BIP32 public key. data XPubKey = XPubKey { xPubDepth :: !Word8 @@ -211,30 +239,20 @@ data XPubKey = XPubKey deriving (Generic, Eq, Show, Read, NFData, Hashable) -instance Serial XPubKey where - serialize k = do - putWord8 $ xPubDepth k - serialize $ xPubParent k - putWord32be $ xPubIndex k - serialize $ xPubChain k - serialize $ wrapPubKey True (xPubKey k) - deserialize = - XPubKey - <$> getWord8 - <*> deserialize - <*> getWord32be - <*> deserialize - <*> (pubKeyPoint <$> deserialize) - - -instance Serialize XPubKey where - put = serialize - get = deserialize - - instance Binary XPubKey where - put = serialize - get = deserialize + put k = do + Put.putWord8 $ xPubDepth k + put $ xPubParent k + Put.putWord32be $ xPubIndex k + put $ xPubChain k + put $ wrapPubKey True (xPubKey k) + get = + XPubKey + <$> Get.getWord8 + <*> get + <*> Get.getWord32be + <*> get + <*> (pubKeyPoint <$> get) -- | Build a BIP32 compatible extended private key from a bytestring. This will @@ -244,7 +262,7 @@ makeXPrvKey bs = XPrvKey 0 (Fingerprint 0) 0 c k where (p, c) = split512 $ hmac512 "Bitcoin seed" bs - k = fromMaybe err (secKey (runPutS (serialize p))) + k = fromMaybe err . secKey . BSS.fromShort $ getHash256 p err = throw $ DerivationException "Invalid seed" @@ -277,8 +295,8 @@ prvSubKey xkey child | 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 + m = BSL.append (BSL.fromStrict $ exportPubKey True pK) $ Bin.encode child + (a, c) = split512 $ (hmac512L . U.encodeS) (xPrvChain xkey) m k = fromMaybe err $ tweakSecKey (xPrvKey xkey) a err = throw $ DerivationException "Invalid prvSubKey derivation" @@ -297,8 +315,8 @@ pubSubKey xKey child 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 + m = BSL.append (BSL.fromStrict . exportPubKey True $ xPubKey xKey) $ Bin.encode child + (a, c) = split512 $ (hmac512L . U.encodeS) (xPubChain xKey) m pK = fromMaybe err $ tweakPubKey (xPubKey xKey) a err = throw $ DerivationException "Invalid pubSubKey derivation" @@ -322,8 +340,8 @@ hardSubKey xkey child | 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 + m = BSL.append (bsPadPrvKey $ xPrvKey xkey) (Bin.encode i) + (a, c) = split512 $ (hmac512L . U.encodeS) (xPrvChain xkey) m k = fromMaybe err $ tweakSecKey (xPrvKey xkey) a err = throw $ DerivationException "Invalid hardSubKey derivation" @@ -359,13 +377,13 @@ xPrvID = xPubID . deriveXPubKey -- | Computes the key identifier of an extended public key. xPubID :: XPubKey -> Hash160 -xPubID = ripemd160 . runPutS . serialize . sha256 . exportPubKey True . xPubKey +xPubID = ripemd160 . hashWith 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 + fromRight err . U.decode . BSL.take 4 . Bin.encode . xPrvID where err = error "Could not decode xPrvFP" @@ -373,7 +391,7 @@ xPrvFP = -- | Computes the key fingerprint of an extended public key. xPubFP :: XPubKey -> Fingerprint xPubFP = - fromRight err . runGetS deserialize . B.take 4 . runPutS . serialize . xPubID + fromRight err . U.decode . BSL.take 4 . Bin.encode . xPubID where err = error "Could not decode xPubFP" @@ -397,24 +415,26 @@ xPubCompatWitnessAddr xkey = -- | Exports an extended private key to the BIP32 key export format ('Base58'). xPrvExport :: Network -> XPrvKey -> Base58 -xPrvExport net = encodeBase58Check . runPutS . putXPrvKey net +xPrvExport net = encodeBase58Check . Put.runPut . putXPrvKey net -- | Exports an extended public key to the BIP32 key export format ('Base58'). xPubExport :: Network -> XPubKey -> Base58 -xPubExport net = encodeBase58Check . runPutS . putXPubKey net +xPubExport net = encodeBase58Check . Put.runPut . putXPubKey net -- | Decodes a BIP32 encoded extended private key. This function will fail if -- invalid base 58 characters are detected or if the checksum fails. xPrvImport :: Network -> Base58 -> Maybe XPrvKey -xPrvImport net = eitherToMaybe . runGetS (getXPrvKey net) <=< decodeBase58Check +xPrvImport net = + eitherToMaybe . U.runGet (getXPrvKey net) <=< decodeBase58Check -- | Decodes a BIP32 encoded extended public key. This function will fail if -- invalid base 58 characters are detected or if the checksum fails. xPubImport :: Network -> Base58 -> Maybe XPubKey -xPubImport net = eitherToMaybe . runGetS (getXPubKey net) <=< decodeBase58Check +xPubImport net = + eitherToMaybe . U.runGet (getXPubKey net) <=< decodeBase58Check -- | Export an extended private key to WIF (Wallet Import Format). @@ -423,37 +443,37 @@ xPrvWif net xkey = toWif net (wrapSecKey True (xPrvKey xkey)) -- | Parse a binary extended private key. -getXPrvKey :: MonadGet m => Network -> m XPrvKey +getXPrvKey :: Network -> Get XPrvKey getXPrvKey net = do - ver <- getWord32be + ver <- Get.getWord32be unless (ver == getExtSecretPrefix net) $ fail "Get: Invalid version for extended private key" - deserialize + get -- | Serialize an extended private key. -putXPrvKey :: MonadPut m => Network -> XPrvKey -> m () +putXPrvKey :: Network -> XPrvKey -> Put putXPrvKey net k = do - putWord32be $ getExtSecretPrefix net - serialize k + Put.putWord32be $ getExtSecretPrefix net + put k -- | Parse a binary extended public key. -getXPubKey :: MonadGet m => Network -> m XPubKey +getXPubKey :: Network -> Get XPubKey getXPubKey net = do - ver <- getWord32be + ver <- Get.getWord32be unless (ver == getExtPubKeyPrefix net) $ fail "Get: Invalid version for extended public key" - deserialize + get -- | Serialize an extended public key. -putXPubKey :: MonadPut m => Network -> XPubKey -> m () +putXPubKey :: Network -> XPubKey -> Put putXPubKey net k = do - putWord32be $ getExtPubKeyPrefix net - serialize k + Put.putWord32be $ getExtPubKeyPrefix net + put k {- Derivation helpers -} @@ -658,61 +678,31 @@ instance Ord (DerivPathI t) where _ `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 + get = listToPath <$> getList Get.getWord32be + put = putList Put.putWord32be . pathToList -instance Serial HardPath where - deserialize = +instance Binary HardPath where + get = maybe (fail "Could not decode hard path") return . toHard . listToPath - =<< getList getWord32be - serialize = putList putWord32be . pathToList - - -instance Serialize HardPath where - put = serialize - get = deserialize - - -instance Binary HardPath where - put = serialize - get = deserialize + =<< getList Get.getWord32be + put = putList Put.putWord32be . pathToList -instance Serial SoftPath where - deserialize = +instance Binary SoftPath where + get = maybe (fail "Could not decode soft path") return . toSoft . listToPath - =<< getList getWord32be - serialize = putList putWord32be . pathToList - - -instance Serialize SoftPath where - put = serialize - get = deserialize - - -instance Binary SoftPath where - put = serialize - get = deserialize + =<< getList Get.getWord32be + put = putList Put.putWord32be . pathToList -- | Get a list of derivation indices from a derivation path. @@ -811,10 +801,10 @@ instance Show DerivPath where instance Read DerivPath where - readPrec = parens $ do - R.Ident "DerivPath" <- lexP - R.String str <- lexP - maybe pfail (return . getParsedPath) (parsePath str) + readPrec = R.parens $ do + R.Ident "DerivPath" <- R.lexP + R.String str <- R.lexP + maybe R.pfail (return . getParsedPath) (parsePath str) instance Show HardPath where @@ -824,10 +814,10 @@ instance Show HardPath where instance Read HardPath where - readPrec = parens $ do - R.Ident "HardPath" <- lexP - R.String str <- lexP - maybe pfail return $ parseHard str + readPrec = R.parens $ do + R.Ident "HardPath" <- R.lexP + R.String str <- R.lexP + maybe R.pfail return $ parseHard str instance Show SoftPath where @@ -837,10 +827,10 @@ instance Show SoftPath where instance Read SoftPath where - readPrec = parens $ do - R.Ident "SoftPath" <- lexP - R.String str <- lexP - maybe pfail return $ parseSoft str + readPrec = R.parens $ do + R.Ident "SoftPath" <- R.lexP + R.String str <- R.lexP + maybe R.pfail return $ parseSoft str instance IsString ParsedPath where @@ -893,10 +883,10 @@ instance Show ParsedPath where instance Read ParsedPath where - readPrec = parens $ do - R.Ident "ParsedPath" <- lexP - R.String str <- lexP - maybe pfail return $ parsePath str + readPrec = R.parens $ do + R.Ident "ParsedPath" <- R.lexP + R.String str <- R.lexP + maybe R.pfail return $ parsePath str -- | Parse derivation path string for extended key. @@ -952,15 +942,15 @@ 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) + R.parens $ do + R.Ident "Bip32HardIndex" <- R.lexP + R.Number n <- R.lexP + maybe R.pfail (return . Bip32HardIndex . fromIntegral) (numberToInteger n) s = - parens $ do - R.Ident "Bip32SoftIndex" <- lexP - R.Number n <- lexP - maybe pfail (return . Bip32SoftIndex . fromIntegral) (numberToInteger n) + R.parens $ do + R.Ident "Bip32SoftIndex" <- R.lexP + R.Number n <- R.lexP + maybe R.pfail (return . Bip32SoftIndex . fromIntegral) (numberToInteger n) -- | Test whether the number could be a valid BIP32 derivation index. @@ -1065,20 +1055,18 @@ derivePathMSAddrs keys path = {- Utilities for extended keys -} -- | De-serialize HDW-specific private key. -getPadPrvKey :: MonadGet m => m SecKey +getPadPrvKey :: Get SecKey getPadPrvKey = do - pad <- getWord8 + pad <- Get.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 + Get.getByteString 32 + >>= maybe (error "getPadPrvKey: unreachable") pure . secKey -- | Serialize HDW-specific private key. -putPadPrvKey :: MonadPut m => SecKey -> m () -putPadPrvKey p = putWord8 0x00 >> putByteString (runPutS (S.put p)) +putPadPrvKey :: SecKey -> Put +putPadPrvKey p = Put.putWord8 0x00 >> Put.putByteString (getSecKey p) -bsPadPrvKey :: SecKey -> ByteString -bsPadPrvKey = runPutS . putPadPrvKey +bsPadPrvKey :: SecKey -> BSL.ByteString +bsPadPrvKey = Put.runPut . putPadPrvKey diff --git a/src/Bitcoin/Keys/Extended/Internal.hs b/src/Bitcoin/Keys/Extended/Internal.hs index 8bdc8595..37edde0c 100644 --- a/src/Bitcoin/Keys/Extended/Internal.hs +++ b/src/Bitcoin/Keys/Extended/Internal.hs @@ -8,17 +8,17 @@ module Bitcoin.Keys.Extended.Internal ( ) where import Bitcoin.Util (decodeHex, encodeHex) +import qualified Bitcoin.Util as U import Control.DeepSeq (NFData) import Control.Monad ((>=>)) import Data.Binary (Binary (..)) -import Data.Bytes.Get (getWord32be) -import Data.Bytes.Put (putWord32be) -import Data.Bytes.Serial (Serial (..)) +import qualified Data.Binary as Bin +import qualified Data.Binary.Get as Get +import qualified Data.Binary.Put as Put +import qualified Data.ByteString.Lazy as BSL 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,28 +34,29 @@ newtype Fingerprint = Fingerprint {unFingerprint :: Word32} fingerprintToText :: Fingerprint -> Text -fingerprintToText = encodeHex . S.encode +fingerprintToText = encodeHex . U.encodeS textToFingerprint :: Text -> Either String Fingerprint -textToFingerprint = maybe (Left "Fingerprint: invalid hex") Right . decodeHex >=> S.decode +textToFingerprint = maybe (Left "Fingerprint: invalid hex") Right . decodeHex >=> U.decode . BSL.fromStrict instance Show Fingerprint where - show = show . Text.unpack . encodeHex . S.encode + show = show . Text.unpack . encodeHex . U.encodeS instance Read Fingerprint where readPrec = readPrec >>= maybe (fail "Fingerprint: invalid hex") pure . decodeHex - >>= either (fail . ("Fingerprint: " <>)) pure . S.decode + >>= either (fail . ("Fingerprint: " <>)) pure . U.decode . BSL.fromStrict instance IsString Fingerprint where fromString = fromRight decodeError - . S.decode + . U.decode + . BSL.fromStrict . fromMaybe hexError . decodeHex . Text.pack @@ -64,16 +65,6 @@ instance IsString Fingerprint where 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 + put = Put.putWord32be . unFingerprint + get = Fingerprint <$> Get.getWord32be diff --git a/src/Bitcoin/Keys/Mnemonic.hs b/src/Bitcoin/Keys/Mnemonic.hs index 48cdb82d..ff0601ba 100644 --- a/src/Bitcoin/Keys/Mnemonic.hs +++ b/src/Bitcoin/Keys/Mnemonic.hs @@ -24,6 +24,7 @@ import Data.Bits (shiftL, shiftR) import qualified Data.ByteArray as BA import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL import Data.List import qualified Data.Map.Strict as M import Data.Maybe @@ -114,7 +115,7 @@ calcCS len = getBits len . BA.convert . hashWith SHA256 numCS :: Int -> Entropy -> Integer numCS len = - shiftCS . bsToInteger + shiftCS . bsToInteger . BSL.fromStrict where shiftCS = case 8 - len `mod` 8 of 8 -> id @@ -176,7 +177,7 @@ indicesToBS is = do -- | Turn a 'ByteString' into a list of 11-bit numbers. bsToIndices :: ByteString -> [Int] bsToIndices bs = - reverse . go q $ bsToInteger bs `shiftR` r + reverse . go q $ bsToInteger (BSL.fromStrict bs) `shiftR` r where (q, r) = (BS.length bs * 8) `quotRem` 11 go 0 _ = [] diff --git a/src/Bitcoin/Network/Bloom.hs b/src/Bitcoin/Network/Bloom.hs index f67115ee..aaf37765 100644 --- a/src/Bitcoin/Network/Bloom.hs +++ b/src/Bitcoin/Network/Bloom.hs @@ -25,24 +25,33 @@ module Bitcoin.Network.Bloom ( bloomRelevantUpdate, ) where -import Bitcoin.Network.Common -import Bitcoin.Script.Standard -import Bitcoin.Transaction.Common -import Control.DeepSeq -import Control.Monad (forM_, replicateM) +import Bitcoin.Network.Common (VarInt (VarInt), putVarInt) +import Bitcoin.Script.Standard ( + ScriptOutput (..), + decodeOutputBS, + isPayMulSig, + isPayPK, + ) +import Bitcoin.Transaction.Common ( + OutPoint (..), + Tx (txOut), + TxOut (scriptOutput), + txHash, + ) +import qualified Bitcoin.Util as U +import Control.DeepSeq (NFData) +import Control.Monad (replicateM) import Data.Binary (Binary (..)) -import Data.Bits +import Data.Binary.Get (getByteString, getWord32le, getWord8) +import Data.Binary.Put (putByteString, putWord32le, putWord8) +import Data.Bits (Bits (shiftL, shiftR, (.&.), (.|.))) import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial 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 Data.Word (Word32, Word64, Word8) import GHC.Generics (Generic) @@ -79,8 +88,8 @@ data BloomFlags deriving (Eq, Show, Read, Generic, NFData) -instance Serial BloomFlags where - deserialize = go =<< getWord8 +instance Binary BloomFlags where + get = go =<< getWord8 where go 0 = return BloomUpdateNone go 1 = return BloomUpdateAll @@ -88,22 +97,12 @@ instance Serial BloomFlags where go _ = fail "BloomFlags get: Invalid bloom flag" - serialize f = putWord8 $ case f of + put 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 @@ -123,53 +122,28 @@ data BloomFilter = BloomFilter deriving (Eq, Show, Read, Generic, NFData) -instance Serial BloomFilter where - deserialize = +instance Binary BloomFilter where + get = BloomFilter - <$> (S.fromList <$> (readDat =<< deserialize)) + <$> (S.fromList <$> (readDat =<< get)) <*> getWord32le <*> getWord32le - <*> deserialize + <*> get where readDat (VarInt len) = replicateM (fromIntegral len) getWord8 - serialize (BloomFilter dat hashFuncs tweak flags) = do + put (BloomFilter dat hashFuncs tweak flags) = do putVarInt $ S.length dat - forM_ (F.toList dat) putWord8 + mapM_ putWord8 $ F.toList dat putWord32le hashFuncs putWord32le tweak - serialize flags - - -instance Binary BloomFilter where - put = serialize - get = deserialize - - -instance Serialize BloomFilter where - put = serialize - get = deserialize + put flags -- | 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 + deriving (Eq, Show, Read, Generic, NFData, Binary) -- | Add the given data element to the connections current filter without @@ -178,28 +152,17 @@ 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 +instance Binary FilterAdd where + get = do + (VarInt len) <- get + FilterAdd <$> getByteString (fromIntegral len) - serialize (FilterAdd bs) = do + put (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. bloomCreate :: @@ -314,14 +277,14 @@ bloomRelevantUpdate bfilter tx (BloomUpdateAll, _) -> bloomInsert bf outpoint _ -> error "Error Updating Bloom Filter with relevant outpoint" where - outpoint = runPutS $ serialize $ OutPoint{outPointHash = h, outPointIndex = id'} + outpoint = U.encodeS $ 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 + encodeScriptOut (PayMulSig outputMuSig _) = U.encodeS outputMuSig + encodeScriptOut (PayWitnessScriptHash scriptHash) = U.encodeS scriptHash + encodeScriptOut (DataCarrier getOutputDat) = U.encodeS getOutputDat + encodeScriptOut outputHash = (U.encodeS . getOutputHash) outputHash -- | Returns True if the filter is empty (all bytes set to 0x00) diff --git a/src/Bitcoin/Network/Common.hs b/src/Bitcoin/Network/Common.hs index d7d796c2..e262c1fb 100644 --- a/src/Bitcoin/Network/Common.hs +++ b/src/Bitcoin/Network/Common.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -- | @@ -16,9 +17,6 @@ module Bitcoin.Network.Common ( Inv (..), InvVector (..), InvType (..), - HostAddress, - hostToSockAddr, - sockToHostAddress, NetworkAddress (..), NotFound (..), Ping (..), @@ -41,24 +39,25 @@ module Bitcoin.Network.Common ( putVarInt, ) where -import Bitcoin.Crypto.Hash -import Control.DeepSeq +import Bitcoin.Crypto.Hash (Hash256) +import qualified Bitcoin.Util as U +import Control.DeepSeq (NFData) import Control.Monad (forM_, liftM2, replicateM, unless) -import Data.Binary (Binary (..)) +import Data.Binary (Binary (..), Get, Put) +import qualified Data.Binary.Get as Get +import qualified Data.Binary.Put as Put import Data.Bits (shiftL) import Data.ByteString (ByteString) -import qualified Data.ByteString as B -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 qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as BSL +import Data.String (IsString (..)) import Data.String.Conversions (cs) import Data.Word (Word32, Word64) import GHC.Generics (Generic) -import Network.Socket (SockAddr (..)) -import Text.Read as R +import Network.Socket (HostAddress6, SockAddr (..)) +import Text.Read (Lexeme (String)) +import qualified Text.Read as R -- | Network address with a timestamp. @@ -74,26 +73,16 @@ newtype Addr = Addr deriving (Eq, Show, Generic, NFData) -instance Serial Addr where - deserialize = Addr <$> (repList =<< deserialize) +instance Binary Addr where + get = Addr <$> (repList =<< get) where repList (VarInt c) = replicateM (fromIntegral c) action - action = liftM2 (,) getWord32le deserialize + action = liftM2 (,) Get.getWord32le get - serialize (Addr xs) = do + put (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 + forM_ xs $ \(a, b) -> Put.putWord32le a >> put b -- | Data type describing signed messages that can be sent between bitcoin @@ -108,19 +97,9 @@ 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 + get = Alert <$> get <*> get + put (Alert p s) = put p >> put s -- | The 'GetData' type is used to retrieve information on a specific object @@ -137,25 +116,15 @@ newtype GetData = GetData deriving (Eq, Show, Generic, NFData) -instance Serial GetData where - deserialize = GetData <$> (repList =<< deserialize) +instance Binary GetData where + get = GetData <$> (repList =<< get) where - repList (VarInt c) = replicateM (fromIntegral c) deserialize + repList (VarInt c) = replicateM (fromIntegral c) get - serialize (GetData xs) = do + put (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 + forM_ xs put -- | 'Inv' messages are used by nodes to advertise their knowledge of new @@ -168,25 +137,15 @@ newtype Inv = Inv deriving (Eq, Show, Generic, NFData) -instance Serial Inv where - deserialize = Inv <$> (repList =<< deserialize) +instance Binary Inv where + get = Inv <$> (repList =<< get) where - repList (VarInt c) = replicateM (fromIntegral c) deserialize + repList (VarInt c) = replicateM (fromIntegral c) get - serialize (Inv xs) = do + put (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 + forM_ xs put -- | Data type identifying the type of an inventory vector. SegWit types are @@ -211,8 +170,8 @@ data InvType deriving (Eq, Show, Read, Generic, NFData) -instance Serial InvType where - deserialize = go =<< getWord32le +instance Binary InvType where + get = go =<< Get.getWord32le where go x = case x of @@ -225,8 +184,8 @@ instance Serial InvType where | x == 1 `shiftL` 30 + 2 -> return InvWitnessBlock | x == 1 `shiftL` 30 + 3 -> return InvWitnessMerkleBlock | otherwise -> return (InvType x) - serialize x = - putWord32le $ + put x = + Put.putWord32le $ case x of InvError -> 0 InvTx -> 1 @@ -238,16 +197,6 @@ instance Serial InvType where 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. @@ -260,39 +209,9 @@ 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 + get = InvVector <$> get <*> get + put (InvVector t h) = put t >> put h -- | Data type describing a bitcoin network address. Addresses are stored in @@ -301,68 +220,36 @@ instance Serialize HostAddress where data NetworkAddress = NetworkAddress { naServices :: !Word64 -- ^ bitmask of services available for this address - , naAddress :: !HostAddress + , naAddress :: !HostAddress6 -- ^ address and port information } deriving (Eq, Show, Generic, NFData) -hostToSockAddr :: HostAddress -> SockAddr -hostToSockAddr (HostAddress bs) = - case runGetS getSockAddr bs of - Left e -> error e - Right x -> x - - -sockToHostAddress :: SockAddr -> HostAddress -sockToHostAddress = HostAddress . runPutS . putSockAddr - +putHostAddr6 :: HostAddress6 -> Put +putHostAddr6 (a, b, c, d) = do + Put.putWord32be a + Put.putWord32be b + Put.putWord32be c + Put.putWord32be d -putSockAddr :: MonadPut m => SockAddr -> m () -putSockAddr (SockAddrInet6 p _ (a, b, c, d) _) = do - putWord32be a - putWord32be b - putWord32be c - putWord32be d - putWord16be (fromIntegral p) -putSockAddr (SockAddrInet p a) = do - putWord32be 0x00000000 - putWord32be 0x00000000 - putWord32be 0x0000ffff - putWord32host a - putWord16be (fromIntegral p) -putSockAddr _ = error "Invalid address type" - -getSockAddr :: MonadGet m => m SockAddr -getSockAddr = do - a <- getWord32be - b <- getWord32be - c <- getWord32be - if a == 0x00000000 && b == 0x00000000 && c == 0x0000ffff - then do - d <- getWord32host - p <- getWord16be - return $ SockAddrInet (fromIntegral p) d - else do - d <- getWord32be - p <- getWord16be - return $ SockAddrInet6 (fromIntegral p) 0 (a, b, c, d) 0 - - -instance Serial NetworkAddress where - deserialize = NetworkAddress <$> getWord64le <*> deserialize - serialize (NetworkAddress s a) = putWord64le s >> serialize a +getHostAddr6 :: Get HostAddress6 +getHostAddr6 = + (,,,) + <$> Get.getWord32be + <*> Get.getWord32be + <*> Get.getWord32be + <*> Get.getWord32be instance Binary NetworkAddress where - get = deserialize - put = serialize - - -instance Serialize NetworkAddress where - get = deserialize - put = serialize + get = + NetworkAddress + <$> Get.getWord64le + <*> getHostAddr6 + put (NetworkAddress s a) = + Put.putWord64le s >> putHostAddr6 a -- | A 'NotFound' message is returned as a response to a 'GetData' message @@ -376,25 +263,15 @@ newtype NotFound = NotFound deriving (Eq, Show, Generic, NFData) -instance Serial NotFound where - deserialize = NotFound <$> (repList =<< deserialize) +instance Binary NotFound where + get = NotFound <$> (repList =<< get) where - repList (VarInt c) = replicateM (fromIntegral c) deserialize + repList (VarInt c) = replicateM (fromIntegral c) get - serialize (NotFound xs) = do + put (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 + forM_ xs put -- | A 'Ping' message is sent to bitcoin peers to check if a connection is still @@ -415,34 +292,14 @@ 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 + get = Ping <$> Get.getWord64le + put (Ping n) = Put.putWord64le n instance Binary Pong where - get = deserialize - put = serialize - - -instance Serialize Ping where - get = deserialize - put = serialize - - -instance Serialize Pong where - get = deserialize - put = serialize + get = Pong <$> Get.getWord64le + put (Pong n) = Put.putWord64le n -- | The 'Reject' message is sent when messages are rejected by a peer. @@ -472,9 +329,9 @@ data RejectCode deriving (Eq, Show, Read, Generic, NFData) -instance Serial RejectCode where - deserialize = - getWord8 >>= \code -> case code of +instance Binary RejectCode where + get = + Get.getWord8 >>= \case 0x01 -> return RejectMalformed 0x10 -> return RejectInvalid 0x11 -> return RejectObsolete @@ -483,7 +340,7 @@ instance Serial RejectCode where 0x41 -> return RejectDust 0x42 -> return RejectInsufficientFee 0x43 -> return RejectCheckpoint - _ -> + code -> fail $ unwords [ "Reject get: Invalid code" @@ -491,61 +348,42 @@ instance Serial RejectCode where ] - serialize code = putWord8 $ case code of - RejectMalformed -> 0x01 - RejectInvalid -> 0x10 - RejectObsolete -> 0x11 - RejectDuplicate -> 0x12 - RejectNonStandard -> 0x40 - RejectDust -> 0x41 - RejectInsufficientFee -> 0x42 - RejectCheckpoint -> 0x43 - - -instance Binary RejectCode where - put = serialize - get = deserialize - - -instance Serialize RejectCode where - put = serialize - get = deserialize + put = + Put.putWord8 . \case + RejectMalformed -> 0x01 + RejectInvalid -> 0x10 + RejectObsolete -> 0x11 + RejectDuplicate -> 0x12 + RejectNonStandard -> 0x40 + RejectDust -> 0x41 + RejectInsufficientFee -> 0x42 + RejectCheckpoint -> 0x43 -- | Convenience function to build a 'Reject' message. reject :: MessageCommand -> RejectCode -> ByteString -> Reject reject cmd code reason = - Reject cmd code (VarString reason) B.empty + Reject cmd code (VarString reason) BS.empty -instance Serial Reject where - deserialize = - deserialize >>= \(VarString bs) -> +instance Binary Reject where + get = + get >>= \(VarString bs) -> Reject (stringToCommand bs) - <$> deserialize - <*> deserialize + <$> get + <*> get <*> maybeData where maybeData = - isEmpty >>= \done -> + Get.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 + then return BS.empty + else Get.getByteString 32 + put (Reject cmd code reason dat) = do + put $ VarString $ commandToString cmd + put code + put reason + unless (BS.null dat) $ Put.putByteString dat -- | Data type representing a variable-length integer. The 'VarInt' type @@ -554,41 +392,31 @@ newtype VarInt = VarInt {getVarInt :: Word64} deriving (Eq, Show, Read, Generic, NFData) -instance Serial VarInt where - deserialize = VarInt <$> (getWord8 >>= go) +instance Binary VarInt where + get = VarInt <$> (Get.getWord8 >>= go) where - go 0xff = getWord64le - go 0xfe = fromIntegral <$> getWord32le - go 0xfd = fromIntegral <$> getWord16le + go 0xff = Get.getWord64le + go 0xfe = fromIntegral <$> Get.getWord32le + go 0xfd = fromIntegral <$> Get.getWord16le go x = return $ fromIntegral x - serialize (VarInt x) + put (VarInt x) | x < 0xfd = - putWord8 $ fromIntegral x + Put.putWord8 $ fromIntegral x | x <= 0xffff = do - putWord8 0xfd - putWord16le $ fromIntegral x + Put.putWord8 0xfd + Put.putWord16le $ fromIntegral x | x <= 0xffffffff = do - putWord8 0xfe - putWord32le $ fromIntegral x + Put.putWord8 0xfe + Put.putWord32le $ fromIntegral x | otherwise = do - putWord8 0xff - putWord64le x - - -instance Binary VarInt where - put = serialize - get = deserialize - - -instance Serialize VarInt where - put = serialize - get = deserialize + Put.putWord8 0xff + Put.putWord64le x -putVarInt :: (MonadPut m, Integral a) => a -> m () -putVarInt = serialize . VarInt . fromIntegral +putVarInt :: Integral a => a -> Put +putVarInt = put . VarInt . fromIntegral -- | Data type for serialization of variable-length strings. @@ -596,25 +424,15 @@ newtype VarString = VarString {getVarString :: ByteString} deriving (Eq, Show, Read, Generic, NFData) -instance Serial VarString where - deserialize = VarString <$> (readBS =<< deserialize) - where - readBS (VarInt len) = getByteString (fromIntegral len) - - - serialize (VarString bs) = do - putVarInt $ B.length bs - putByteString bs - - instance Binary VarString where - put = serialize - get = deserialize + get = VarString <$> (readBS =<< get) + where + readBS (VarInt len) = Get.getByteString (fromIntegral len) -instance Serialize VarString where - put = serialize - get = deserialize + put (VarString bs) = do + putVarInt $ BS.length bs + Put.putByteString bs -- | When a bitcoin node creates an outgoing connection to another node, @@ -643,56 +461,46 @@ data Version = Version deriving (Eq, Show, Generic, NFData) -instance Serial Version where - deserialize = +instance Binary Version where + get = Version - <$> getWord32le - <*> getWord64le - <*> getWord64le - <*> deserialize - <*> deserialize - <*> getWord64le - <*> deserialize - <*> getWord32le - <*> (go =<< isEmpty) + <$> Get.getWord32le + <*> Get.getWord64le + <*> Get.getWord64le + <*> get + <*> get + <*> Get.getWord64le + <*> get + <*> Get.getWord32le + <*> (go =<< Get.isEmpty) where go True = return True go False = getBool - serialize (Version v s t ar as n ua sh r) = do - putWord32le v - putWord64le s - putWord64le t - serialize ar - serialize as - putWord64le n - serialize ua - putWord32le sh + put (Version v s t ar as n ua sh r) = do + Put.putWord32le v + Put.putWord64le s + Put.putWord64le t + put ar + put as + Put.putWord64le n + put ua + Put.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 +getBool :: Get Bool +getBool = go =<< Get.getWord8 where go 0 = return False go _ = return True -putBool :: MonadPut m => Bool -> m () -putBool True = putWord8 1 -putBool False = putWord8 0 +putBool :: Bool -> Put +putBool True = Put.putWord8 1 +putBool False = Put.putWord8 0 -- | A 'MessageCommand' is included in a 'MessageHeader' in order to identify @@ -733,27 +541,17 @@ instance Show MessageCommand where instance Read MessageCommand where readPrec = do - String str <- lexP + String str <- R.lexP return (stringToCommand (cs str)) -instance Serial MessageCommand where - deserialize = go <$> getByteString 12 +instance Binary MessageCommand where + get = go <$> Get.getByteString 12 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 + put = Put.putByteString . packCommand . commandToString instance IsString MessageCommand where @@ -819,13 +617,13 @@ commandToString mc = case mc of -- | Pack a string 'MessageCommand' so that it is exactly 12-bytes long. packCommand :: ByteString -> ByteString packCommand s = - B.take 12 $ + BS.take 12 $ s `mappend` C.replicate 12 '\NUL' -- | Undo packing done by 'packCommand'. unpackCommand :: ByteString -> ByteString -unpackCommand = B.takeWhile (/= 0) +unpackCommand = BS.takeWhile (/= 0) -- | Node offers no services. diff --git a/src/Bitcoin/Network/Message.hs b/src/Bitcoin/Network/Message.hs index 76baf37f..6647c6da 100644 --- a/src/Bitcoin/Network/Message.hs +++ b/src/Bitcoin/Network/Message.hs @@ -15,22 +15,39 @@ module Bitcoin.Network.Message ( getMessage, ) where -import Bitcoin.Block.Common -import Bitcoin.Block.Merkle -import Bitcoin.Crypto.Hash -import Bitcoin.Data -import Bitcoin.Network.Bloom -import Bitcoin.Network.Common -import Bitcoin.Transaction.Common -import Control.DeepSeq +import Bitcoin.Block.Common ( + Block, + GetBlocks, + GetHeaders, + Headers, + ) +import Bitcoin.Block.Merkle (MerkleBlock) +import Bitcoin.Crypto.Hash (CheckSum32, checkSum32) +import Bitcoin.Data (Network (getNetworkMagic)) +import Bitcoin.Network.Bloom (FilterAdd, FilterLoad) +import Bitcoin.Network.Common ( + Addr, + Alert, + GetData, + Inv, + MessageCommand (..), + NotFound, + Ping, + Pong, + Reject, + Version, + ) +import Bitcoin.Transaction.Common (Tx) +import qualified Bitcoin.Util as U +import Control.DeepSeq (NFData) import Control.Monad (unless) import Data.Binary (Binary (..)) +import qualified Data.Binary as Bin +import Data.Binary.Get (Get, getByteString, getLazyByteString, getWord32be, getWord32le, lookAhead) +import Data.Binary.Put (Put, putLazyByteString, putWord32be, putWord32le) 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 qualified Data.ByteString.Lazy as BSL import Data.Word (Word32) import GHC.Generics (Generic) @@ -50,30 +67,20 @@ data MessageHeader = MessageHeader deriving (Eq, Show, Generic, NFData) -instance Serial MessageHeader where - deserialize = +instance Binary MessageHeader where + get = MessageHeader <$> getWord32be - <*> deserialize + <*> get <*> getWord32le - <*> deserialize + <*> get - serialize (MessageHeader m c l chk) = do + put (MessageHeader m c l chk) = do putWord32be m - serialize c + put c putWord32le l - serialize chk - - -instance Binary MessageHeader where - put = serialize - get = deserialize - - -instance Serialize MessageHeader where - put = serialize - get = deserialize + put chk -- | The 'Message' type is used to identify all the valid messages that can be @@ -137,10 +144,10 @@ msgType (MOther c _) = MCOther c -- | Deserializer for network messages. -getMessage :: MonadGet m => Network -> m Message +getMessage :: Network -> Get Message getMessage net = do - (MessageHeader mgc cmd len chk) <- deserialize - bs <- lookAhead $ getByteString $ fromIntegral len + (MessageHeader mgc cmd len chk) <- get + bs <- getLazyByteString $ fromIntegral len unless (mgc == getNetworkMagic net) (fail $ "get: Invalid network magic bytes: " ++ show mgc) @@ -149,32 +156,31 @@ getMessage net = do (fail $ "get: Invalid message checksum: " ++ show chk) if len > 0 then do - bs <- ensure (fromIntegral len) let f = case cmd of - MCVersion -> MVersion <$> deserialize - MCAddr -> MAddr <$> deserialize - MCInv -> MInv <$> deserialize - MCGetData -> MGetData <$> deserialize - MCNotFound -> MNotFound <$> deserialize - MCGetBlocks -> MGetBlocks <$> deserialize - MCGetHeaders -> MGetHeaders <$> deserialize - MCTx -> MTx <$> deserialize - MCBlock -> MBlock <$> deserialize - MCMerkleBlock -> MMerkleBlock <$> deserialize - MCHeaders -> MHeaders <$> deserialize - MCFilterLoad -> MFilterLoad <$> deserialize - MCFilterAdd -> MFilterAdd <$> deserialize - MCPing -> MPing <$> deserialize - MCPong -> MPong <$> deserialize - MCAlert -> MAlert <$> deserialize - MCReject -> MReject <$> deserialize + MCVersion -> MVersion <$> get + MCAddr -> MAddr <$> get + MCInv -> MInv <$> get + MCGetData -> MGetData <$> get + MCNotFound -> MNotFound <$> get + MCGetBlocks -> MGetBlocks <$> get + MCGetHeaders -> MGetHeaders <$> get + MCTx -> MTx <$> get + MCBlock -> MBlock <$> get + MCMerkleBlock -> MMerkleBlock <$> get + MCHeaders -> MHeaders <$> get + MCFilterLoad -> MFilterLoad <$> get + MCFilterAdd -> MFilterAdd <$> get + MCPing -> MPing <$> get + MCPong -> MPong <$> get + MCAlert -> MAlert <$> get + MCReject -> MReject <$> get MCOther c -> MOther c <$> getByteString (fromIntegral len) _ -> fail $ "get: command " ++ show cmd ++ " should not carry a payload" - either fail return (runGetS f bs) + either fail return $ U.runGet f bs else case cmd of MCGetAddr -> return MGetAddr MCVerAck -> return MVerAck @@ -190,35 +196,35 @@ getMessage net = do -- | Serializer for network messages. -putMessage :: MonadPut m => Network -> Message -> m () +putMessage :: Network -> Message -> Put putMessage net msg = do let (cmd, payload) = case msg of - MVersion m -> (MCVersion, runPutS $ serialize m) - MVerAck -> (MCVerAck, BS.empty) - MAddr m -> (MCAddr, runPutS $ serialize m) - MInv m -> (MCInv, runPutS $ serialize m) - MGetData m -> (MCGetData, runPutS $ serialize m) - MNotFound m -> (MCNotFound, runPutS $ serialize m) - MGetBlocks m -> (MCGetBlocks, runPutS $ serialize m) - MGetHeaders m -> (MCGetHeaders, runPutS $ serialize m) - MTx m -> (MCTx, runPutS $ serialize m) - MBlock m -> (MCBlock, runPutS $ serialize m) - MMerkleBlock m -> (MCMerkleBlock, runPutS $ serialize m) - MHeaders m -> (MCHeaders, runPutS $ serialize m) - MGetAddr -> (MCGetAddr, BS.empty) - MFilterLoad m -> (MCFilterLoad, runPutS $ serialize m) - MFilterAdd m -> (MCFilterAdd, runPutS $ serialize m) - MFilterClear -> (MCFilterClear, BS.empty) - MPing m -> (MCPing, runPutS $ serialize m) - MPong m -> (MCPong, runPutS $ serialize m) - MAlert m -> (MCAlert, runPutS $ serialize m) - MMempool -> (MCMempool, BS.empty) - MReject m -> (MCReject, runPutS $ serialize m) - MSendHeaders -> (MCSendHeaders, BS.empty) - MOther c p -> (MCOther c, p) + MVersion m -> (MCVersion, Bin.encode m) + MVerAck -> (MCVerAck, BSL.empty) + MAddr m -> (MCAddr, Bin.encode m) + MInv m -> (MCInv, Bin.encode m) + MGetData m -> (MCGetData, Bin.encode m) + MNotFound m -> (MCNotFound, Bin.encode m) + MGetBlocks m -> (MCGetBlocks, Bin.encode m) + MGetHeaders m -> (MCGetHeaders, Bin.encode m) + MTx m -> (MCTx, Bin.encode m) + MBlock m -> (MCBlock, Bin.encode m) + MMerkleBlock m -> (MCMerkleBlock, Bin.encode m) + MHeaders m -> (MCHeaders, Bin.encode m) + MGetAddr -> (MCGetAddr, BSL.empty) + MFilterLoad m -> (MCFilterLoad, Bin.encode m) + MFilterAdd m -> (MCFilterAdd, Bin.encode m) + MFilterClear -> (MCFilterClear, BSL.empty) + MPing m -> (MCPing, Bin.encode m) + MPong m -> (MCPong, Bin.encode m) + MAlert m -> (MCAlert, Bin.encode m) + MMempool -> (MCMempool, BSL.empty) + MReject m -> (MCReject, Bin.encode m) + MSendHeaders -> (MCSendHeaders, BSL.empty) + MOther c p -> (MCOther c, BSL.fromStrict p) chk = checkSum32 payload - len = fromIntegral $ BS.length payload + len = fromIntegral $ BSL.length payload header = MessageHeader (getNetworkMagic net) cmd len chk - serialize header - putByteString payload + put header + putLazyByteString payload diff --git a/src/Bitcoin/Script/Common.hs b/src/Bitcoin/Script/Common.hs index 596eb2e5..f0072480 100644 --- a/src/Bitcoin/Script/Common.hs +++ b/src/Bitcoin/Script/Common.hs @@ -18,17 +18,18 @@ module Bitcoin.Script.Common ( scriptOpToInt, ) where +import qualified Bitcoin.Util as U import Control.DeepSeq import Control.Monad import Data.Binary (Binary (..)) +import qualified Data.Binary as Bin +import Data.Binary.Get (getByteString, getWord16le, getWord32le, getWord8, isEmpty) +import Data.Binary.Put (putByteString, putWord16le, putWord32le, putWord8) import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL import Data.Either (fromRight) import Data.Hashable -import Data.Serialize (Serialize (..)) import Data.Word (Word8) import GHC.Generics (Generic) @@ -49,28 +50,18 @@ newtype Script = Script deriving (Eq, Show, Read, Generic, Hashable, NFData) -instance Serial Script where - deserialize = +instance Binary Script where + get = Script <$> 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 + else (:) <$> get <*> getScriptOps -instance Serialize Script where - put = serialize - get = deserialize + put (Script ops) = mapM_ put ops -- | Data type representing the type of an OP_PUSHDATA opcode. @@ -216,8 +207,8 @@ data ScriptOp deriving (Show, Read, Eq, Generic, Hashable, NFData) -instance Serial ScriptOp where - deserialize = go . fromIntegral =<< getWord8 +instance Binary ScriptOp where + get = go . fromIntegral =<< getWord8 where go op | op == 0x00 = return OP_0 @@ -358,9 +349,9 @@ instance Serial ScriptOp where | otherwise = return $ OP_INVALIDOPCODE op - serialize op = case op of + put op = case op of (OP_PUSHDATA payload optype) -> do - let len = B.length payload + let len = BS.length payload case optype of OPCODE -> do unless (len <= 0x4b) $ @@ -508,16 +499,6 @@ instance Serial ScriptOp where OP_CHECKSIGADD -> putWord8 0xba -instance Binary ScriptOp where - put = serialize - get = deserialize - - -instance Serialize ScriptOp where - put = serialize - get = deserialize - - -- | Check whether opcode is only data. isPushOp :: ScriptOp -> Bool isPushOp op = case op of @@ -552,7 +533,7 @@ opPushData bs | len <= 0xffffffff = OP_PUSHDATA bs OPDATA4 | otherwise = error "opPushData: payload size too big" where - len = B.length bs + len = BS.length bs -- | Transforms integers @[1 .. 16]@ to 'ScriptOp' @[OP_1 .. OP_16]@. @@ -563,8 +544,8 @@ intToScriptOp i where op = fromRight err - . runGetS deserialize - . B.singleton + . U.decode + . BSL.singleton . fromIntegral $ i + 0x50 err = error $ "intToScriptOp: Invalid integer " ++ show i @@ -577,4 +558,4 @@ scriptOpToInt s | res `elem` [1 .. 16] = return res | otherwise = Left $ "scriptOpToInt: invalid opcode " ++ show s where - res = fromIntegral (B.head $ runPutS $ serialize s) - 0x50 + res = (fromIntegral . BSL.head . Bin.encode) s - 0x50 diff --git a/src/Bitcoin/Script/SigHash.hs b/src/Bitcoin/Script/SigHash.hs index fb672175..c6163a37 100644 --- a/src/Bitcoin/Script/SigHash.hs +++ b/src/Bitcoin/Script/SigHash.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -- | @@ -27,24 +28,39 @@ module Bitcoin.Script.SigHash ( decodeTxSig, ) where -import Bitcoin.Crypto -import Bitcoin.Crypto.Hash -import Bitcoin.Data -import Bitcoin.Network.Common -import Bitcoin.Script.Common -import Bitcoin.Transaction.Common -import Bitcoin.Util -import Control.DeepSeq -import Control.Monad -import Data.Bits +import Bitcoin.Crypto ( + Hash256, + Sig, + decodeStrictSig, + putSig, + ) +import Bitcoin.Crypto.Hash (doubleSHA256L) +import Bitcoin.Data (Network) +import Bitcoin.Network.Common (putVarInt) +import Bitcoin.Script.Common ( + Script (..), + ScriptOp (OP_CODESEPARATOR), + ) +import Bitcoin.Transaction.Common (Tx (..), TxIn (..), TxOut (TxOut)) +import Bitcoin.Util (updateIndex) +import qualified Bitcoin.Util as U +import Control.DeepSeq (NFData) +import Control.Monad (when) +import Data.Binary (put) +import qualified Data.Binary as Bin +import Data.Binary.Put ( + putLazyByteString, + putWord32le, + putWord64le, + putWord8, + runPut, + ) +import Data.Bits (Bits ((.&.), (.|.))) import qualified Data.ByteString as BS -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Hashable -import Data.Maybe -import Data.Scientific -import Data.Word +import qualified Data.ByteString.Lazy as BSL +import Data.Hashable (Hashable) +import Data.Maybe (fromMaybe) +import Data.Word (Word32, Word64) import GHC.Generics (Generic) @@ -174,17 +190,18 @@ txSigHash :: SigHash -> -- | hash to be signed Hash256 -txSigHash net tx out v i sh = do +txSigHash _net tx out _v i sh = do let newIn = buildInputs (txIn tx) fout i sh -- When SigSingle and input index > outputs, then sign integer 1 fromMaybe one $ do newOut <- buildOutputs (txOut tx) i sh let newTx = Tx (txVersion tx) newIn newOut [] (txLockTime tx) - return $ - doubleSHA256 $ - runPutS $ do - serialize newTx - putWord32le $ fromIntegral sh + return + . doubleSHA256L + . runPut + $ do + put newTx + putWord32le $ fromIntegral sh where fout = Script $ filter (/= OP_CODESEPARATOR) $ scriptOps out one = "0100000000000000000000000000000000000000000000000000000000000000" @@ -194,13 +211,13 @@ txSigHash net tx out v i sh = do buildInputs :: [TxIn] -> Script -> Int -> SigHash -> [TxIn] buildInputs txins out i sh | hasAnyoneCanPayFlag sh = - [(txins !! i){scriptInput = runPutS $ serialize out}] + [(txins !! i){scriptInput}] | 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} + single = updateIndex i emptyIn $ \ti -> ti{scriptInput} + scriptInput = U.encodeS out noSeq ti j = if i == j then ti @@ -235,38 +252,38 @@ txSigHashSegwitV0 :: -- | hash to be signed Hash256 txSigHashSegwitV0 _ tx out v i sh = - doubleSHA256 . runPutS $ do + doubleSHA256L . runPut $ do putWord32le $ txVersion tx - serialize hashPrevouts - serialize hashSequence - serialize $ prevOutput $ txIn tx !! i + put hashPrevouts + put hashSequence + put $ prevOutput $ txIn tx !! i putScript out putWord64le v putWord32le $ txInSequence $ txIn tx !! i - serialize hashOutputs + put hashOutputs putWord32le $ txLockTime tx putWord32le $ fromIntegral sh where hashPrevouts | not $ hasAnyoneCanPayFlag sh = - doubleSHA256 $ runPutS $ mapM_ (serialize . prevOutput) $ txIn tx + doubleSHA256L . runPut . mapM_ (put . prevOutput) $ txIn tx | otherwise = zeros hashSequence | not (hasAnyoneCanPayFlag sh) && not (isSigHashSingle sh) && not (isSigHashNone sh) = - doubleSHA256 $ runPutS $ mapM_ (putWord32le . txInSequence) $ txIn tx + doubleSHA256L . runPut . mapM_ (putWord32le . txInSequence) $ txIn tx | otherwise = zeros hashOutputs | not (isSigHashSingle sh) && not (isSigHashNone sh) = - doubleSHA256 $ runPutS $ mapM_ serialize $ txOut tx + doubleSHA256L . runPut . mapM_ put $ txOut tx | isSigHashSingle sh && i < length (txOut tx) = - doubleSHA256 $ runPutS $ serialize $ txOut tx !! i + doubleSHA256L . Bin.encode $ txOut tx !! i | otherwise = zeros putScript s = do - let encodedScript = runPutS $ serialize s - putVarInt $ BS.length encodedScript - putByteString encodedScript + let encodedScript = Bin.encode s + putVarInt $ BSL.length encodedScript + putLazyByteString encodedScript zeros :: Hash256 zeros = "0000000000000000000000000000000000000000000000000000000000000000" @@ -290,13 +307,14 @@ instance NFData 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) + BSL.toStrict . runPut $ putSig sig >> putWord8 (fromIntegral n) -- | Deserialize a 'TxSignature'. decodeTxSig :: Network -> BS.ByteString -> Either String TxSignature +-- TODO remove unused parameter decodeTxSig _ bs | BS.null bs = Left "Empty signature candidate" -decodeTxSig net bs = +decodeTxSig _net bs = case decodeStrictSig $ BS.init bs of Just sig -> do let sh = fromIntegral $ BS.last bs diff --git a/src/Bitcoin/Script/Standard.hs b/src/Bitcoin/Script/Standard.hs index 36042d49..c4d428ce 100644 --- a/src/Bitcoin/Script/Standard.hs +++ b/src/Bitcoin/Script/Standard.hs @@ -41,22 +41,34 @@ module Bitcoin.Script.Standard ( isScriptHashInput, ) where -import Bitcoin.Crypto -import Bitcoin.Data -import Bitcoin.Keys.Common -import Bitcoin.Script.Common -import Bitcoin.Script.SigHash -import Bitcoin.Util +import Bitcoin.Crypto.Hash (Hash160, Hash256, addressHashL, sha256L) +import Bitcoin.Data (Network) +import Bitcoin.Keys.Common (PubKeyI) +import Bitcoin.Script.Common ( + PushDataType (OPCODE), + Script (..), + ScriptOp (..), + intToScriptOp, + opPushData, + scriptOpToInt, + ) +import Bitcoin.Script.SigHash ( + TxSignature (TxSignatureEmpty), + decodeTxSig, + encodeTxSig, + ) +import Bitcoin.Util (eitherToMaybe, maybeToEither) +import qualified Bitcoin.Util as U import Control.Applicative ((<|>)) -import Control.DeepSeq +import Control.DeepSeq (NFData) import Control.Monad (guard, liftM2, (<=<)) +import Data.Binary (Binary) +import qualified Data.Binary as Bin import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial +import qualified Data.ByteString.Lazy as BSL import Data.Function (on) -import Data.Hashable +import Data.Hashable (Hashable) import Data.List (sortBy) import Data.Maybe (fromJust, isJust) import Data.Word (Word8) @@ -145,17 +157,17 @@ isDataCarrier _ = False decodeOutput :: Script -> Either String ScriptOutput decodeOutput s = case scriptOps s of -- Pay to PubKey - [OP_PUSHDATA bs _, OP_CHECKSIG] -> PayPK <$> runGetS deserialize bs + [OP_PUSHDATA bs _, OP_CHECKSIG] -> PayPK <$> (U.decode . BSL.fromStrict) bs -- Pay to PubKey Hash [OP_DUP, OP_HASH160, OP_PUSHDATA bs _, OP_EQUALVERIFY, OP_CHECKSIG] -> - PayPKHash <$> runGetS deserialize bs + PayPKHash <$> (U.decode . BSL.fromStrict) bs -- Pay to Script Hash [OP_HASH160, OP_PUSHDATA bs _, OP_EQUAL] -> - PayScriptHash <$> runGetS deserialize bs + PayScriptHash <$> (U.decode . BSL.fromStrict) bs -- Pay to Witness [OP_0, OP_PUSHDATA bs OPCODE] - | BS.length bs == 20 -> PayWitnessPKHash <$> runGetS deserialize bs - | BS.length bs == 32 -> PayWitnessScriptHash <$> runGetS deserialize bs + | BS.length bs == 20 -> PayWitnessPKHash <$> (U.decode . BSL.fromStrict) bs + | BS.length bs == 32 -> PayWitnessScriptHash <$> (U.decode . BSL.fromStrict) bs | BS.length bs /= 20 && BS.length bs /= 32 -> Left "Version 0 segwit program must be 20 or 32 bytes long" -- Other Witness @@ -214,19 +226,20 @@ opWitnessVersion _ = Nothing -- | Similar to 'decodeOutput' but decodes from a 'ByteString'. decodeOutputBS :: ByteString -> Either String ScriptOutput -decodeOutputBS = decodeOutput <=< runGetS deserialize +decodeOutputBS = decodeOutput <=< U.decode . BSL.fromStrict -- | Computes a 'Script' from a standard 'ScriptOutput'. encodeOutput :: ScriptOutput -> Script +-- FIXME this might be a good place to also have strict serialization of keys encodeOutput s = Script $ case s of -- Pay to PubKey - (PayPK k) -> [opPushData $ runPutS $ serialize k, OP_CHECKSIG] + (PayPK k) -> [pushItem k, OP_CHECKSIG] -- Pay to PubKey Hash Address (PayPKHash h) -> [ OP_DUP , OP_HASH160 - , opPushData $ runPutS $ serialize h + , pushItem h , OP_EQUALVERIFY , OP_CHECKSIG ] @@ -235,17 +248,17 @@ encodeOutput s = Script $ case s of | r <= length ps -> let opM = intToScriptOp r opN = intToScriptOp $ length ps - keys = map (opPushData . runPutS . serialize) ps + keys = pushItem <$> ps in opM : keys ++ [opN, OP_CHECKMULTISIG] | otherwise -> error "encodeOutput: PayMulSig r must be <= than pkeys" -- Pay to Script Hash Address (PayScriptHash h) -> - [OP_HASH160, opPushData $ runPutS $ serialize h, OP_EQUAL] + [OP_HASH160, pushItem h, OP_EQUAL] -- Pay to Witness PubKey Hash Address (PayWitnessPKHash h) -> - [OP_0, opPushData $ runPutS $ serialize h] + [OP_0, pushItem h] (PayWitnessScriptHash h) -> - [OP_0, opPushData $ runPutS $ serialize h] + [OP_0, pushItem h] (PayWitness v h) -> [ case witnessVersionOp v of Nothing -> error "encodeOutput: invalid witness version" @@ -256,19 +269,23 @@ encodeOutput s = Script $ case s of (DataCarrier d) -> [OP_RETURN, opPushData d] +pushItem :: Binary a => a -> ScriptOp +pushItem = opPushData . U.encodeS + + -- | Similar to 'encodeOutput' but encodes to a ByteString encodeOutputBS :: ScriptOutput -> ByteString -encodeOutputBS = runPutS . serialize . encodeOutput +encodeOutputBS = U.encodeS . encodeOutput -- | Encode script as pay-to-script-hash script toP2SH :: Script -> ScriptOutput -toP2SH = PayScriptHash . addressHash . runPutS . serialize +toP2SH = PayScriptHash . addressHashL . Bin.encode -- | Encode script as a pay-to-witness-script-hash script toP2WSH :: Script -> ScriptOutput -toP2WSH = PayWitnessScriptHash . sha256 . runPutS . serialize +toP2WSH = PayWitnessScriptHash . sha256L . Bin.encode -- | Match @[OP_N, PubKey1, ..., PubKeyM, OP_M, OP_CHECKMULTISIG]@ @@ -281,7 +298,7 @@ matchPayMulSig (Script ops) = case splitAt (length ops - 2) ops of 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 (OP_PUSHDATA bs _ : xs) = liftM2 (:) (U.decode $ BSL.fromStrict bs) (go xs) go [] = return [] go _ = Left "matchPayMulSig: invalid multisig opcode" @@ -290,7 +307,7 @@ matchPayMulSig (Script ops) = case splitAt (length ops - 2) ops of -- 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 + PayMulSig keys r -> PayMulSig (sortBy (compare `on` Bin.encode) keys) r _ -> error "Can only call orderMulSig on PayMulSig scripts" @@ -370,7 +387,7 @@ decodeSimpleInput net (Script ops) = matchPK [op] = SpendPK <$> f op matchPK _ = Nothing matchPKHash [op, OP_PUSHDATA pub _] = - SpendPKHash <$> f op <*> eitherToMaybe (runGetS deserialize pub) + SpendPKHash <$> f op <*> (eitherToMaybe . U.decode . BSL.fromStrict) pub matchPKHash _ = Nothing matchMulSig (x : xs) = do guard $ x == OP_0 @@ -404,7 +421,7 @@ decodeInput net s@(Script ops) = -- | Like 'decodeInput' but decodes directly from a serialized script -- 'ByteString'. decodeInputBS :: Network -> ByteString -> Either String ScriptInput -decodeInputBS net = decodeInput net <=< runGetS deserialize +decodeInputBS net = decodeInput net <=< U.decode . BSL.fromStrict -- | Encode a standard input into a script. @@ -419,7 +436,7 @@ encodeInput s = case s of -- | Similar to 'encodeInput' but encodes directly to a serialized script -- 'ByteString'. encodeInputBS :: ScriptInput -> ByteString -encodeInputBS = runPutS . serialize . encodeInput +encodeInputBS = U.encodeS . encodeInput -- | Encode a standard 'SimpleInput' into opcodes as an input 'Script'. @@ -428,7 +445,7 @@ encodeSimpleInput s = Script $ case s of SpendPK ts -> [f ts] - SpendPKHash ts p -> [f ts, opPushData $ runPutS $ serialize p] + SpendPKHash ts p -> [f ts, pushItem p] SpendMulSig xs -> OP_0 : map f xs where f TxSignatureEmpty = OP_0 diff --git a/src/Bitcoin/Transaction/Builder.hs b/src/Bitcoin/Transaction/Builder.hs index 353161d0..59198f02 100644 --- a/src/Bitcoin/Transaction/Builder.hs +++ b/src/Bitcoin/Transaction/Builder.hs @@ -27,13 +27,38 @@ module Bitcoin.Transaction.Builder ( verifyStdInput, ) where -import Bitcoin.Address -import Bitcoin.Crypto.Hash (Hash256, addressHash) -import Bitcoin.Crypto.Signature -import Bitcoin.Data -import Bitcoin.Keys.Common -import Bitcoin.Network.Common -import Bitcoin.Script +import Bitcoin.Address ( + addressToOutput, + p2pkhAddr, + p2shAddr, + p2wpkhAddr, + p2wshAddr, + payToScriptAddress, + payToWitnessScriptAddress, + pubKeyAddr, + pubKeyWitnessAddr, + textToAddr, + ) +import Bitcoin.Crypto.Hash (Hash256, addressHash, addressHashL) +import Bitcoin.Crypto.Signature (verifyHashSig) +import Bitcoin.Data (Network) +import Bitcoin.Keys.Common (PubKeyI (pubKeyPoint), SecKeyI) +import Bitcoin.Script ( + RedeemScript, + Script (Script), + ScriptInput (..), + ScriptOp (OP_PUSHDATA), + ScriptOutput (..), + SigHash, + SimpleInput (..), + TxSignature (..), + decodeInputBS, + decodeOutputBS, + encodeInputBS, + encodeOutput, + encodeOutputBS, + txSigHash, + ) import Bitcoin.Transaction.Builder.Sign ( SigInput (..), buildInput, @@ -41,21 +66,27 @@ import Bitcoin.Transaction.Builder.Sign ( sigKeys, ) import qualified Bitcoin.Transaction.Builder.Sign as S -import Bitcoin.Transaction.Common +import Bitcoin.Transaction.Common ( + OutPoint, + Tx (..), + TxIn (TxIn, prevOutput, scriptInput), + TxOut (TxOut), + WitnessStack, + ) import Bitcoin.Transaction.Segwit ( decodeWitnessInput, isSegwit, viewWitnessProgram, ) -import Bitcoin.Util +import Bitcoin.Util (matchTemplate, maybeToEither, updateIndex) +import qualified Bitcoin.Util as U import Control.Applicative ((<|>)) import Control.Arrow (first) import Control.Monad (foldM, unless) -import Crypto.Secp256k1 -import qualified Data.ByteString as B -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial +import Crypto.Secp256k1 (PubKey, SecKey) +import qualified Data.Binary as Bin +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL import Data.Either (fromRight) import Data.List (nub) import Data.Maybe (catMaybes, fromJust, isJust) @@ -85,7 +116,7 @@ buildTx :: [OutPoint] -> [(ScriptOutput, Word64)] -> Tx buildTx ops rcpts = Tx 1 (toIn <$> ops) (toOut <$> rcpts) [] 0 where - toIn op = TxIn op B.empty maxBound + toIn op = TxIn op BS.empty maxBound toOut (o, v) = TxOut v $ encodeOutputBS o @@ -171,7 +202,7 @@ mergeTxs net txs os 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}) + ins is i = updateIndex i is (\ti -> ti{scriptInput = BS.empty}) clearInput tx (_, i) = Tx (txVersion tx) (ins (txIn tx) i) (txOut tx) [] (txLockTime tx) @@ -187,7 +218,7 @@ mergeTxInput :: mergeTxInput net txs tx ((so, val), i) = do -- Ignore transactions with empty inputs let ins = map (scriptInput . (!! i) . txIn) txs - sigRes <- mapM extractSigs $ filter (not . B.null) ins + sigRes <- mapM extractSigs $ filter (not . BS.null) ins let rdm = snd $ head sigRes unless (all ((== rdm) . snd) sigRes) $ Left "Redeem scripts do not match" si <- encodeInputBS <$> go (nub $ concatMap fst sigRes) so rdm @@ -259,7 +290,7 @@ verifyStdInput net tx i so0 val nestedScriptOutput :: Either String ScriptOutput nestedScriptOutput = - runGetS deserialize inp + U.decode (BSL.fromStrict inp) >>= \case Script [OP_PUSHDATA bs _] -> decodeOutputBS bs _ -> Left "nestedScriptOutput: not a nested output" @@ -290,7 +321,7 @@ verifyStdInput net tx i so0 val && 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 + && addressHashL (Bin.encode pub) == kh && verifyHashSig (theTxSigHash so sh $ Just rdm') sig (pubKeyPoint pub) (PayWitnessScriptHash h, Just rdm'@(PayMulSig pubs r), SpendMulSig sigs) -> payToWitnessScriptAddress rdm' == p2wshAddr h diff --git a/src/Bitcoin/Transaction/Builder/Sign.hs b/src/Bitcoin/Transaction/Builder/Sign.hs index ea885017..31485209 100644 --- a/src/Bitcoin/Transaction/Builder/Sign.hs +++ b/src/Bitcoin/Transaction/Builder/Sign.hs @@ -29,15 +29,38 @@ import Bitcoin.Keys.Common ( derivePubKeyI, wrapSecKey, ) -import Bitcoin.Script -import Bitcoin.Transaction.Common -import Bitcoin.Transaction.Segwit +import Bitcoin.Script ( + RedeemScript, + ScriptInput (..), + ScriptOutput (..), + SigHash, + SimpleInput (..), + TxSignature (..), + decodeInputBS, + decodeTxSig, + encodeInputBS, + encodeOutput, + encodeOutputBS, + opPushData, + txSigHash, + txSigHashSegwitV0, + ) +import Bitcoin.Transaction.Common ( + OutPoint, + Tx (..), + TxIn (..), + WitnessData, + ) +import Bitcoin.Transaction.Segwit ( + WitnessProgram (EmptyWitnessProgram), + calcWitnessProgram, + isSegwit, + toWitnessStack, + ) import Bitcoin.Util (matchTemplate, updateIndex) +import qualified Bitcoin.Util as U import Control.DeepSeq (NFData) import Control.Monad (foldM, when) -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial import Data.Either (rights) import Data.Hashable (Hashable) import Data.List (find, nub) @@ -118,7 +141,7 @@ signInput net tx i (sigIn@(SigInput so val _ _ rdmM), nest) key = do } where f si x = x{scriptInput = encodeInputBS si} - g so' x = x{scriptInput = runPutS . serialize . opPushData $ encodeOutputBS so'} + g so' x = x{scriptInput = U.encodeS . opPushData $ encodeOutputBS so'} txis = txIn tx nextTxIn so' si | isSegwit so' && nest = updateIndex i txis (g so') diff --git a/src/Bitcoin/Transaction/Common.hs b/src/Bitcoin/Transaction/Common.hs index d370b127..486baa9f 100644 --- a/src/Bitcoin/Transaction/Common.hs +++ b/src/Bitcoin/Transaction/Common.hs @@ -24,11 +24,17 @@ module Bitcoin.Transaction.Common ( nullOutPoint, ) where -import Bitcoin.Crypto.Hash -import Bitcoin.Network.Common -import Bitcoin.Util +import Bitcoin.Crypto.Hash (Hash256, doubleSHA256, doubleSHA256L) +import Bitcoin.Network.Common (VarInt (VarInt), putVarInt) +import Bitcoin.Util ( + decodeHex, + eitherToMaybe, + encodeHex, + hexBuilder, + ) +import qualified Bitcoin.Util as U import Control.Applicative ((<|>)) -import Control.DeepSeq +import Control.DeepSeq (NFData) import Control.Monad ( forM_, guard, @@ -39,38 +45,27 @@ import Control.Monad ( when, (<=<), ) -import Data.Binary (Binary (..)) +import Data.Binary (Binary (..), Get, Put) +import qualified Data.Binary as Bin +import qualified Data.Binary.Get as Get +import qualified Data.Binary.Put as Put import Data.ByteString (ByteString) -import qualified Data.ByteString as B +import qualified Data.ByteString as BS import Data.ByteString.Builder (char7) -import qualified Data.ByteString.Lazy as BL -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial +import qualified Data.ByteString.Lazy as BSL 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) import Data.Word (Word32, Word64) import GHC.Generics (Generic) -import Text.Read as R +import qualified 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 + deriving (Eq, Ord, Generic, Hashable, Binary, NFData) instance Show TxHash where @@ -92,24 +87,24 @@ instance IsString TxHash where -- | Transaction hash excluding signatures. nosigTxHash :: Tx -> TxHash nosigTxHash tx = - TxHash $ - doubleSHA256 $ - runPutS $ - serialize tx{txIn = map clearInput $ txIn tx} + TxHash + . doubleSHA256L + $ Bin.encode + tx{txIn = map clearInput $ txIn tx} where - clearInput ti = ti{scriptInput = B.empty} + clearInput ti = ti{scriptInput = BS.empty} -- | Convert transaction hash to hex form, reversing bytes. txHashToHex :: TxHash -> Text -txHashToHex (TxHash h) = encodeHex (B.reverse (runPutS (serialize h))) +txHashToHex (TxHash h) = encodeHex . BS.reverse $ U.encodeS h -- | Convert transaction hash from hex, reversing bytes. hexToTxHash :: Text -> Maybe TxHash hexToTxHash hex = do - bs <- B.reverse <$> decodeHex hex - h <- either (const Nothing) Just (runGetS deserialize bs) + bs <- BS.reverse <$> decodeHex hex + h <- either (const Nothing) Just . U.decode $ BSL.fromStrict bs return $ TxHash h @@ -143,77 +138,67 @@ data Tx = Tx -- | Compute transaction hash. txHash :: Tx -> TxHash -txHash tx = TxHash . doubleSHA256 . runPutS $ serialize tx{txWitness = []} +txHash tx = TxHash . doubleSHA256L $ Bin.encode tx{txWitness = []} instance IsString Tx where fromString = - fromMaybe e . (eitherToMaybe . runGetS deserialize <=< decodeHex) . cs + fromMaybe e . (eitherToMaybe . U.decode . BSL.fromStrict <=< decodeHex) . cs where e = error "Could not read transaction from hex string" -instance Serial Tx where - deserialize = +instance Binary Tx where + get = isWitnessTx >>= \w -> if w then parseWitnessTx else parseLegacyTx - serialize tx + put tx | 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 -> Put putInOut tx = do putVarInt $ length (txIn tx) - forM_ (txIn tx) serialize + forM_ (txIn tx) put putVarInt $ length (txOut tx) - forM_ (txOut tx) serialize + forM_ (txOut tx) put --- | Non-SegWit transaction serializer. -putLegacyTx :: MonadPut m => Tx -> m () +-- | Non-SegWit transaction serialization. +putLegacyTx :: Tx -> Put putLegacyTx tx = do - putWord32le (txVersion tx) + Put.putWord32le (txVersion tx) putInOut tx - putWord32le (txLockTime tx) + Put.putWord32le (txLockTime tx) --- | Witness transaciton serializer. -putWitnessTx :: MonadPut m => Tx -> m () +-- | Witness transaciton serialization. +putWitnessTx :: Tx -> Put putWitnessTx tx = do - putWord32le (txVersion tx) - putWord8 0x00 - putWord8 0x01 + Put.putWord32le (txVersion tx) + Put.putWord8 0x00 + Put.putWord8 0x01 putInOut tx putWitnessData (txWitness tx) - putWord32le (txLockTime tx) + Put.putWord32le (txLockTime tx) -isWitnessTx :: MonadGet m => m Bool -isWitnessTx = lookAhead $ do - _ <- getWord32le - m <- getWord8 - f <- getWord8 +isWitnessTx :: Get Bool +isWitnessTx = Get.lookAhead $ do + _ <- Get.getWord32le + m <- Get.getWord8 + f <- Get.getWord8 return (m == 0x00 && f == 0x01) -- | Non-SegWit transaction deseralizer. -parseLegacyTx :: MonadGet m => m Tx +parseLegacyTx :: Get Tx parseLegacyTx = do - v <- getWord32le - is <- replicateList =<< deserialize - os <- replicateList =<< deserialize + v <- Get.getWord32le + is <- replicateList =<< get + os <- replicateList =<< get when (length is == 0x00 && length os == 0x01) $ fail "Witness transaction" - l <- getWord32le + l <- Get.getWord32le return Tx { txVersion = v @@ -223,48 +208,48 @@ parseLegacyTx = do , txLockTime = l } where - replicateList (VarInt c) = replicateM (fromIntegral c) deserialize + replicateList (VarInt c) = replicateM (fromIntegral c) get --- | Witness transaction deserializer. -parseWitnessTx :: MonadGet m => m Tx +-- | Witness transaction getr. +parseWitnessTx :: Get Tx parseWitnessTx = do - v <- getWord32le - m <- getWord8 - f <- getWord8 + v <- Get.getWord32le + m <- Get.getWord8 + f <- Get.getWord8 unless (m == 0x00 && f == 0x01) $ fail "Not a witness transaction" - is <- replicateList =<< deserialize - os <- replicateList =<< deserialize + is <- replicateList =<< get + os <- replicateList =<< get w <- parseWitnessData $ length is - l <- getWord32le + l <- Get.getWord32le return Tx{txVersion = v, txIn = is, txOut = os, txWitness = w, txLockTime = l} where - replicateList (VarInt c) = replicateM (fromIntegral c) deserialize + replicateList (VarInt c) = replicateM (fromIntegral c) get --- | Witness data deserializer. Requires count of inputs. -parseWitnessData :: MonadGet m => Int -> m WitnessData +-- | Witness data getr. Requires count of inputs. +parseWitnessData :: Int -> Get WitnessData parseWitnessData n = replicateM n parseWitnessStack where parseWitnessStack = do - VarInt i <- deserialize + VarInt i <- get replicateM (fromIntegral i) parseWitnessStackItem parseWitnessStackItem = do - VarInt i <- deserialize - getByteString $ fromIntegral i + VarInt i <- get + Get.getByteString $ fromIntegral i --- | Witness data serializer. -putWitnessData :: MonadPut m => WitnessData -> m () +-- | Witness data serialization. +putWitnessData :: WitnessData -> Put putWitnessData = mapM_ putWitnessStack where putWitnessStack ws = do putVarInt $ length ws mapM_ putWitnessStackItem ws putWitnessStackItem bs = do - putVarInt $ B.length bs - putByteString bs + putVarInt $ BS.length bs + Put.putByteString bs -- | Data type representing a transaction input. @@ -279,28 +264,18 @@ 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 - - - serialize (TxIn o s q) = do - serialize o - putVarInt $ B.length s - putByteString s - putWord32le q - - instance Binary TxIn where - get = deserialize - put = serialize + get = + TxIn <$> get <*> (readBS =<< get) <*> Get.getWord32le + where + readBS (VarInt len) = Get.getByteString $ fromIntegral len -instance Serialize TxIn where - get = deserialize - put = serialize + put (TxIn o s q) = do + put o + putVarInt $ BS.length s + Put.putByteString s + Put.putWord32le q -- | Data type representing a transaction output. @@ -313,27 +288,17 @@ 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 + get = do + val <- Get.getWord64le + VarInt len <- get + TxOut val <$> Get.getByteString (fromIntegral len) -instance Serialize TxOut where - put = serialize - get = deserialize + put (TxOut o s) = do + Put.putWord64le o + putVarInt $ BS.length s + Put.putByteString s -- | The 'OutPoint' refers to a transaction output being spent. @@ -346,21 +311,11 @@ 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 + get = do + (h, i) <- liftM2 (,) get Get.getWord32le + return $ OutPoint h i + put (OutPoint h i) = put h >> Put.putWord32le i -- | Outpoint used in coinbase transactions. diff --git a/src/Bitcoin/Transaction/Partial.hs b/src/Bitcoin/Transaction/Partial.hs index 1c438564..31aaeec9 100644 --- a/src/Bitcoin/Transaction/Partial.hs +++ b/src/Bitcoin/Transaction/Partial.hs @@ -87,14 +87,16 @@ import Bitcoin.Transaction.Common ( ) import Bitcoin.Transaction.Segwit (isSegwit) import Bitcoin.Util (eitherToMaybe) +import qualified Bitcoin.Util as U import Control.Applicative ((<|>)) import Control.DeepSeq import Control.Monad (foldM, guard, replicateM, void) +import Data.Binary (Binary (..)) +import Data.Binary.Get (Get, getByteString, getWord32le, getWord8, isolate, lookAhead) +import Data.Binary.Put (Put, putByteString, putLazyByteString, putWord32le, putWord8, runPut) import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Bytes.Get (runGetS) -import Data.Bytes.Put (runPutS) -import Data.Bytes.Serial (Serial (..)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL import Data.Either (fromRight) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM @@ -102,8 +104,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) @@ -449,7 +449,7 @@ completeSig :: Input -> ScriptOutput -> Input completeSig input (PayPK k) = input { finalScriptSig = - eitherToMaybe . runGetS deserialize + eitherToMaybe . U.decode . BSL.fromStrict =<< HashMap.lookup k (partialSigs input) } completeSig input (PayPKHash h) @@ -460,7 +460,7 @@ completeSig input (PayPKHash h) Just $ Script [ opPushData sig - , opPushData (runPutS (serialize k)) + , opPushData $ U.encodeS k ] } completeSig input (PayMulSig pubKeys m) @@ -487,7 +487,7 @@ completeSig input (PayScriptHash h) completeSig input (PayWitnessPKHash h) | [(k, sig)] <- HashMap.toList (partialSigs input) , PubKeyAddress h == pubKeyAddr k = - input{finalScriptWitness = Just [sig, runPutS $ serialize k]} + input{finalScriptWitness = Just [sig, U.encodeS k]} completeSig input (PayWitnessScriptHash h) | Just witScript <- inputWitnessScript input , PayWitnessScriptHash h == toP2WSH witScript @@ -497,7 +497,7 @@ completeSig input _ = input serializedRedeemScript :: Script -> Script -serializedRedeemScript = Script . pure . opPushData . runPutS . serialize +serializedRedeemScript = Script . pure . opPushData . U.encodeS completeWitnessSig :: Input -> ScriptOutput -> Input @@ -539,7 +539,7 @@ finalTransaction psbt = , txWitness = if hasWitness then reverse witData else [] } finalizeInput (ins, witData) (txInput, psbtInput) = - ( txInput{scriptInput = maybe mempty (runPutS . serialize) $ finalScriptSig psbtInput} : ins + ( txInput{scriptInput = maybe mempty U.encodeS $ finalScriptSig psbtInput} : ins , fromMaybe [] (finalScriptWitness psbtInput) : witData ) @@ -575,33 +575,33 @@ emptyOutput :: Output emptyOutput = Output Nothing Nothing HashMap.empty (UnknownMap HashMap.empty) -instance Serialize PartiallySignedTransaction where +instance Binary PartiallySignedTransaction where get = do - magic <- S.getBytes 4 + magic <- getByteString 4 guard $ magic == "psbt" - headerSep <- S.getWord8 + headerSep <- getWord8 guard $ headerSep == 0xff - keySize <- S.getWord8 + keySize <- getWord8 guard $ keySize == 1 - globalUnsignedTxType <- S.getWord8 + globalUnsignedTxType <- getWord8 guard $ globalUnsignedTxType == 0x00 - unsignedTransaction <- getSizedBytes deserialize - guard $ all (B.null . scriptInput) (txIn unsignedTransaction) + unsignedTransaction <- getSizedBytes get + guard $ all (BS.null . scriptInput) (txIn unsignedTransaction) guard $ null (txWitness unsignedTransaction) - globalUnknown <- S.get - globalEnd <- S.getWord8 + globalUnknown <- get + globalEnd <- getWord8 guard $ globalEnd == 0x00 inputs <- replicateM (length (txIn unsignedTransaction)) - S.get + get outputs <- replicateM (length (txOut unsignedTransaction)) - S.get + get return PartiallySignedTransaction @@ -619,41 +619,41 @@ instance Serialize PartiallySignedTransaction where , 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 + putByteString "psbt" + putWord8 0xff -- Header separator + putWord8 0x01 -- Key size + putWord8 0x00 -- Unsigned Transaction type + putSizedBytes $ put unsignedTransaction + put globalUnknown + putWord8 0x00 -- Global end + mapM_ put inputs + mapM_ put outputs + + +instance Binary Key where get = do - VarInt keySize <- deserialize + VarInt keySize <- get guard $ keySize > 0 - t <- S.getWord8 - k <- S.getBytes (fromIntegral keySize - 1) + t <- getWord8 + k <- getByteString (fromIntegral keySize - 1) return (Key t k) put (Key t k) = do - putVarInt $ 1 + B.length k - S.putWord8 t - S.putByteString k + putVarInt $ 1 + BS.length k + putWord8 t + putByteString k -instance Serialize UnknownMap where +instance Binary UnknownMap where get = go HashMap.empty where getItem m = do - k <- S.get - VarString v <- deserialize + k <- get + VarString v <- get go $ HashMap.insert k v m go m = do - isEnd <- S.lookAhead S.getWord8 + isEnd <- lookAhead getWord8 if isEnd == 0x00 then return (UnknownMap m) else getItem m @@ -662,11 +662,11 @@ instance Serialize UnknownMap where put (UnknownMap m) = void $ HashMap.traverseWithKey - (\k v -> S.put k >> serialize (VarString v)) + (\k v -> put k >> put (VarString v)) m -instance Serialize Input where +instance Binary Input where get = getMap getInputItem setInputUnknown emptyInput where @@ -691,43 +691,43 @@ instance Serialize Input where , inputUnknown } = do whenJust - (putKeyValue InNonWitnessUtxo . serialize) + (putKeyValue InNonWitnessUtxo . put) nonWitnessUtxo whenJust - (putKeyValue InWitnessUtxo . serialize) + (putKeyValue InWitnessUtxo . put) witnessUtxo putPartialSig partialSigs whenJust putSigHash sigHashType whenJust - (putKeyValue InRedeemScript . serialize) + (putKeyValue InRedeemScript . put) inputRedeemScript whenJust - (putKeyValue InWitnessScript . serialize) + (putKeyValue InWitnessScript . put) inputWitnessScript putHDPath InBIP32Derivation inputHDKeypaths whenJust - (putKeyValue InFinalScriptSig . serialize) + (putKeyValue InFinalScriptSig . put) finalScriptSig whenJust (putKeyValue InFinalScriptWitness . putFinalScriptWitness) finalScriptWitness - S.put inputUnknown - S.putWord8 0x00 + put inputUnknown + putWord8 0x00 where putPartialSig = - putPubKeyMap serialize InPartialSig . fmap VarString + putPubKeyMap put InPartialSig . fmap VarString putSigHash sigHash = do putKey InSigHashType - S.putWord8 0x04 - S.putWord32le (fromIntegral sigHash) + putWord8 0x04 + putWord32le (fromIntegral sigHash) putFinalScriptWitness witnessStack = do - S.put $ (VarInt . fromIntegral . length) witnessStack - mapM_ (serialize . VarString) witnessStack + put $ (VarInt . fromIntegral . length) witnessStack + mapM_ (put . VarString) witnessStack -instance Serialize Output where +instance Binary Output where get = getMap getOutputItem setOutputUnknown emptyOutput where setOutputUnknown f output = @@ -745,30 +745,30 @@ instance Serialize Output where , outputUnknown } = do whenJust - (putKeyValue OutRedeemScript . serialize) + (putKeyValue OutRedeemScript . put) outputRedeemScript whenJust - (putKeyValue OutWitnessScript . serialize) + (putKeyValue OutWitnessScript . put) outputWitnessScript putHDPath OutBIP32Derivation outputHDKeypaths - S.put outputUnknown - S.putWord8 0x00 + put outputUnknown + putWord8 0x00 putSizedBytes :: Put -> Put putSizedBytes f = do - putVarInt (B.length bs) - S.putByteString bs + putVarInt (BSL.length bs) + putLazyByteString bs where - bs = S.runPut f + bs = runPut f getSizedBytes :: Get a -> Get a -getSizedBytes = - S.getNested - (fromIntegral . getVarInt <$> deserialize) +getSizedBytes getItem = do + n <- fromIntegral . getVarInt <$> get + isolate n getItem putKeyValue :: Enum t => t -> Put -> Put @@ -780,7 +780,7 @@ putKeyValue t v = do putKey :: Enum t => t -> Put putKey t = do putVarInt (1 :: Word8) - S.putWord8 (enumWord8 t) + putWord8 (enumWord8 t) getMap :: @@ -794,14 +794,14 @@ getMap getMapItem setUnknown = go 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 + k <- getByteString (fromIntegral keySize - 1) + VarString v <- get go $ setUnknown (HashMap.insert (Key t k) v) m go m = do - keySize <- getVarInt <$> deserialize + keySize <- getVarInt <$> get if keySize == 0 then return m - else getItem keySize m . word8Enum =<< S.getWord8 + else getItem keySize m . word8Enum =<< getWord8 data InputType @@ -832,10 +832,10 @@ instance NFData OutputType getInputItem :: Int -> Input -> InputType -> Get Input getInputItem 0 input@Input{nonWitnessUtxo = Nothing} InNonWitnessUtxo = do - utxo <- getSizedBytes deserialize + utxo <- getSizedBytes get return input{nonWitnessUtxo = Just utxo} getInputItem 0 input@Input{witnessUtxo = Nothing} InWitnessUtxo = do - utxo <- getSizedBytes deserialize + utxo <- getSizedBytes get return input{witnessUtxo = Just utxo} getInputItem keySize input InPartialSig = do (k, v) <- getPartialSig @@ -846,18 +846,18 @@ getInputItem keySize input InPartialSig = do where getPartialSig = (,) - <$> S.isolate keySize deserialize - <*> (getVarString <$> deserialize) + <$> isolate keySize get + <*> (getVarString <$> get) getInputItem 0 input@Input{sigHashType = Nothing} InSigHashType = do - VarInt size <- deserialize + VarInt size <- get guard $ size == 0x04 - sigHash <- fromIntegral <$> S.getWord32le + sigHash <- fromIntegral <$> getWord32le return $ input{sigHashType = Just sigHash} getInputItem 0 input@Input{inputRedeemScript = Nothing} InRedeemScript = do - script <- getSizedBytes deserialize + script <- getSizedBytes get return $ input{inputRedeemScript = Just script} getInputItem 0 input@Input{inputWitnessScript = Nothing} InWitnessScript = do - script <- getSizedBytes deserialize + script <- getSizedBytes get return $ input{inputWitnessScript = Just script} getInputItem keySize input InBIP32Derivation = do (k, v) <- getHDPath keySize @@ -866,15 +866,15 @@ getInputItem keySize input InBIP32Derivation = do { inputHDKeypaths = HashMap.insert k v (inputHDKeypaths input) } getInputItem 0 input@Input{finalScriptSig = Nothing} InFinalScriptSig = do - script <- getSizedBytes deserialize + script <- getSizedBytes get 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 + VarInt n <- get -- Item count + replicateM (fromIntegral n) get getInputItem keySize input inputType = fail $ "Incorrect key size for input item or item already existed: " @@ -883,10 +883,10 @@ getInputItem keySize input inputType = getOutputItem :: Int -> Output -> OutputType -> Get Output getOutputItem 0 output@Output{outputRedeemScript = Nothing} OutRedeemScript = do - script <- getSizedBytes deserialize + script <- getSizedBytes get return $ output{outputRedeemScript = Just script} getOutputItem 0 output@Output{outputWitnessScript = Nothing} OutWitnessScript = do - script <- getSizedBytes deserialize + script <- getSizedBytes get return $ output{outputWitnessScript = Just script} getOutputItem keySize output OutBIP32Derivation = do (k, v) <- getHDPath keySize @@ -900,12 +900,12 @@ getOutputItem keySize output outputType = getHDPath :: Int -> Get (PubKeyI, (Fingerprint, [KeyIndex])) getHDPath keySize = (,) - <$> S.isolate keySize deserialize - <*> (unPSBTHDPath <$> S.get) + <$> isolate keySize get + <*> (unPSBTHDPath <$> get) putHDPath :: Enum t => t -> HashMap PubKeyI (Fingerprint, [KeyIndex]) -> Put -putHDPath t = putPubKeyMap S.put t . fmap PSBTHDPath +putHDPath t = putPubKeyMap put t . fmap PSBTHDPath newtype PSBTHDPath = PSBTHDPath {unPSBTHDPath :: (Fingerprint, [KeyIndex])} @@ -915,24 +915,24 @@ newtype PSBTHDPath = PSBTHDPath {unPSBTHDPath :: (Fingerprint, [KeyIndex])} instance NFData PSBTHDPath -instance Serialize PSBTHDPath where +instance Binary PSBTHDPath where get = do - VarInt valueSize <- deserialize + VarInt valueSize <- get guard $ valueSize `mod` 4 == 0 let numIndices = (fromIntegral valueSize - 4) `div` 4 PSBTHDPath - <$> S.isolate + <$> isolate (fromIntegral valueSize) - ((,) <$> S.get <*> getKeyIndexList numIndices) + ((,) <$> get <*> getKeyIndexList numIndices) where - getKeyIndexList n = replicateM n S.getWord32le + getKeyIndexList n = replicateM n getWord32le put (PSBTHDPath (fp, kis)) = do - putVarInt (B.length bs) - S.putByteString bs + putVarInt (BSL.length bs) + putLazyByteString bs where - bs = S.runPut $ S.put fp >> mapM_ S.putWord32le kis + bs = runPut $ put fp >> mapM_ putWord32le kis putPubKeyMap :: Enum t => (a -> Put) -> t -> HashMap PubKeyI a -> Put @@ -940,7 +940,7 @@ putPubKeyMap f t = void . HashMap.traverseWithKey putItem where putItem k v = do - S.put $ Key (enumWord8 t) (runPutS (serialize k)) + put $ Key (enumWord8 t) $ U.encodeS k f v diff --git a/src/Bitcoin/Transaction/Segwit.hs b/src/Bitcoin/Transaction/Segwit.hs index 76aefb8b..4e3cc0f1 100644 --- a/src/Bitcoin/Transaction/Segwit.hs +++ b/src/Bitcoin/Transaction/Segwit.hs @@ -23,14 +23,24 @@ module Bitcoin.Transaction.Segwit ( toWitnessStack, ) where -import Bitcoin.Data -import Bitcoin.Keys.Common -import Bitcoin.Script -import Bitcoin.Transaction.Common +import Bitcoin.Data (Network) +import Bitcoin.Keys.Common (PubKeyI) +import Bitcoin.Script ( + Script, + ScriptInput (..), + ScriptOutput (..), + SimpleInput (..), + TxSignature (TxSignatureEmpty), + decodeOutput, + decodeTxSig, + encodeOutput, + encodeTxSig, + ) +import Bitcoin.Transaction.Common (WitnessStack) +import qualified Bitcoin.Util as U +import qualified Data.Binary as Bin import Data.ByteString (ByteString) -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial +import qualified Data.ByteString.Lazy as BSL -- | Test if a 'ScriptOutput' is P2WPKH or P2WSH @@ -52,8 +62,11 @@ data WitnessProgram -- | Encode a witness program toWitnessStack :: WitnessProgram -> WitnessStack toWitnessStack = \case - P2WPKH (WitnessProgramPKH sig key) -> [encodeTxSig sig, runPutS (serialize key)] - P2WSH (WitnessProgramSH stack scr) -> stack <> [runPutS (serialize scr)] + P2WPKH (WitnessProgramPKH sig key) -> + [ encodeTxSig sig + , U.encodeS key + ] + P2WSH (WitnessProgramSH stack scr) -> stack <> [U.encodeS scr] EmptyWitnessProgram -> mempty @@ -79,10 +92,10 @@ viewWitnessProgram :: viewWitnessProgram net so witness = case so of PayWitnessPKHash _ | length witness == 2 -> do sig <- decodeTxSig net $ head witness - pubkey <- runGetS deserialize $ witness !! 1 + pubkey <- U.decode . BSL.fromStrict $ witness !! 1 return . P2WPKH $ WitnessProgramPKH sig pubkey PayWitnessScriptHash _ | not (null witness) -> do - redeemScript <- runGetS deserialize $ last witness + redeemScript <- U.decode . BSL.fromStrict $ last witness return . P2WSH $ WitnessProgramSH (init witness) redeemScript _ | null witness -> return EmptyWitnessProgram @@ -102,7 +115,7 @@ decodeWitnessInput net = \case (PayPK _, [sigBS]) -> SpendPK <$> decodeTxSig net sigBS (PayPKHash _, [sigBS, keyBS]) -> - SpendPKHash <$> decodeTxSig net sigBS <*> runGetS deserialize keyBS + SpendPKHash <$> decodeTxSig net sigBS <*> U.decode (BSL.fromStrict keyBS) (PayMulSig _ _, "" : sigsBS) -> SpendMulSig <$> traverse (decodeTxSig net) sigsBS _ -> Left "decodeWitnessInput: Non-standard script output" @@ -126,7 +139,7 @@ calcWitnessProgram so si = case (so, si) of simpleInputStack :: SimpleInput -> [ByteString] simpleInputStack = \case SpendPK sig -> [f sig] - SpendPKHash sig k -> [f sig, runPutS (serialize k)] + SpendPKHash sig k -> [f sig, U.encodeS k] SpendMulSig sigs -> "" : fmap f sigs where f TxSignatureEmpty = "" diff --git a/src/Bitcoin/Transaction/Taproot.hs b/src/Bitcoin/Transaction/Taproot.hs index 594d1bae..4cc0339f 100644 --- a/src/Bitcoin/Transaction/Taproot.hs +++ b/src/Bitcoin/Transaction/Taproot.hs @@ -27,12 +27,13 @@ module Bitcoin.Transaction.Taproot ( import Bitcoin.Crypto (PubKey, initTaggedHash, tweak, tweakAddPubKey) import Bitcoin.Keys.Common (PubKeyI (PubKeyI), pubKeyPoint) +import Bitcoin.Network.Common (VarInt (VarInt)) import Bitcoin.Script.Common (Script) import Bitcoin.Script.Standard (ScriptOutput (PayWitness)) import Bitcoin.Transaction.Common (WitnessStack) -import Bitcoin.Util (decodeHex, eitherToMaybe, encodeHex) +import Bitcoin.Util (eitherToMaybe) +import qualified Bitcoin.Util as U import Control.Applicative (many) -import Control.Monad ((<=<)) import Crypto.Hash ( Digest, SHA256, @@ -42,18 +43,18 @@ import Crypto.Hash ( hashUpdates, ) import Data.Binary (Binary (..)) +import qualified Data.Binary as Bin +import Data.Binary.Get (getByteString, getLazyByteString, getWord8) +import Data.Binary.Put (putLazyByteString, runPut) 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.Put (putByteString, runPutS) -import Data.Bytes.Serial (Serial (..), deserialize, serialize) -import Data.Bytes.VarInt (VarInt (VarInt)) +import qualified Data.ByteString.Lazy as BSL import Data.Foldable (foldl') +import Data.Function (on) import Data.Maybe (fromMaybe, mapMaybe) -import Data.Serialize (Serialize, get, getByteString, getWord8, put) import Data.Word (Word8) @@ -65,31 +66,20 @@ newtype XOnlyPubKey = XOnlyPubKey {xOnlyPubKey :: PubKey} instance Eq XOnlyPubKey where - k1 == k2 = runPutS (serialize k1) == runPutS (serialize k2) + (==) = (==) `on` Bin.encode -instance Serial XOnlyPubKey where - serialize (XOnlyPubKey pk) = - putByteString - . BS.drop 1 - . runPutS - . serialize +instance Binary XOnlyPubKey where + put (XOnlyPubKey pk) = + putLazyByteString + . BSL.drop 1 + . Bin.encode $ PubKeyI pk True - deserialize = + get = either fail (pure . XOnlyPubKey . pubKeyPoint) - . runGetS deserialize - . BS.cons 0x02 - =<< getBytes 32 - - -instance Serialize XOnlyPubKey where - put = serialize - get = deserialize - - -instance Binary XOnlyPubKey where - put = serialize - get = deserialize + . U.decode + . BSL.cons 0x02 + =<< getLazyByteString 32 type TapLeafVersion = Word8 @@ -142,14 +132,15 @@ hashBranch hashA hashB = leafHash :: TapLeafVersion -> Script -> Digest SHA256 leafHash leafVersion leafScript = hashFinalize - . hashUpdate (initTaggedHash "TapLeaf") - . runPutS + . hashUpdates (initTaggedHash "TapLeaf") + . BSL.toChunks + . runPut $ do - serialize leafVersion - serialize $ VarInt (BS.length scriptBytes) - putByteString scriptBytes + put leafVersion + put $ (VarInt . fromIntegral . BSL.length) scriptBytes + putLazyByteString scriptBytes where - scriptBytes = runPutS $ serialize leafScript + scriptBytes = Bin.encode leafScript -- | Representation of a full taproot output. @@ -173,15 +164,15 @@ taprootCommitment internalKey merkleRoot = BA.convert . hashFinalize . maybe id (flip hashUpdate) merkleRoot - . (`hashUpdate` keyBytes) + . (`hashUpdates` BSL.toChunks keyBytes) $ initTaggedHash "TapTweak" where - keyBytes = runPutS . serialize $ XOnlyPubKey internalKey + keyBytes = Bin.encode $ XOnlyPubKey internalKey -- | Generate the output script for a taproot output taprootScriptOutput :: TaprootOutput -> ScriptOutput -taprootScriptOutput = PayWitness 0x01 . runPutS . serialize . XOnlyPubKey . taprootOutputKey +taprootScriptOutput = PayWitness 0x01 . U.encodeS . XOnlyPubKey . taprootOutputKey -- | Comprehension of taproot witness data @@ -216,7 +207,7 @@ viewTaprootWitness witnessStack = case reverse witnessStack of where parseSpendPathData scriptPathAnnex = \case scriptBytes : controlBytes : scriptPathStack -> do - scriptPathScript <- eitherToMaybe $ runGetS deserialize scriptBytes + scriptPathScript <- eitherToMaybe . U.decode $ BSL.fromStrict scriptBytes (v, scriptPathInternalKey, scriptPathControl) <- deconstructControl controlBytes pure . ScriptPathSpend $ ScriptPathData @@ -229,10 +220,10 @@ viewTaprootWitness witnessStack = case reverse witnessStack of , scriptPathControl } _ -> Nothing - deconstructControl = eitherToMaybe . runGetS deserializeControl + deconstructControl = eitherToMaybe . U.runGet deserializeControl . BSL.fromStrict deserializeControl = do v <- getWord8 - k <- xOnlyPubKey <$> deserialize + k <- xOnlyPubKey <$> get proof <- many $ getByteString 32 pure (v, k, proof) @@ -243,10 +234,10 @@ encodeTaprootWitness = \case KeyPathSpend signature -> pure signature ScriptPathSpend scriptPathData -> scriptPathStack scriptPathData - <> [ runPutS . serialize $ scriptPathScript scriptPathData + <> [ U.encodeS $ scriptPathScript scriptPathData , mconcat [ BS.pack [scriptPathLeafVersion scriptPathData .|. parity scriptPathData] - , runPutS . serialize . XOnlyPubKey $ scriptPathInternalKey scriptPathData + , U.encodeS . XOnlyPubKey $ scriptPathInternalKey scriptPathData , mconcat $ scriptPathControl scriptPathData ] , fromMaybe mempty $ scriptPathAnnex scriptPathData @@ -277,6 +268,6 @@ verifyScriptPathData outputKey scriptPathData = fromMaybe False $ do keyParity :: PubKey -> Word8 -keyParity key = case BS.unpack . runPutS . serialize $ PubKeyI key True of +keyParity key = case BSL.unpack . Bin.encode $ PubKeyI key True of 0x02 : _ -> 0x00 _ -> 0x01 diff --git a/src/Bitcoin/Util.hs b/src/Bitcoin/Util.hs index 11845d26..e285ff43 100644 --- a/src/Bitcoin/Util.hs +++ b/src/Bitcoin/Util.hs @@ -34,6 +34,9 @@ module Bitcoin.Util ( lst3, -- * Serialization Helpers + encodeS, + decode, + runGet, putList, getList, putMaybe, @@ -52,35 +55,37 @@ module Bitcoin.Util ( putTwo, ) where -import Control.Monad +import Control.Monad (replicateM) import Control.Monad.Trans.Except (ExceptT (..), except) -import Data.Bits +import Data.Bifunctor (bimap) +import Data.Binary (Binary, Get, Put) +import qualified Data.Binary as Bin +import qualified Data.Binary as Get +import qualified Data.Binary.Get as Get +import qualified Data.Binary.Put as Put +import Data.Bits (Bits (..)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Base16 as B16 -import Data.ByteString.Builder -import qualified Data.ByteString.Lazy as BL +import Data.ByteString.Builder (Builder, lazyByteStringHex) +import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Base16 as BL16 -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Char (toLower) -import Data.Int +import Data.Int (Int32, Int64) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap -import Data.List +import Data.List (foldl', unfoldr) import Data.Text (Text) import qualified Data.Text.Encoding as E import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as EL -import Data.Word +import Data.Word (Word8) -- ByteString helpers -- | Decode a big endian 'Integer' from a 'ByteString'. -bsToInteger :: ByteString -> Integer -bsToInteger = BS.foldr f 0 . BS.reverse +bsToInteger :: BSL.ByteString -> Integer +bsToInteger = BSL.foldr f 0 . BSL.reverse where f w n = toInteger w .|. shiftL n 8 @@ -96,7 +101,7 @@ integerToBS i f x = Just (fromInteger x :: Word8, x `shiftR` 8) -hexBuilder :: BL.ByteString -> Builder +hexBuilder :: BSL.ByteString -> Builder hexBuilder = lazyByteStringHex @@ -105,7 +110,7 @@ encodeHex = B16.encodeBase16 -- | Encode as string of human-readable hex characters. -encodeHexLazy :: BL.ByteString -> TL.Text +encodeHexLazy :: BSL.ByteString -> TL.Text encodeHexLazy = BL16.encodeBase16 @@ -114,7 +119,7 @@ decodeHex = eitherToMaybe . B16.decodeBase16 . E.encodeUtf8 -- | Decode string of human-readable hex characters. -decodeHexLazy :: TL.Text -> Maybe BL.ByteString +decodeHexLazy :: TL.Text -> Maybe BSL.ByteString decodeHexLazy = eitherToMaybe . BL16.decodeBase16 . EL.encodeUtf8 @@ -238,84 +243,96 @@ convertBits pad frombits tobits i = (reverse yout, rem') -- Serialization helpers -- -putInt32be :: MonadPut m => Int32 -> m () +encodeS :: Binary a => a -> ByteString +encodeS = BSL.toStrict . Bin.encode + + +decode :: Binary a => BSL.ByteString -> Either String a +decode = bimap lst3 lst3 . Get.decodeOrFail + + +runGet :: Get a -> BSL.ByteString -> Either String a +runGet parser = bimap lst3 lst3 . Get.runGetOrFail parser + + +putInt32be :: Int32 -> Put putInt32be n - | n < 0 = putWord32be (complement (fromIntegral (abs n)) + 1) - | otherwise = putWord32be (fromIntegral (abs n)) + | n < 0 = Put.putWord32be (complement (fromIntegral (abs n)) + 1) + | otherwise = Put.putWord32be (fromIntegral (abs n)) -getInt32be :: MonadGet m => m Int32 +getInt32be :: Get Int32 getInt32be = do - n <- getWord32be + n <- Get.getWord32be if testBit n 31 then return (negate (complement (fromIntegral n) + 1)) else return (fromIntegral n) -putInt64be :: MonadPut m => Int64 -> m () +putInt64be :: Int64 -> Put putInt64be n - | n < 0 = putWord64be (complement (fromIntegral (abs n)) + 1) - | otherwise = putWord64be (fromIntegral (abs n)) + | n < 0 = Put.putWord64be (complement (fromIntegral (abs n)) + 1) + | otherwise = Put.putWord64be (fromIntegral (abs n)) -getInt64be :: MonadGet m => m Int64 +getInt64be :: Get Int64 getInt64be = do - n <- getWord64be + n <- Get.getWord64be if testBit n 63 then return (negate (complement (fromIntegral n) + 1)) else return (fromIntegral n) -putInteger :: MonadPut m => Integer -> m () +putInteger :: Integer -> Put putInteger n | n >= lo && n <= hi = do - putWord8 0x00 + Put.putWord8 0x00 putInt32be (fromIntegral n) | otherwise = do - putWord8 0x01 - putWord8 (fromIntegral (signum n)) + Put.putWord8 0x01 + Put.putWord8 (fromIntegral (signum n)) let len = (nrBits (abs n) + 7) `div` 8 - putWord64be (fromIntegral len) - mapM_ putWord8 (unroll (abs n)) + Put.putWord64be (fromIntegral len) + mapM_ Put.putWord8 (unroll (abs n)) where lo = fromIntegral (minBound :: Int32) hi = fromIntegral (maxBound :: Int32) -getInteger :: MonadGet m => m Integer +getInteger :: Get Integer getInteger = - getWord8 >>= \case + Get.getWord8 >>= \case 0 -> fromIntegral <$> getInt32be _ -> do - sign <- getWord8 - bytes <- getList getWord8 + sign <- Get.getWord8 + bytes <- getList Get.getWord8 let v = roll bytes return $! if sign == 0x01 then v else -v -putMaybe :: MonadPut m => (a -> m ()) -> Maybe a -> m () -putMaybe f Nothing = putWord8 0x00 -putMaybe f (Just x) = putWord8 0x01 >> f x +putMaybe :: (a -> Put) -> Maybe a -> Put +putMaybe f Nothing = Put.putWord8 0x00 +putMaybe f (Just x) = Put.putWord8 0x01 >> f x -getMaybe :: MonadGet m => m a -> m (Maybe a) +getMaybe :: Get a -> Get (Maybe a) getMaybe f = - getWord8 >>= \case + Get.getWord8 >>= \case 0x00 -> return Nothing 0x01 -> Just <$> f _ -> fail "Not a Maybe" -putLengthBytes :: MonadPut m => ByteString -> m () +putLengthBytes :: ByteString -> Put putLengthBytes bs = do - putWord64be (fromIntegral (BS.length bs)) - putByteString bs + Put.putWord64be (fromIntegral (BS.length bs)) + Put.putByteString bs -getLengthBytes :: MonadGet m => m ByteString +getLengthBytes :: Get ByteString getLengthBytes = do - len <- fromIntegral <$> getWord64be - getByteString len + len <- fromIntegral <$> Get.getWord64be + Get.getByteString len -- @@ -348,29 +365,29 @@ nrBits k = -- | Read as a list of pairs of int and element. -getIntMap :: MonadGet m => m Int -> m a -> m (IntMap a) +getIntMap :: Get Int -> Get a -> Get (IntMap a) getIntMap i m = IntMap.fromList <$> getList (getTwo i m) -putIntMap :: MonadPut m => (Int -> m ()) -> (a -> m ()) -> IntMap a -> m () +putIntMap :: (Int -> Put) -> (a -> Put) -> IntMap a -> Put putIntMap f g = putList (putTwo f g) . IntMap.toAscList -putTwo :: MonadPut m => (a -> m ()) -> (b -> m ()) -> (a, b) -> m () +putTwo :: (a -> Put) -> (b -> Put) -> (a, b) -> Put putTwo f g (x, y) = f x >> g y -getTwo :: MonadGet m => m a -> m b -> m (a, b) +getTwo :: Get a -> Get b -> Get (a, b) getTwo f g = (,) <$> f <*> g -putList :: MonadPut m => (a -> m ()) -> [a] -> m () +putList :: (a -> Put) -> [a] -> Put putList f ls = do - putWord64be (fromIntegral (length ls)) + Put.putWord64be (fromIntegral (length ls)) mapM_ f ls -getList :: MonadGet m => m a -> m [a] +getList :: Get a -> Get [a] getList f = do - l <- fromIntegral <$> getWord64be + l <- fromIntegral <$> Get.getWord64be replicateM l f diff --git a/src/Bitcoin/Util/Arbitrary/Address.hs b/src/Bitcoin/Util/Arbitrary/Address.hs index d55d62e1..5ecbf8fb 100644 --- a/src/Bitcoin/Util/Arbitrary/Address.hs +++ b/src/Bitcoin/Util/Arbitrary/Address.hs @@ -10,7 +10,7 @@ import Bitcoin.Constants import Bitcoin.Data import Bitcoin.Util.Arbitrary.Crypto import Bitcoin.Util.Arbitrary.Util -import qualified Data.ByteString as B +import qualified Data.ByteString as BS import Test.QuickCheck @@ -63,5 +63,5 @@ arbitraryWitnessAddress = do ver <- choose (1, 16) len <- choose (2, 40) ws <- vectorOf len arbitrary - let bs = B.pack ws + let bs = BS.pack ws return $ WitnessAddress ver bs diff --git a/src/Bitcoin/Util/Arbitrary/Crypto.hs b/src/Bitcoin/Util/Arbitrary/Crypto.hs index 4bef79bc..3e3eebdf 100644 --- a/src/Bitcoin/Util/Arbitrary/Crypto.hs +++ b/src/Bitcoin/Util/Arbitrary/Crypto.hs @@ -3,9 +3,19 @@ -- Portability : POSIX module Bitcoin.Util.Arbitrary.Crypto where -import Bitcoin.Crypto.Hash -import Bitcoin.Util.Arbitrary.Util -import Test.QuickCheck +import Bitcoin.Crypto.Hash ( + CheckSum32, + Hash160, + Hash256, + Hash512, + checkSum32, + ripemd160, + sha256, + sha512, + ) +import Bitcoin.Util.Arbitrary.Util (arbitraryBSn) +import qualified Data.ByteString.Lazy as BSL +import Test.QuickCheck (Gen) -- | Arbitrary 160-bit hash. @@ -29,4 +39,4 @@ arbitraryHash512 = -- | Arbitrary 32-bit checksum. arbitraryCheckSum32 :: Gen CheckSum32 arbitraryCheckSum32 = - checkSum32 <$> arbitraryBSn 4 + checkSum32 . BSL.fromStrict <$> arbitraryBSn 4 diff --git a/src/Bitcoin/Util/Arbitrary/Network.hs b/src/Bitcoin/Util/Arbitrary/Network.hs index cd112c64..8f61a958 100644 --- a/src/Bitcoin/Util/Arbitrary/Network.hs +++ b/src/Bitcoin/Util/Arbitrary/Network.hs @@ -3,14 +3,44 @@ -- Portability : POSIX module Bitcoin.Util.Arbitrary.Network where -import Bitcoin.Network -import Bitcoin.Util.Arbitrary.Crypto -import Bitcoin.Util.Arbitrary.Util +import Bitcoin.Network ( + Addr (Addr), + Alert (Alert), + BloomFilter, + BloomFlags (..), + FilterAdd (FilterAdd), + FilterLoad (FilterLoad), + GetData (GetData), + Inv (Inv), + InvType (..), + InvVector (InvVector), + MessageCommand (..), + NetworkAddress (NetworkAddress), + NotFound (NotFound), + Ping (Ping), + Pong (Pong), + Reject (Reject), + RejectCode (..), + VarInt (VarInt), + VarString (VarString), + Version (Version), + bloomCreate, + ) +import Bitcoin.Util.Arbitrary.Crypto (arbitraryHash256) +import Bitcoin.Util.Arbitrary.Util (arbitraryBS) import qualified Data.ByteString as BS (empty, pack) import qualified Data.ByteString.Char8 as C8 import Data.Word (Word16, Word32) -import Network.Socket (SockAddr (..)) -import Test.QuickCheck +import Test.QuickCheck ( + ASCIIString (ASCIIString), + Arbitrary (arbitrary), + Gen, + choose, + elements, + listOf1, + oneof, + vectorOf, + ) -- | Arbitrary 'VarInt'. @@ -25,21 +55,15 @@ arbitraryVarString = VarString <$> arbitraryBS -- | Arbitrary 'NetworkAddress'. arbitraryNetworkAddress :: Gen NetworkAddress -arbitraryNetworkAddress = do - s <- arbitrary - a <- arbitrary - p <- arbitrary - d <- - oneof - [ do - b <- arbitrary - c <- arbitrary - d <- arbitrary - return $ SockAddrInet6 (fromIntegral p) 0 (a, b, c, d) 0 - , return $ SockAddrInet (fromIntegral (p :: Word16)) a - ] - let n = sockToHostAddress d - return $ NetworkAddress s n +arbitraryNetworkAddress = + NetworkAddress + <$> arbitrary + <*> ( (,,,) + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + ) -- | Arbitrary 'NetworkAddressTime'. diff --git a/src/Bitcoin/Util/Arbitrary/Script.hs b/src/Bitcoin/Util/Arbitrary/Script.hs index 05919adc..96e34bbe 100644 --- a/src/Bitcoin/Util/Arbitrary/Script.hs +++ b/src/Bitcoin/Util/Arbitrary/Script.hs @@ -17,7 +17,7 @@ import Bitcoin.Util.Arbitrary.Crypto import Bitcoin.Util.Arbitrary.Keys import Bitcoin.Util.Arbitrary.Util import Crypto.Secp256k1 -import qualified Data.ByteString as B +import qualified Data.ByteString as BS import Data.Maybe import Data.Word import Test.QuickCheck @@ -292,7 +292,7 @@ arbitraryWitOutput = do ver <- choose (1, 16) len <- choose (2, 40) ws <- vectorOf len arbitrary - let bs = B.pack ws + let bs = BS.pack ws return $ PayWitness ver bs diff --git a/src/Bitcoin/Util/Arbitrary/Util.hs b/src/Bitcoin/Util/Arbitrary/Util.hs index 845a2cd3..d75e0b0a 100644 --- a/src/Bitcoin/Util/Arbitrary/Util.hs +++ b/src/Bitcoin/Util/Arbitrary/Util.hs @@ -20,24 +20,26 @@ module Bitcoin.Util.Arbitrary.Util ( fromMap, ) where -import Bitcoin.Constants -import Bitcoin.Data +import Bitcoin.Constants (Network, allNets) import Control.Monad (forM_, (<=<)) import Data.ByteString (ByteString, pack) 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 import qualified Data.Map.Strict as Map -import Data.Proxy import Data.Time.Clock (UTCTime (..)) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import qualified Data.Typeable as T import Data.Word (Word32) import Test.Hspec (Spec, describe, shouldBe, shouldSatisfy) import Test.Hspec.QuickCheck (prop) -import Test.QuickCheck +import Test.QuickCheck ( + Arbitrary (arbitrary), + Gen, + elements, + frequency, + listOf1, + vectorOf, + ) -- | Arbitrary strict 'ByteString'. diff --git a/stack.yaml b/stack.yaml index 5f3db2d3..5a6a9190 100644 --- a/stack.yaml +++ b/stack.yaml @@ -6,3 +6,4 @@ nix: - pkg-config extra-deps: - fourmolu-0.8.2.0 + - cryptonite-0.30 diff --git a/stack.yaml.lock b/stack.yaml.lock index 64fdfd07..c24f3d9f 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -11,6 +11,13 @@ packages: size: 143718 original: hackage: fourmolu-0.8.2.0 +- completed: + hackage: cryptonite-0.30@sha256:12c85dea7be63e5ad90bcb487eb3846bf3c413347f94336fa1dede7b28f9936a,18301 + pantry-tree: + sha256: df1cbe4cc40d569cc75ffed40bc5deac43cb085653980b42b9b6a5d4b745a30a + size: 23323 + original: + hackage: cryptonite-0.30 snapshots: - completed: sha256: 1ecad1f0bd2c27de88dbff6572446cfdf647c615d58a7e2e2085c6b7dfc04176 diff --git a/test/Bitcoin/Address/Bech32Spec.hs b/test/Bitcoin/Address/Bech32Spec.hs index adf777c6..14535607 100644 --- a/test/Bitcoin/Address/Bech32Spec.hs +++ b/test/Bitcoin/Address/Bech32Spec.hs @@ -10,7 +10,7 @@ import Bitcoin.Util import Control.Monad import Data.Bits (xor) import Data.ByteString (ByteString) -import qualified Data.ByteString as B +import qualified Data.ByteString as BS import Data.Char (chr, ord, toLower) import Data.Maybe import Data.String.Conversions @@ -120,7 +120,7 @@ testInvalidAddress address = do segwitScriptPubkey :: Word8 -> [Word8] -> ByteString segwitScriptPubkey witver witprog = - B.pack $ witver' : fromIntegral (length witprog) : witprog + BS.pack $ witver' : fromIntegral (length witprog) : witprog where witver' = if witver == 0 then 0 else witver + 0x50 diff --git a/test/Bitcoin/AddressSpec.hs b/test/Bitcoin/AddressSpec.hs index 8a5b3224..cc19e53a 100644 --- a/test/Bitcoin/AddressSpec.hs +++ b/test/Bitcoin/AddressSpec.hs @@ -1,31 +1,48 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} module Bitcoin.AddressSpec (spec) where -import Bitcoin.Address -import Bitcoin.Constants -import Bitcoin.Data -import Bitcoin.Keys -import Bitcoin.Util -import Bitcoin.Util.Arbitrary -import Bitcoin.UtilSpec hiding (spec) -import Data.Aeson -import Data.Aeson.Encoding +import Bitcoin.Address ( + Address, + addrToText, + addressToOutput, + decodeBase58, + decodeBase58Check, + encodeBase58, + encodeBase58Check, + outputAddress, + pubKeyCompatWitnessAddr, + textToAddr, + ) +import Bitcoin.Constants (Network, btcTest) +import Bitcoin.Keys (derivePubKeyI, fromWif) +import Bitcoin.Util (decodeHex, encodeHex) +import Bitcoin.Util.Arbitrary ( + arbitraryAddress, + arbitraryAddressAll, + arbitraryBS, + arbitraryNetAddress, + ) +import Bitcoin.UtilSpec ( + NetBox (..), + ReadBox (..), + SerialBox (..), + testIdentity, + ) +import Data.Aeson (Encoding, ToJSON (toJSON), Value, withText) +import Data.Aeson.Encoding (null_, text) import Data.Aeson.Types (Parser) import Data.ByteString (ByteString) import qualified Data.ByteString as BS (append, empty, pack) -import Data.Bytes.Serial -import Data.Foldable +import qualified Data.ByteString.Lazy as BSL import Data.Maybe (fromJust, isJust) -import Data.Proxy (Proxy (..)) import Data.Text (Text) -import qualified Data.Text as T -import Data.Typeable (Typeable, typeRep) -import Test.HUnit -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck +import Test.HUnit (Assertion, assertBool, assertEqual) +import Test.Hspec (Spec, describe, it) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (forAll) addrToJSON :: Network -> Address -> Value @@ -64,11 +81,11 @@ spec = do testIdentity serialVals readVals [] netVals describe "Address properties" $ do prop "encodes and decodes base58 bytestring" $ - forAll arbitraryBS $ \bs -> - decodeBase58 (encodeBase58 bs) == Just bs + forAll (BSL.fromStrict <$> arbitraryBS) $ \bs -> + (decodeBase58 . encodeBase58) bs == Just bs prop "encodes and decodes base58 bytestring with checksum" $ - forAll arbitraryBS $ \bs -> - decodeBase58Check (encodeBase58Check bs) == Just bs + forAll (BSL.fromStrict <$> arbitraryBS) $ \bs -> + (decodeBase58Check . encodeBase58Check) bs == Just bs prop "textToAddr . addrToText identity" $ forAll arbitraryNetAddress $ \(net, a) -> (textToAddr net =<< addrToText net a) == Just a @@ -89,7 +106,7 @@ spec = do testVector :: (ByteString, Text, Text) -> Assertion -testVector (bs, e, chk) = do +testVector (BSL.fromStrict -> bs, e, chk) = do assertEqual "encodeBase58" e b58 assertEqual "encodeBase58Check" chk b58Chk assertEqual "decodeBase58" (Just bs) (decodeBase58 b58) @@ -133,10 +150,10 @@ vectors = testBase58Vector :: (Text, Text) -> Assertion testBase58Vector (a, b) = do assertEqual "encodeBase58 match" b (encodeBase58 bsA) - assertEqual "decodeBase58 match" a (encodeHex bsB) + assertEqual "decodeBase58 match" a $ (encodeHex . BSL.toStrict) bsB assertEqual "bytestring match" bsA bsB where - bsA = fromJust $ decodeHex a + bsA = BSL.fromStrict . fromJust $ decodeHex a bsB = fromJust $ decodeBase58 b @@ -190,7 +207,7 @@ base58Vectors = testBase58InvalidVector :: (Text, Maybe Text) -> Assertion testBase58InvalidVector (a, resM) = - assertEqual "decodeBase58 invalid match" resM (encodeHex <$> decodeBase58 a) + assertEqual "decodeBase58 invalid match" resM $ encodeHex . BSL.toStrict <$> decodeBase58 a base58InvalidVectors :: [(Text, Maybe Text)] @@ -213,7 +230,7 @@ testBase58ChkInvalidVector (a, resM) = assertEqual "decodeBase58Check invalid match" resM - (encodeHex <$> decodeBase58Check a) + $ encodeHex . BSL.toStrict <$> decodeBase58Check a base58ChkInvalidVectors :: [(Text, Maybe Text)] diff --git a/test/Bitcoin/BlockSpec.hs b/test/Bitcoin/BlockSpec.hs index 7ea9ff84..54fdc833 100644 --- a/test/Bitcoin/BlockSpec.hs +++ b/test/Bitcoin/BlockSpec.hs @@ -4,32 +4,71 @@ module Bitcoin.BlockSpec ( spec, ) where -import Bitcoin.Block -import Bitcoin.Constants -import Bitcoin.Data +import Bitcoin.Block ( + BlockHeader, + BlockHeaders, + BlockNode (nodeHeader, nodeHeight), + HeaderMemory, + Timestamp, + appendBlocks, + blockHashToHex, + buildMerkleRoot, + buildPartialMerkle, + calcTreeHeight, + calcTreeWidth, + computeAssertBits, + computeSubsidy, + connectBlocks, + decodeCompact, + encodeCompact, + extractMatches, + hexToBlockHash, + initialChain, + splitPoint, + ) +import Bitcoin.Constants ( + Network (..), + btc, + btcRegTest, + ) import Bitcoin.Orphans () -import Bitcoin.Transaction -import Bitcoin.Util -import Bitcoin.Util.Arbitrary -import Bitcoin.UtilSpec hiding (spec) -import Control.Monad (MonadPlus (..), forM_, unless, (<=<)) -import Control.Monad.Trans.State.Strict -import Data.Aeson -import Data.Aeson.Encoding -import qualified Data.ByteString.Lazy as BL -import Data.Bytes.Get -import Data.Bytes.Put (runPutL, runPutS) -import Data.Bytes.Serial +import Bitcoin.Transaction (TxHash (getTxHash), hexToTxHash) +import Bitcoin.Util.Arbitrary ( + arbitraryBlock, + arbitraryBlockHash, + arbitraryBlockHeader, + arbitraryBlockNode, + arbitraryGetBlocks, + arbitraryGetHeaders, + arbitraryHeaders, + arbitraryMerkleBlock, + arbitraryNetwork, + arbitraryTxHash, + ) +import Bitcoin.UtilSpec ( + JsonBox (..), + ReadBox (..), + SerialBox (..), + testIdentity, + ) +import Control.Monad (forM_, unless) +import Control.Monad.Trans.State.Strict (State, evalState) import Data.Either (fromRight) import Data.Maybe (fromJust) import Data.String (fromString) import Data.String.Conversions (cs) import Data.Text (Text) import Data.Word (Word32) -import Test.HUnit hiding (State) -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck +import Test.HUnit (Assertion, assertBool, assertEqual) +import Test.Hspec (Spec, SpecWith, describe, it, runIO, shouldBe) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck ( + Arbitrary (arbitrary), + Property, + forAll, + listOf1, + (==>), + ) import Text.Printf (printf) diff --git a/test/Bitcoin/Crypto/HashSpec.hs b/test/Bitcoin/Crypto/HashSpec.hs index 65a8d65c..420f521a 100644 --- a/test/Bitcoin/Crypto/HashSpec.hs +++ b/test/Bitcoin/Crypto/HashSpec.hs @@ -2,29 +2,49 @@ module Bitcoin.Crypto.HashSpec (spec) where -import Bitcoin.Block -import Bitcoin.Crypto -import Bitcoin.Util -import Bitcoin.Util.Arbitrary -import Bitcoin.UtilSpec hiding (spec) -import Data.Bits +import Bitcoin.Block (decodeCompact, encodeCompact) +import Bitcoin.Crypto ( + Hash160 (getHash160), + Hash256 (..), + Hash512 (getHash512), + hmac256, + hmac512, + join512, + ripemd160, + sha1, + sha256, + sha512, + split512, + ) +import Bitcoin.Util (decodeHex, encodeHex) +import qualified Bitcoin.Util as U +import Bitcoin.Util.Arbitrary ( + arbitraryBS, + arbitraryBSS, + arbitraryHash160, + arbitraryHash256, + arbitraryHash512, + ) +import Bitcoin.UtilSpec ( + ReadBox (..), + SerialBox (..), + testIdentity, + ) +import Data.Bits (Bits (shiftR)) import Data.ByteString (ByteString) -import Data.ByteString.Builder +import Data.ByteString.Builder (Builder, toLazyByteString, word8) import qualified Data.ByteString.Char8 as C -import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Short as BSS -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial import Data.Maybe (fromJust) import Data.String (fromString) -import Data.String.Conversions +import Data.String.Conversions (cs) import Data.Text (Text) -import Data.Word -import Test.HUnit -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck +import Data.Word (Word32) +import Test.HUnit (Assertion, assertEqual) +import Test.Hspec (Spec, describe, it) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (forAll) serialVals :: [SerialBox] @@ -57,13 +77,13 @@ spec = prop "decodeCompact . encodeCompact i == i" decEncCompact prop "from string Hash512" $ forAll arbitraryHash512 $ \h -> - fromString (cs $ encodeHex $ runPutS $ serialize h) == h + fromString (cs . encodeHex $ U.encodeS h) == h prop "from string Hash256" $ forAll arbitraryHash256 $ \h -> - fromString (cs $ encodeHex $ runPutS $ serialize h) == h + fromString (cs . encodeHex $ U.encodeS h) == h prop "from string Hash160" $ forAll arbitraryHash160 $ \h -> - fromString (cs $ encodeHex $ runPutS $ serialize h) == h + fromString (cs . encodeHex $ U.encodeS h) == h describe "Test Vectors" $ do it "Passes RIPEMD160 test vectors" $ mapM_ (testVector ripemd160 getHash160) ripemd160Vectors @@ -121,7 +141,7 @@ testHMACVector f1 f2 (k, m, res) = longTestString :: ByteString longTestString = - BL.toStrict $! toLazyByteString $! go [0 .. 199999] + BSL.toStrict $! toLazyByteString $! go [0 .. 199999] where go :: [Word32] -> Builder go [] = mempty diff --git a/test/Bitcoin/Crypto/SignatureSpec.hs b/test/Bitcoin/Crypto/SignatureSpec.hs index 9b33ef96..53ff9b61 100644 --- a/test/Bitcoin/Crypto/SignatureSpec.hs +++ b/test/Bitcoin/Crypto/SignatureSpec.hs @@ -2,29 +2,69 @@ module Bitcoin.Crypto.SignatureSpec (spec) where -import Bitcoin.Address -import Bitcoin.Constants -import Bitcoin.Crypto -import Bitcoin.Keys -import Bitcoin.Script -import Bitcoin.Transaction -import Bitcoin.Util -import Bitcoin.Util.Arbitrary +import Bitcoin (getCompactSig) +import Bitcoin.Address ( + Address (WitnessPubKeyAddress), + pubKeyWitnessAddr, + ) +import Bitcoin.Constants (btc) +import Bitcoin.Crypto ( + SecKey, + Sig, + decodeStrictSig, + derivePubKey, + exportCompactSig, + exportSig, + getSig, + importSig, + isCanonicalHalfOrder, + putSig, + secKey, + sha256, + signHash, + signMsg, + verifyHashSig, + ) +import Bitcoin.Keys (PubKeyI, derivePubKeyI, wrapSecKey) +import Bitcoin.Script ( + ScriptOutput (..), + encodeOutput, + setAnyoneCanPayFlag, + sigHashAll, + sigHashNone, + sigHashSingle, + toP2WSH, + ) +import Bitcoin.Transaction ( + SigInput (SigInput), + Tx (txIn), + TxIn (prevOutput), + signNestedWitnessTx, + signTx, + ) +import Bitcoin.Util (decodeHex, encodeHex, lst3) +import qualified Bitcoin.Util as U +import Bitcoin.Util.Arbitrary (arbitrarySignature) import Bitcoin.UtilSpec (readTestFile) -import Control.Monad +import Control.Monad (foldM, void, (<=<), (>=>)) +import Data.Binary.Put (runPut) import Data.Bits (testBit) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe -import Data.Serialize as S +import Data.Maybe (fromJust) import Data.String.Conversions (cs) import Data.Text (Text) -import Test.HUnit -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck +import Test.HUnit ( + Assertion, + assertBool, + assertEqual, + assertFailure, + ) +import Test.Hspec (Spec, describe, it, runIO) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (forAll) spec :: Spec @@ -46,8 +86,8 @@ spec = do forAll arbitrarySignature $ (\s -> importSig (exportSig s) == Just s) . lst3 prop "getSig . putSig identity" $ - forAll arbitrarySignature $ - (\s -> runGet getSig (runPut $ putSig s) == Right s) . lst3 + forAll arbitrarySignature $ \(_, _, s) -> + (U.runGet getSig . runPut . putSig) s == Right s describe "Signature vectors" $ checkDistSig $ \file1 file2 -> do vectors <- runIO (readTestFile file1 :: IO [(Text, Text, Text)]) @@ -188,7 +228,7 @@ toVector (prv, m, res) = (fromJust $ (secKey <=< decodeHex) prv, cs m, res) testRFC6979Vector :: (SecKey, ByteString, Text) -> Assertion testRFC6979Vector (prv, m, res) = do - assertEqual "RFC 6979 Vector" res (encodeHex $ encode $ exportCompactSig s) + assertEqual "RFC 6979 Vector" res $ encodeHex . getCompactSig $ exportCompactSig s assertBool "Signature is valid" $ verifyHashSig h s (derivePubKey prv) assertBool "Signature is canonical" $ testIsCanonical s assertBool "Signature is normalized" $ isCanonicalHalfOrder s diff --git a/test/Bitcoin/Keys/ExtendedSpec.hs b/test/Bitcoin/Keys/ExtendedSpec.hs index f8254327..a6b9a420 100644 --- a/test/Bitcoin/Keys/ExtendedSpec.hs +++ b/test/Bitcoin/Keys/ExtendedSpec.hs @@ -3,22 +3,74 @@ module Bitcoin.Keys.ExtendedSpec (spec) where -import Bitcoin.Address -import Bitcoin.Constants -import Bitcoin.Keys +import Bitcoin.Address (addrToText) +import Bitcoin.Constants (Network, btc) +import Bitcoin.Keys ( + DerivPath, + DerivPathI (Deriv, (:/), (:|)), + ParsedPath (getParsedPath), + SoftPath, + XKey (XPrv, XPub), + XPrvKey (xPrvChain, xPrvKey), + XPubKey (xPubKey), + applyPath, + derivePath, + derivePubPath, + deriveXPubKey, + exportPubKey, + getSecKey, + getXPrvKey, + getXPubKey, + hardSubKey, + listToPath, + makeXPrvKey, + parsePath, + pathToList, + pathToStr, + prvSubKey, + pubSubKey, + putXPrvKey, + putXPubKey, + toHard, + toSoft, + xPrvExport, + xPrvFP, + xPrvID, + xPrvImport, + xPrvWif, + xPubAddr, + xPubExport, + xPubImport, + ) import Bitcoin.Orphans () -import Bitcoin.Util -import Bitcoin.Util.Arbitrary -import Bitcoin.UtilSpec (JsonBox (..), NetBox (..), ReadBox (..), SerialBox (..), customCerealID, testIdentity) +import Bitcoin.Util (decodeHex, encodeHex) +import qualified Bitcoin.Util as U +import Bitcoin.Util.Arbitrary ( + arbitraryBip32PathIndex, + arbitraryDerivPath, + arbitraryHardPath, + arbitraryNetwork, + arbitraryParsedPath, + arbitrarySoftPath, + arbitraryXPrvKey, + arbitraryXPubKey, + genNetData, + ) +import Bitcoin.UtilSpec (JsonBox (..), NetBox (..), ReadBox (..), SerialBox (..), testIdentity) import Control.Monad (forM_) -import Data.Aeson as A -import Data.Aeson.Encoding -import Data.Aeson.Types +import Data.Aeson as A ( + Encoding, + Value (String), + decode, + encode, + withText, + ) +import Data.Aeson.Encoding (text) +import Data.Aeson.Types (Parser) +import Data.Binary.Put (runPut) import Data.Bits ((.&.)) +import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as B8 -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial import Data.Either (isLeft) import Data.Maybe (fromJust, isJust, isNothing) import Data.String (fromString) @@ -26,9 +78,9 @@ import Data.String.Conversions (cs) import Data.Text (Text) import Data.Word (Word32) import Test.HUnit (Assertion, assertBool, assertEqual) -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck hiding ((.&.)) +import Test.Hspec (Spec, describe, it) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (forAll) serialVals :: [SerialBox] @@ -104,12 +156,12 @@ spec = do describe "Custom identity tests" $ do prop "encodes and decodes extended private key" $ forAll arbitraryNetwork $ \net -> - forAll arbitraryXPrvKey $ - customCerealID (getXPrvKey net) (putXPrvKey net) + forAll arbitraryXPrvKey $ \x -> + (U.runGet (getXPrvKey net) . runPut) (putXPrvKey net x) == Right x prop "encodes and decodes extended public key" $ forAll arbitraryNetwork $ \net -> - forAll arbitraryXPubKey $ - customCerealID (getXPubKey net) (putXPubKey net) . snd + forAll arbitraryXPubKey $ \(_, x) -> + (U.runGet (getXPubKey net) . runPut) (putXPubKey net x) == Right x describe "bip32 subkey derivation vector 1" $ vectorSpec m1 vector1 describe "bip32 subkey derivation vector 2" $ vectorSpec m2 vector2 describe "bip32 subkey derivation vector 3" $ vectorSpec m3 vector3 @@ -392,8 +444,8 @@ vectorSpec mTxt vecTxt = runVector :: XPrvKey -> TestVector -> Assertion runVector m v = do - assertBool "xPrvID" $ encodeHex (runPutS . serialize $ xPrvID m) == v !! 0 - assertBool "xPrvFP" $ encodeHex (runPutS . serialize $ xPrvFP m) == v !! 1 + assertBool "xPrvID" $ encodeHex (U.encodeS $ xPrvID m) == v !! 0 + assertBool "xPrvFP" $ encodeHex (U.encodeS $ xPrvFP m) == v !! 1 assertBool "xPrvAddr" $ addrToText btc (xPubAddr $ deriveXPubKey m) == Just (v !! 2) assertBool "bip44Addr" $ @@ -403,34 +455,14 @@ runVector m v = do assertBool "xPrvWIF" $ xPrvWif btc m == v !! 5 assertBool "pubKey" $ encodeHex (exportPubKey True $ xPubKey $ deriveXPubKey m) == v !! 6 - assertBool "chain code" $ encodeHex (runPutS . serialize $ xPrvChain m) == v !! 7 + assertBool "chain code" $ encodeHex (U.encodeS $ xPrvChain m) == v !! 7 assertBool "Hex PubKey" $ - encodeHex (runPutS $ putXPubKey btc $ deriveXPubKey m) == v !! 8 - assertBool "Hex PrvKey" $ encodeHex (runPutS (putXPrvKey btc m)) == v !! 9 + (encodeHex . BSL.toStrict . runPut . putXPubKey btc) (deriveXPubKey m) == v !! 8 + assertBool "Hex PrvKey" $ (encodeHex . BSL.toStrict . runPut . putXPrvKey btc) m == v !! 9 assertBool "Base58 PubKey" $ xPubExport btc (deriveXPubKey m) == v !! 10 assertBool "Base58 PrvKey" $ xPrvExport btc m == v !! 11 --- This function was used to generate addition data for the test vectors -genVector :: XPrvKey -> [(Text, Text)] -genVector m = - [ ("xPrvID", encodeHex (runPutS . serialize $ xPrvID m)) - , ("xPrvFP", encodeHex (runPutS . serialize $ xPrvFP m)) - , ("xPrvAddr", fromJust $ addrToText btc (xPubAddr $ deriveXPubKey m)) - , - ( "bip44Addr" - , fromJust $ - addrToText btc (xPubAddr $ deriveXPubKey $ derivePath bip44Addr m) - ) - , ("prvKey", encodeHex (getSecKey $ xPrvKey m)) - , ("xPrvWIF", xPrvWif btc m) - , ("pubKey", encodeHex (exportPubKey True $ xPubKey $ deriveXPubKey m)) - , ("chain code", encodeHex (runPutS . serialize $ xPrvChain m)) - , ("Hex PubKey", encodeHex (runPutS $ putXPubKey btc $ deriveXPubKey m)) - , ("Hex PrvKey", encodeHex (runPutS (putXPrvKey btc m))) - ] - - parseVector :: TestKey -> [TestVector] -> [(Text, XPrvKey, TestVector)] parseVector mTxt vs = go <$> vs diff --git a/test/Bitcoin/Keys/MnemonicSpec.hs b/test/Bitcoin/Keys/MnemonicSpec.hs index cf5a222f..0d12b98b 100644 --- a/test/Bitcoin/Keys/MnemonicSpec.hs +++ b/test/Bitcoin/Keys/MnemonicSpec.hs @@ -2,22 +2,35 @@ module Bitcoin.Keys.MnemonicSpec (spec) where -import Bitcoin.Keys -import Bitcoin.Util -import Bitcoin.Util.Arbitrary -import Control.Monad (zipWithM_) +import Bitcoin.Keys ( + Mnemonic, + fromMnemonic, + mnemonicToSeed, + toMnemonic, + ) +import Bitcoin.Util (decodeHex, encodeHex, getBits) +import Bitcoin.Util.Arbitrary (arbitraryBS) +import Control.Monad (zipWithM_, (<=<)) +import Data.Binary (Binary) +import qualified Data.Binary as Bin import Data.Bits (shiftR, (.&.)) import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL import Data.Either (fromRight) import Data.List (isPrefixOf) import Data.Maybe (fromJust) -import Data.Serialize (Serialize, encode) import Data.Text (Text) import qualified Data.Text as T import Data.Word (Word32, Word64) -import Test.HUnit -import Test.Hspec -import Test.QuickCheck hiding ((.&.)) +import Test.HUnit (Assertion, assertBool, assertEqual) +import Test.Hspec (Spec, describe, it) +import Test.QuickCheck ( + Arbitrary (arbitrary), + Property, + Testable (property), + choose, + (==>), + ) spec :: Spec @@ -293,10 +306,10 @@ invalidMss = ] -binWordsToBS :: Serialize a => [a] -> BS.ByteString -binWordsToBS = foldr f BS.empty +binWordsToBS :: Binary a => [a] -> BSL.ByteString +binWordsToBS = foldr f BSL.empty where - f b a = a `BS.append` encode b + f b a = a `BSL.append` Bin.encode b {- Encode mnemonic -} @@ -304,34 +317,37 @@ binWordsToBS = foldr f BS.empty toMnemonic128 :: (Word64, Word64) -> Bool toMnemonic128 (a, b) = l == 12 where - bs = encode a `BS.append` encode b + bs = Bin.encode a `BSL.append` Bin.encode b l = length . T.words . fromRight (error "Could not decode mnemonic senttence") - $ toMnemonic bs + . toMnemonic + $ BSL.toStrict bs toMnemonic160 :: (Word32, Word64, Word64) -> Bool toMnemonic160 (a, b, c) = l == 15 where - bs = BS.concat [encode a, encode b, encode c] + bs = BSL.concat [Bin.encode a, Bin.encode b, Bin.encode c] l = length . T.words . fromRight (error "Could not decode mnemonic sentence") - $ toMnemonic bs + . toMnemonic + $ BSL.toStrict bs toMnemonic256 :: (Word64, Word64, Word64, Word64) -> Bool toMnemonic256 (a, b, c, d) = l == 24 where - bs = BS.concat [encode a, encode b, encode c, encode d] + bs = BSL.concat [Bin.encode a, Bin.encode b, Bin.encode c, Bin.encode d] l = length . T.words . fromRight (error "Could not decode mnemonic sentence") - $ toMnemonic bs + . toMnemonic + $ BSL.toStrict bs toMnemonic512 :: @@ -339,98 +355,105 @@ toMnemonic512 :: toMnemonic512 ((a, b, c, d), (e, f, g, h)) = l == 48 where bs = - BS.concat - [ encode a - , encode b - , encode c - , encode d - , encode e - , encode f - , encode g - , encode h + BSL.concat + [ Bin.encode a + , Bin.encode b + , Bin.encode c + , Bin.encode d + , Bin.encode e + , Bin.encode f + , Bin.encode g + , Bin.encode h ] l = length . T.words . fromRight (error "Could not decode mnemonic sentence") - $ toMnemonic bs + . toMnemonic + $ BSL.toStrict bs toMnemonicVar :: [Word32] -> Property -toMnemonicVar ls = not (null ls) && length ls <= 8 ==> l == wc +toMnemonicVar ls = not (null ls) && length ls <= 8 ==> l == fromIntegral wc where bs = binWordsToBS ls - bl = BS.length bs + bl = BSL.length bs cb = bl `div` 4 wc = (cb + bl * 8) `div` 11 l = length . T.words . fromRight (error "Could not decode mnemonic sentence") - $ toMnemonic bs + . toMnemonic + $ BSL.toStrict bs {- Encode/Decode -} fromToMnemonic128 :: (Word64, Word64) -> Bool -fromToMnemonic128 (a, b) = bs == bs' +fromToMnemonic128 (a, b) = bs == BSL.fromStrict bs' where - bs = encode a `BS.append` encode b + bs = Bin.encode a `BSL.append` Bin.encode b bs' = fromRight (error "Could not decode mnemonic entropy") - (fromMnemonic =<< toMnemonic bs) + . (fromMnemonic <=< toMnemonic) + $ BSL.toStrict bs fromToMnemonic160 :: (Word32, Word64, Word64) -> Bool -fromToMnemonic160 (a, b, c) = bs == bs' +fromToMnemonic160 (a, b, c) = bs == BSL.fromStrict bs' where - bs = BS.concat [encode a, encode b, encode c] + bs = BSL.concat [Bin.encode a, Bin.encode b, Bin.encode c] bs' = fromRight (error "Could not decode mnemonic entropy") - (fromMnemonic =<< toMnemonic bs) + . (fromMnemonic <=< toMnemonic) + $ BSL.toStrict bs fromToMnemonic256 :: (Word64, Word64, Word64, Word64) -> Bool -fromToMnemonic256 (a, b, c, d) = bs == bs' +fromToMnemonic256 (a, b, c, d) = bs == BSL.fromStrict bs' where - bs = BS.concat [encode a, encode b, encode c, encode d] + bs = BSL.concat [Bin.encode a, Bin.encode b, Bin.encode c, Bin.encode d] bs' = fromRight (error "Could not decode mnemonic entropy") - (fromMnemonic =<< toMnemonic bs) + . (fromMnemonic <=< toMnemonic) + $ BSL.toStrict bs fromToMnemonic512 :: ((Word64, Word64, Word64, Word64), (Word64, Word64, Word64, Word64)) -> Bool -fromToMnemonic512 ((a, b, c, d), (e, f, g, h)) = bs == bs' +fromToMnemonic512 ((a, b, c, d), (e, f, g, h)) = bs == BSL.fromStrict bs' where bs = - BS.concat - [ encode a - , encode b - , encode c - , encode d - , encode e - , encode f - , encode g - , encode h + BSL.concat + [ Bin.encode a + , Bin.encode b + , Bin.encode c + , Bin.encode d + , Bin.encode e + , Bin.encode f + , Bin.encode g + , Bin.encode h ] bs' = fromRight (error "Could not decode mnemonic entropy") - (fromMnemonic =<< toMnemonic bs) + . (fromMnemonic <=< toMnemonic) + $ BSL.toStrict bs fromToMnemonicVar :: [Word32] -> Property -fromToMnemonicVar ls = not (null ls) && length ls <= 8 ==> bs == bs' +fromToMnemonicVar ls = not (null ls) && length ls <= 8 ==> bs == BSL.fromStrict bs' where bs = binWordsToBS ls bs' = fromRight (error "Could not decode mnemonic entropy") - (fromMnemonic =<< toMnemonic bs) + . (fromMnemonic <=< toMnemonic) + $ BSL.toStrict bs {- Mnemonic to seed -} @@ -438,33 +461,36 @@ fromToMnemonicVar ls = not (null ls) && length ls <= 8 ==> bs == bs' mnemonicToSeed128 :: (Word64, Word64) -> Bool mnemonicToSeed128 (a, b) = l == 64 where - bs = encode a `BS.append` encode b + bs = Bin.encode a `BSL.append` Bin.encode b seed = fromRight (error "Could not decode mnemonic seed") - (mnemonicToSeed "" =<< toMnemonic bs) + . (mnemonicToSeed "" <=< toMnemonic) + $ BSL.toStrict bs l = BS.length seed mnemonicToSeed160 :: (Word32, Word64, Word64) -> Bool mnemonicToSeed160 (a, b, c) = l == 64 where - bs = BS.concat [encode a, encode b, encode c] + bs = BSL.concat [Bin.encode a, Bin.encode b, Bin.encode c] seed = fromRight (error "Could not decode mnemonic seed") - (mnemonicToSeed "" =<< toMnemonic bs) + . (mnemonicToSeed "" <=< toMnemonic) + $ BSL.toStrict bs l = BS.length seed mnemonicToSeed256 :: (Word64, Word64, Word64, Word64) -> Bool mnemonicToSeed256 (a, b, c, d) = l == 64 where - bs = BS.concat [encode a, encode b, encode c, encode d] + bs = BSL.concat [Bin.encode a, Bin.encode b, Bin.encode c, Bin.encode d] seed = fromRight (error "Could not decode mnemonic seed") - (mnemonicToSeed "" =<< toMnemonic bs) + . (mnemonicToSeed "" <=< toMnemonic) + $ BSL.toStrict bs l = BS.length seed @@ -473,20 +499,21 @@ mnemonicToSeed512 :: mnemonicToSeed512 ((a, b, c, d), (e, f, g, h)) = l == 64 where bs = - BS.concat - [ encode a - , encode b - , encode c - , encode d - , encode e - , encode f - , encode g - , encode h + BSL.concat + [ Bin.encode a + , Bin.encode b + , Bin.encode c + , Bin.encode d + , Bin.encode e + , Bin.encode f + , Bin.encode g + , Bin.encode h ] seed = fromRight (error "Could not decode mnemonic seed") - (mnemonicToSeed "" =<< toMnemonic bs) + . (mnemonicToSeed "" <=< toMnemonic) + $ BSL.toStrict bs l = BS.length seed @@ -497,7 +524,8 @@ mnemonicToSeedVar ls = not (null ls) && length ls <= 16 ==> l == 64 seed = fromRight (error "Could not decode mnemonic seed") - (mnemonicToSeed "" =<< toMnemonic bs) + . (mnemonicToSeed "" <=< toMnemonic) + $ BSL.toStrict bs l = BS.length seed diff --git a/test/Bitcoin/KeysSpec.hs b/test/Bitcoin/KeysSpec.hs index b01a1b20..2c69fee9 100644 --- a/test/Bitcoin/KeysSpec.hs +++ b/test/Bitcoin/KeysSpec.hs @@ -1,34 +1,73 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Bitcoin.KeysSpec (spec) where -import Bitcoin.Address -import Bitcoin.Constants -import Bitcoin.Crypto -import Bitcoin.Keys +import Bitcoin (getSecKey, secKey) +import Bitcoin.Address ( + addrToText, + addressToOutput, + outputAddress, + pubKeyAddr, + textToAddr, + ) +import Bitcoin.Constants (allNets, btc, btcRegTest, btcTest) +import Bitcoin.Crypto ( + Hash256, + SecKey, + doubleSHA256, + signHash, + verifyHashSig, + ) +import Bitcoin.Keys ( + PubKeyI (pubKeyCompressed, pubKeyPoint), + SecKeyI (secKeyCompressed, secKeyData), + derivePubKeyI, + fromMiniKey, + fromWif, + toWif, + wrapSecKey, + ) import Bitcoin.Orphans () -import Bitcoin.Script -import Bitcoin.Util -import Bitcoin.Util.Arbitrary -import Bitcoin.UtilSpec hiding (spec) -import Control.Lens -import Control.Monad -import Data.Aeson as A -import Data.Aeson.Lens +import Bitcoin.Script ( + ScriptOutput, + decodeOutputBS, + encodeOutputBS, + ) +import Bitcoin.Util (decodeHex, eitherToMaybe, encodeHex) +import qualified Bitcoin.Util as U +import Bitcoin.Util.Arbitrary ( + arbitraryKeyPair, + arbitraryNetwork, + arbitrarySecKeyI, + ) +import Bitcoin.UtilSpec ( + JsonBox (..), + ReadBox (..), + SerialBox (..), + readTestFile, + testIdentity, + ) +import Control.Monad (forM_, (<=<)) +import Data.Aeson as A (Object, Value (Bool)) +import qualified Data.Aeson.KeyMap as A +import qualified Data.Binary as Bin import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Maybe -import qualified Data.Serialize as S +import qualified Data.ByteString.Lazy as BSL +import Data.Maybe (fromJust, fromMaybe, isJust, isNothing) import Data.String (fromString) import Data.String.Conversions (cs) import Data.Text (Text) -import Test.HUnit -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck +import Test.HUnit ( + Assertion, + assertBool, + assertEqual, + assertFailure, + ) +import Test.Hspec (Spec, describe, it, runIO) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (Arbitrary (arbitrary), Gen, forAll) serialVals :: [SerialBox] @@ -59,7 +98,7 @@ spec = do forAll arbitraryKeyPair (isCanonicalPubKey . snd) prop "Public key fromString identity" $ forAll arbitraryKeyPair $ \(_, k) -> - fromString (cs . encodeHex $ runPutS $ serialize k) == k + fromString (cs . encodeHex $ U.encodeS k) == k describe "SecKey properties" $ prop "fromWif . toWif identity" $ forAll arbitraryNetwork $ \net -> @@ -75,7 +114,7 @@ spec = do describe "MiniKey vectors" $ it "Passes MiniKey decoding tests" testMiniKey describe "key_io_valid.json vectors" $ do - vectors <- runIO (readTestFile "key_io_valid.json" :: IO [(Text, Text, A.Value)]) + vectors <- runIO (readTestFile "key_io_valid.json" :: IO [(Text, Text, A.Object)]) it "Passes the key_io_valid.json vectors" $ mapM_ testKeyIOValidVector vectors describe "key_io_invalid.json vectors" $ do @@ -90,46 +129,46 @@ isCanonicalPubKey :: PubKeyI -> Bool isCanonicalPubKey p = not $ -- Non-canonical public key: too short - (BS.length bs < 33) + (BSL.length bs < 33) || -- Non-canonical public key: invalid length for uncompressed key - (BS.index bs 0 == 4 && BS.length bs /= 65) + (BSL.index bs 0 == 4 && BSL.length bs /= 65) || -- Non-canonical public key: invalid length for compressed key - (BS.index bs 0 `elem` [2, 3] && BS.length bs /= 33) + (BSL.index bs 0 `elem` [2, 3] && BSL.length bs /= 33) || -- Non-canonical public key: compressed nor uncompressed - (BS.index bs 0 `notElem` [2, 3, 4]) + (BSL.index bs 0 `notElem` [2, 3, 4]) where - bs = runPutS $ serialize p + bs = Bin.encode p testMiniKey :: Assertion testMiniKey = assertEqual "fromMiniKey" (Just res) (go "S6c56bnXQiBjk9mqSYE7ykVQ7NzrRy") where - go = fmap (encodeHex . runPutS . S.put . secKeyData) . fromMiniKey + go = fmap (encodeHex . getSecKey . secKeyData) . fromMiniKey res = "4c7a9640c72dc2099f23715d0c8a0d8a35f8906e3cab61dd3f78b67bf887c9ab" -- Test vectors from: -- https://github.com/bitcoin/bitcoin/blob/master/src/test/key_io_tests.cpp -testKeyIOValidVector :: (Text, Text, A.Value) -> Assertion +testKeyIOValidVector :: (Text, Text, A.Object) -> Assertion testKeyIOValidVector (a, payload, obj) | disabled = return () -- There are invalid version 1 bech32 addresses | isPrv = do -- Test from WIF to SecKey - let isComp = obj ^?! key "isCompressed" . _Bool + let Just isComp = A.lookup "isCompressed" obj >>= getBool prvKeyM = fromWif net a - prvKeyHexM = encodeHex . runPutS . S.put . secKeyData <$> prvKeyM + prvKeyHexM = encodeHex . getSecKey . secKeyData <$> prvKeyM assertBool "Valid PrvKey" $ isJust prvKeyM assertEqual "Valid compression" (Just isComp) (secKeyCompressed <$> prvKeyM) assertEqual "WIF matches payload" (Just payload) prvKeyHexM let prvAsPubM = (eitherToMaybe . decodeOutputBS <=< decodeHex) a assertBool "PrvKey is invalid ScriptOutput" $ isNothing prvAsPubM -- Test from SecKey to WIF - let secM = eitherToMaybe . runGetS S.get =<< decodeHex payload + let secM = secKey =<< decodeHex payload wifM = toWif net . wrapSecKey isComp <$> secM assertEqual "Payload matches WIF" (Just a) wifM | otherwise = do @@ -139,10 +178,7 @@ testKeyIOValidVector (a, payload, obj) assertBool ("Valid Address " <> cs a) $ isJust addrM assertEqual "Address matches payload" (Just payload) scriptM let pubAsWifM = fromWif net a - pubAsSecM = - eitherToMaybe . runGetS S.get - =<< decodeHex a :: - Maybe SecKey + pubAsSecM = secKey =<< decodeHex a assertBool "Address is invalid Wif" $ isNothing pubAsWifM assertBool "Address is invalid PrvKey" $ isNothing pubAsSecM -- Test Script to Addr @@ -150,21 +186,24 @@ testKeyIOValidVector (a, payload, obj) resM = addrToText net =<< outputAddress =<< outM assertEqual "Payload matches address" (Just a) resM where - isPrv = obj ^?! key "isPrivkey" . _Bool - disabled = fromMaybe False $ obj ^? key "disabled" . _Bool - chain = obj ^?! key "chain" . _String + Just isPrv = A.lookup "isPrivkey" obj >>= getBool + disabled = fromMaybe False $ A.lookup "disabled" obj >>= getBool + Just chain = A.lookup "chain" obj net = case chain of "main" -> btc "test" -> btcTest "regtest" -> btcRegTest _ -> error "Invalid chain key in key_io_valid.json" + getBool = \case + Bool b -> Just b + _ -> Nothing testKeyIOInvalidVector :: [Text] -> Assertion testKeyIOInvalidVector [a] = do let wifMs = (`fromWif` a) <$> allNets - secKeyM = (eitherToMaybe . runGetS S.get <=< decodeHex) a :: Maybe SecKey + secKeyM = (secKey <=< decodeHex) a :: Maybe SecKey scriptM = (eitherToMaybe . decodeOutputBS <=< decodeHex) a :: Maybe ScriptOutput assertBool "Payload is invalid WIF" $ all isNothing wifMs assertBool "Payload is invalid SecKey" $ isNothing secKeyM diff --git a/test/Bitcoin/NetworkSpec.hs b/test/Bitcoin/NetworkSpec.hs index f587cc9b..0c9c3122 100644 --- a/test/Bitcoin/NetworkSpec.hs +++ b/test/Bitcoin/NetworkSpec.hs @@ -2,24 +2,60 @@ module Bitcoin.NetworkSpec (spec) where -import Bitcoin.Address -import Bitcoin.Constants -import Bitcoin.Keys -import Bitcoin.Network -import Bitcoin.Transaction -import Bitcoin.Util -import Bitcoin.Util.Arbitrary -import Bitcoin.UtilSpec hiding (spec) -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial +import Bitcoin.Address (Address (getAddrHash160), pubKeyAddr) +import Bitcoin.Constants (btc) +import Bitcoin.Keys (derivePubKeyI, fromWif) +import Bitcoin.Network ( + BloomFlags (BloomUpdateAll), + bloomContains, + bloomCreate, + bloomInsert, + bloomRelevantUpdate, + getMessage, + putMessage, + ) +import Bitcoin.Transaction ( + OutPoint (OutPoint), + Tx (..), + TxIn (..), + TxOut (..), + ) +import Bitcoin.Util (decodeHex) +import qualified Bitcoin.Util as U +import Bitcoin.Util.Arbitrary ( + arbitraryAddr1, + arbitraryAlert, + arbitraryBloomFilter, + arbitraryBloomFlags, + arbitraryFilterAdd, + arbitraryFilterLoad, + arbitraryGetData, + arbitraryInv1, + arbitraryInvType, + arbitraryInvVector, + arbitraryMessage, + arbitraryMessageCommand, + arbitraryMessageHeader, + arbitraryNetwork, + arbitraryNetworkAddress, + arbitraryNotFound, + arbitraryPing, + arbitraryPong, + arbitraryReject, + arbitraryRejectCode, + arbitraryVarInt, + arbitraryVarString, + arbitraryVersion, + ) +import Bitcoin.UtilSpec (SerialBox (..), testIdentity) +import Data.Binary.Put (runPut) import Data.Maybe (fromJust) import Data.Text (Text) import Data.Word (Word32) import Test.HUnit (Assertion, assertBool, assertEqual) -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck +import Test.Hspec (Spec, describe, it) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (forAll) serialVals :: [SerialBox] @@ -54,8 +90,8 @@ spec = do describe "Custom identity tests" $ do prop "Data.Serialize Encoding for type Message" $ forAll arbitraryNetwork $ \net -> - forAll (arbitraryMessage net) $ - customCerealID (getMessage net) (putMessage net) + forAll (arbitraryMessage net) $ \x -> + Right x == (U.runGet (getMessage net) . runPut . putMessage net) x describe "bloom filters" $ do it "bloom filter vector 1" bloomFilter1 it "bloom filter vector 2" bloomFilter2 @@ -74,7 +110,7 @@ bloomFilter n x = do assertBool "Bloom filter doesn't contain vector 3" $ bloomContains f3 v3 assertBool "Bloom filter doesn't contain vector 4" $ bloomContains f4 v4 assertBool "Bloom filter serialization is incorrect" $ - runPutS (serialize f4) == bs + U.encodeS f4 == bs where f0 = bloomCreate 3 0.01 n BloomUpdateAll f1 = bloomInsert f0 v1 @@ -98,11 +134,11 @@ bloomFilter2 = bloomFilter 2147483649 "03ce4299050000000100008001" bloomFilter3 :: Assertion bloomFilter3 = assertBool "Bloom filter serialization is incorrect" $ - runPutS (serialize f2) == bs + U.encodeS f2 == bs where f0 = bloomCreate 2 0.001 0 BloomUpdateAll - f1 = bloomInsert f0 $ runPutS $ serialize p - f2 = bloomInsert f1 $ runPutS $ serialize $ getAddrHash160 $ pubKeyAddr p + f1 = bloomInsert f0 $ U.encodeS p + f2 = bloomInsert f1 $ U.encodeS $ getAddrHash160 $ pubKeyAddr p k = fromJust $ fromWif btc "5Kg1gnAjaLfKiwhhPpGS3QfRg2m6awQvaj98JCZBZQ5SuS2F15C" p = derivePubKeyI k bs = fromJust $ decodeHex "038fc16b080000000000000001" @@ -117,7 +153,7 @@ relevantOutputUpdated = relevantOutputHash = fromJust $ decodeHex "03f47604ea2736334151081e13265b4fe38e6fa8" bf1 = bloomInsert bf0 relevantOutputHash bf2 = fromJust $ bloomRelevantUpdate bf1 relevantTx - spendTxInput = runPutS . serialize . prevOutput <$> txIn spendRelevantTx + spendTxInput = U.encodeS . prevOutput <$> txIn spendRelevantTx irrelevantOutputNotUpdated :: Assertion diff --git a/test/Bitcoin/Orphans.hs b/test/Bitcoin/Orphans.hs index 422072d2..cb92aee1 100644 --- a/test/Bitcoin/Orphans.hs +++ b/test/Bitcoin/Orphans.hs @@ -4,18 +4,63 @@ module Bitcoin.Orphans where -import Bitcoin -import Control.Monad -import Data.Aeson -import Data.Aeson.Encoding +import Bitcoin ( + Block (Block), + BlockHash, + BlockHeader (BlockHeader), + DerivPath, + DerivPathI, + HardPath, + OutPoint (OutPoint), + ParsedPath (..), + PubKeyI, + ScriptOutput, + SigHash (..), + SigInput (SigInput), + SoftPath, + Tx (Tx), + TxHash, + TxIn (TxIn), + TxOut (TxOut), + XOnlyPubKey, + blockHashToHex, + decodeHex, + decodeOutputBS, + eitherToMaybe, + encodeHex, + encodeOutputBS, + hexBuilder, + hexToBlockHash, + hexToTxHash, + maybeToEither, + parseHard, + parsePath, + parseSoft, + pathToStr, + txHashToHex, + ) +import qualified Bitcoin.Util as U +import Control.Monad (MonadPlus (mzero), (<=<)) +import Data.Aeson ( + FromJSON (parseJSON), + KeyValue ((.=)), + ToJSON (toEncoding, toJSON), + Value (Number, String), + object, + pairs, + withObject, + withScientific, + withText, + (.:), + (.:?), + ) +import Data.Aeson.Encoding (text, unsafeToEncoding) +import qualified Data.Binary as Bin import Data.ByteString.Builder (char7) -import qualified Data.ByteString.Lazy as BL -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Maybe -import Data.Scientific -import Data.String.Conversions +import qualified Data.ByteString.Lazy as BSL +import Data.Maybe (maybeToList) +import Data.Scientific (toBoundedInteger) +import Data.String.Conversions (cs) instance FromJSON BlockHash where @@ -29,7 +74,7 @@ instance ToJSON BlockHash where toEncoding h = unsafeToEncoding $ char7 '"' - <> hexBuilder (BL.reverse (runPutL (serialize h))) + <> (hexBuilder . BSL.reverse . Bin.encode) h <> char7 '"' @@ -38,7 +83,7 @@ instance ToJSON BlockHeader where object [ "version" .= v , "prevblock" .= p - , "merkleroot" .= encodeHex (runPutS (serialize m)) + , "merkleroot" .= (encodeHex . U.encodeS) m , "timestamp" .= t , "bits" .= b , "nonce" .= n @@ -48,15 +93,15 @@ instance ToJSON BlockHeader where ( "version" .= v <> "prevblock" - .= p + .= p <> "merkleroot" - .= encodeHex (runPutS (serialize m)) + .= (encodeHex . U.encodeS) m <> "timestamp" - .= t + .= t <> "bits" - .= b + .= b <> "nonce" - .= n + .= n ) @@ -64,19 +109,14 @@ instance FromJSON BlockHeader where parseJSON = withObject "BlockHeader" $ \o -> BlockHeader - <$> o - .: "version" - <*> o - .: "prevblock" + <$> o .: "version" + <*> o .: "prevblock" <*> (f =<< o .: "merkleroot") - <*> o - .: "timestamp" - <*> o - .: "bits" - <*> o - .: "nonce" + <*> o .: "timestamp" + <*> o .: "bits" + <*> o .: "nonce" where - f = maybe mzero return . (eitherToMaybe . runGetS deserialize <=< decodeHex) + f = maybe mzero return . (eitherToMaybe . U.decode . BSL.fromStrict <=< decodeHex) instance FromJSON TxHash where @@ -90,7 +130,7 @@ instance ToJSON TxHash where toEncoding h = unsafeToEncoding $ char7 '"' - <> hexBuilder (BL.reverse (runPutL (serialize h))) + <> (hexBuilder . BSL.reverse . Bin.encode) h <> char7 '"' @@ -109,11 +149,9 @@ instance FromJSON TxIn where parseJSON = withObject "TxIn" $ \o -> TxIn - <$> o - .: "prevoutput" + <$> o .: "prevoutput" <*> (maybe mzero return . decodeHex =<< o .: "inputscript") - <*> o - .: "sequence" + <*> o .: "sequence" instance ToJSON TxIn where @@ -128,9 +166,9 @@ instance ToJSON TxIn where ( "prevoutput" .= o <> "inputscript" - .= encodeHex s + .= encodeHex s <> "sequence" - .= q + .= q ) @@ -138,8 +176,7 @@ instance FromJSON TxOut where parseJSON = withObject "TxOut" $ \o -> TxOut - <$> o - .: "value" + <$> o .: "value" <*> (maybe mzero return . decodeHex =<< o .: "outputscript") @@ -153,15 +190,11 @@ instance ToJSON TxOut where instance FromJSON Tx where parseJSON = withObject "Tx" $ \o -> Tx - <$> o - .: "version" - <*> o - .: "inputs" - <*> o - .: "outputs" + <$> o .: "version" + <*> o .: "inputs" + <*> o .: "outputs" <*> (mapM (mapM f) =<< o .: "witnessdata") - <*> o - .: "locktime" + <*> o .: "locktime" where f = maybe mzero return . decodeHex @@ -180,13 +213,13 @@ instance ToJSON Tx where ( "version" .= v <> "inputs" - .= i + .= i <> "outputs" - .= o + .= o <> "witnessdata" - .= fmap (fmap encodeHex) w + .= fmap (fmap encodeHex) w <> "locktime" - .= l + .= l ) @@ -240,18 +273,18 @@ instance FromJSON SoftPath where instance ToJSON PubKeyI where - toJSON = String . encodeHex . runPutS . serialize + toJSON = String . encodeHex . U.encodeS toEncoding s = unsafeToEncoding $ char7 '"' - <> hexBuilder (runPutL (serialize s)) + <> (hexBuilder . Bin.encode) s <> char7 '"' instance FromJSON PubKeyI where parseJSON = withText "PubKeyI" $ - maybe mzero return . ((eitherToMaybe . runGetS deserialize) <=< decodeHex) + maybe mzero return . ((eitherToMaybe . U.decode . BSL.fromStrict) <=< decodeHex) instance FromJSON SigHash where @@ -292,11 +325,11 @@ instance ToJSON SigInput where "pkscript" .= so <> "value" - .= val + .= val <> "outpoint" - .= op + .= op <> "sighash" - .= sh + .= sh <> maybe mempty ("redeem" .=) rdm @@ -304,16 +337,11 @@ instance FromJSON SigInput where parseJSON = withObject "SigInput" $ \o -> SigInput - <$> o - .: "pkscript" - <*> o - .: "value" - <*> o - .: "outpoint" - <*> o - .: "sighash" - <*> o - .:? "redeem" + <$> o .: "pkscript" + <*> o .: "value" + <*> o .: "outpoint" + <*> o .: "sighash" + <*> o .:? "redeem" -- | Hex encoding @@ -321,4 +349,4 @@ instance FromJSON XOnlyPubKey where parseJSON = withText "XOnlyPubKey" $ either fail pure - . (runGetS deserialize <=< maybe (Left "Unable to decode hex") Right . decodeHex) + . (U.decode . BSL.fromStrict <=< maybe (Left "Unable to decode hex") Right . decodeHex) diff --git a/test/Bitcoin/ScriptSpec.hs b/test/Bitcoin/ScriptSpec.hs index 85cb4252..7babb050 100644 --- a/test/Bitcoin/ScriptSpec.hs +++ b/test/Bitcoin/ScriptSpec.hs @@ -2,35 +2,103 @@ module Bitcoin.ScriptSpec (spec) where -import Bitcoin.Address -import Bitcoin.Constants -import Bitcoin.Data -import Bitcoin.Keys +import Bitcoin.Address (addrToText, payToScriptAddress) +import Bitcoin.Constants (Network (getNetworkName), btc) +import Bitcoin.Keys (derivePubKeyI, secKey, wrapSecKey) import Bitcoin.Orphans () -import Bitcoin.Script -import Bitcoin.Transaction -import Bitcoin.Util -import Bitcoin.Util.Arbitrary -import Bitcoin.UtilSpec hiding (spec) -import Control.Monad -import Data.Aeson as A +import Bitcoin.Script ( + Script (Script), + ScriptInput (RegularInput), + ScriptOp (..), + ScriptOutput (getOutputMulSigKeys), + SigHash, + SimpleInput (..), + TxSignature (TxSignatureEmpty), + decodeInput, + decodeOutput, + decodeOutputBS, + decodeTxSig, + encodeInput, + encodeOutput, + encodeTxSig, + hasAnyoneCanPayFlag, + intToScriptOp, + isSigHashAll, + isSigHashNone, + isSigHashSingle, + isSigHashUnknown, + opPushData, + scriptOpToInt, + setAnyoneCanPayFlag, + sigHashAll, + sigHashNone, + sigHashSingle, + sortMulSig, + txSigHash, + ) +import Bitcoin.Transaction ( + OutPoint (OutPoint), + Tx (..), + TxIn (..), + TxOut (..), + nullOutPoint, + txHash, + verifyStdInput, + ) +import Bitcoin.Util (decodeHex, eitherToMaybe, encodeHex) +import qualified Bitcoin.Util as U +import Bitcoin.Util.Arbitrary ( + arbitraryIntScriptOp, + arbitraryMSOutput, + arbitraryNetwork, + arbitraryOutPoint, + arbitraryPushDataType, + arbitraryScript, + arbitraryScriptInput, + arbitraryScriptOp, + arbitraryScriptOutput, + arbitrarySigHash, + arbitrarySigHashFlag, + arbitrarySigInput, + arbitraryTx, + arbitraryTxSignature, + ) +import Bitcoin.UtilSpec ( + JsonBox (..), + ReadBox (..), + SerialBox (..), + readTestFile, + testIdentity, + ) +import Control.Monad (forM_, unless, when, zipWithM_) +import Data.Aeson as A (Value, decode, encode) import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Either -import Data.List -import Data.Maybe -import Data.String +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.Either (fromLeft, isLeft, isRight) +import Data.List (isInfixOf, sort) +import Data.Maybe (fromJust, fromMaybe, mapMaybe) +import Data.String (IsString (fromString)) import Data.String.Conversions (cs) import Data.Text (Text) -import Data.Word -import Test.HUnit as HUnit -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck -import Text.Read +import Data.Word (Word32, Word64) +import Test.HUnit as HUnit (Assertion, assertBool, assertEqual) +import Test.Hspec ( + Spec, + describe, + it, + shouldBe, + shouldNotBe, + shouldSatisfy, + ) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck ( + Property, + Testable (property), + forAll, + (==>), + ) +import Text.Read (readMaybe) serialVals :: [SerialBox] @@ -99,7 +167,7 @@ standardSpec net = do prop "can sort multisig scripts" $ forAll arbitraryMSOutput $ \out -> map - (runPutS . serialize) + U.encodeS (getOutputMulSigKeys (sortMulSig out)) `shouldSatisfy` \xs -> xs == sort xs it "can decode inputs with empty signatures" $ do @@ -112,8 +180,8 @@ standardSpec net = do wrapSecKey True $ fromJust $ secKey $ - B.replicate 32 1 - decodeInput net (Script [OP_0, opPushData $ runPutS $ serialize pk]) + BS.replicate 32 1 + decodeInput net (Script [OP_0, opPushData $ U.encodeS pk]) `shouldBe` Right (RegularInput (SpendPKHash TxSignatureEmpty pk)) decodeInput net (Script [OP_0, OP_0]) `shouldBe` Right (RegularInput (SpendMulSig [TxSignatureEmpty])) @@ -183,7 +251,7 @@ creditTx scriptPubKey val = txI = TxIn { prevOutput = nullOutPoint - , scriptInput = runPutS $ serialize $ Script [OP_0, OP_0] + , scriptInput = U.encodeS $ Script [OP_0, OP_0] , txInSequence = maxBound } @@ -192,7 +260,7 @@ spendTx :: ByteString -> Word64 -> ByteString -> Tx spendTx scriptPubKey val scriptSig = Tx 1 [txI] [txO] [] 0 where - txO = TxOut{outValue = val, scriptOutput = B.empty} + txO = TxOut{outValue = val, scriptOutput = BS.empty} txI = TxIn { prevOutput = OutPoint (txHash $ creditTx scriptPubKey val) 0 @@ -203,7 +271,7 @@ spendTx scriptPubKey val scriptSig = parseScript :: String -> ByteString parseScript str = - B.concat $ fromMaybe err $ mapM f $ words str + BS.concat $ fromMaybe err $ mapM f $ words str where f = decodeHex . cs . dropHex . replaceToken dropHex ('0' : 'x' : xs) = xs @@ -213,7 +281,7 @@ parseScript str = replaceToken :: String -> String replaceToken str = case readMaybe $ "OP_" <> str of - Just opcode -> "0x" <> cs (encodeHex $ runPutS $ serialize (opcode :: ScriptOp)) + Just opcode -> "0x" <> cs (encodeHex $ U.encodeS (opcode :: ScriptOp)) _ -> str @@ -253,10 +321,10 @@ txSigHashSpec net = let tx = fromString txStr s = fromMaybe (error $ "Could not decode script: " <> cs scpStr) $ - eitherToMaybe . runGetS deserialize =<< decodeHex (cs scpStr) + eitherToMaybe . U.decode . BSL.fromStrict =<< decodeHex (cs scpStr) sh = fromIntegral shI res = - eitherToMaybe . runGetS deserialize . B.reverse + eitherToMaybe . U.decode . BSL.fromStrict . BS.reverse =<< decodeHex (cs resStr) Just (txSigHash net tx s 0 i sh) `shouldBe` res @@ -326,11 +394,8 @@ mapMulSigVector (v, 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 + o <- eitherToMaybe . U.decode . BSL.fromStrict =<< decodeHex ops d <- eitherToMaybe $ decodeOutput o addrToText btc $ payToScriptAddress d @@ -389,7 +454,7 @@ scriptSigSignatures = encodeScriptVector :: Assertion encodeScriptVector = - assertEqual "Encode script" res (encodeHex $ runPutS $ serialize s) + assertEqual "Encode script" res (encodeHex $ U.encodeS s) where res = "514104cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef58b\ diff --git a/test/Bitcoin/Transaction/PartialSpec.hs b/test/Bitcoin/Transaction/PartialSpec.hs index f189e49f..0c3d2610 100644 --- a/test/Bitcoin/Transaction/PartialSpec.hs +++ b/test/Bitcoin/Transaction/PartialSpec.hs @@ -1,45 +1,98 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module Bitcoin.Transaction.PartialSpec (spec) where -import Bitcoin.Address -import Bitcoin.Constants -import Bitcoin.Crypto -import Bitcoin.Data -import Bitcoin.Keys -import Bitcoin.Script -import Bitcoin.Transaction -import Bitcoin.Util -import Bitcoin.Util.Arbitrary +import Bitcoin.Address (addressToScript, pubKeyAddr) +import Bitcoin.Constants (Network, btc) +import Bitcoin.Crypto (derivePubKey, secKey, signHash) +import Bitcoin.Keys ( + DerivPathI (Deriv, (:/), (:|)), + PubKeyI (..), + SecKeyI (secKeyData), + XPrvKey (xPrvKey), + derivePath, + deriveXPubKey, + makeXPrvKey, + xPubFP, + ) +import Bitcoin.Script ( + Script, + ScriptOutput (PayMulSig), + TxSignature (TxSignature), + decodeOutput, + decodeOutputBS, + encodeOutput, + encodeOutputBS, + encodeTxSig, + isPayPKHash, + isPayWitnessPKHash, + isPayWitnessScriptHash, + sigHashAll, + toP2SH, + txSigHash, + ) +import Bitcoin.Transaction ( + Input (..), + Key (Key), + OutPoint (..), + Output (..), + PartiallySignedTransaction (..), + Tx (..), + TxHash, + TxIn (..), + TxOut (..), + UnknownMap (UnknownMap), + complete, + emptyInput, + emptyOutput, + emptyPSBT, + finalTransaction, + getSignerKey, + mergeMany, + secKeySigner, + txHash, + verifyStdTx, + xPrvSigner, + ) +import Bitcoin.Util (decodeHex, encodeHex) +import qualified Bitcoin.Util as U +import Bitcoin.Util.Arbitrary ( + arbitraryKeyPair, + arbitraryMSParam, + ) import Bitcoin.UtilSpec (readTestFile) import Control.Monad ((<=<)) import Data.Aeson (FromJSON, parseJSON, withObject, (.:)) import Data.Bifunctor (first) +import qualified Data.Binary as Bin import Data.ByteString (ByteString) import Data.ByteString.Base64 (decodeBase64) -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial +import qualified Data.ByteString.Lazy as BSL import Data.Either (fromRight, isLeft, isRight) import Data.HashMap.Strict (fromList, singleton) import Data.Maybe (fromJust, isJust) -import Data.Serialize as S import Data.Text (Text) import qualified Data.Text as Text import Data.Text.Encoding (encodeUtf8) import Test.HUnit (Assertion, assertBool, assertEqual) -import Test.Hspec -import Test.QuickCheck +import Test.Hspec (Spec, describe, it) +import Test.QuickCheck ( + Gen, + Testable (property), + forAll, + vectorOf, + ) spec :: Spec spec = describe "partially signed bitcoin transaction unit tests" $ do it "encodes trivial psbt" $ - encodeHex (S.encode trivialPSBT) == trivialPSBTHex + encodeHex (U.encodeS trivialPSBT) == trivialPSBTHex it "decodes trivial psbt" $ decodeHexPSBT trivialPSBTHex == Right trivialPSBT it "encodes and decodes non-empty transactions" $ - S.decode (S.encode nonEmptyTransactionPSBT) == Right nonEmptyTransactionPSBT + (U.decode . Bin.encode) nonEmptyTransactionPSBT == Right nonEmptyTransactionPSBT it "does not decode invalid bip vectors" $ mapM_ invalidVecTest invalidVec it "encodes valid bip vecs" $ @@ -61,7 +114,7 @@ spec = describe "partially signed bitcoin transaction unit tests" $ do forAll arbitraryMultiSig $ verifyNonWitnessPSBT btc . unfinalizedMsPSBT btc it "encodes and decodes psbt with final witness script" $ - (fmap (encodeHex . S.encode) . decodeHexPSBT) validVec7Hex == Right validVec7Hex + (fmap (encodeHex . U.encodeS) . decodeHexPSBT) validVec7Hex == Right validVec7Hex it "handles complex psbts correctly" complexPsbtTest it "calculates keys properly" psbtSignerTest @@ -194,13 +247,15 @@ vec5Test = do , inputRedeemScript = Just . fromRight (error "vec5Test: Could not decode redeem script") - . decode + . U.decode + . BSL.fromStrict . fromJust $ decodeHex "0020771fd18ad459666dd49f3d564e3dbc42f4c84774e360ada16816a8ed488d5681" , inputWitnessScript = Just . fromRight (error "vec5Test: Could not decode witness script") - . decode + . U.decode + . BSL.fromStrict . fromJust $ decodeHex "522103b1341ccba7683b6af4f1238cd6e97e7167d569fac47f1e48d47541844355bd462103de55d1e1dac805e3f8a58c1fbf9b94c02f3dbaafe127fefca4995f26f82083bd52ae" , inputHDKeypaths = @@ -327,7 +382,7 @@ witnessScriptPubKey = decodeHexPSBT :: Text -> Either String PartiallySignedTransaction -decodeHexPSBT = S.decode . fromJust . decodeHex +decodeHexPSBT = U.decode . BSL.fromStrict . fromJust . decodeHex decodeHexPSBTM :: (Monad m, MonadFail m) => String -> Text -> m PartiallySignedTransaction @@ -336,13 +391,11 @@ decodeHexPSBTM errMsg = either (fail . (errMsg <>) . (": " <>)) return . decodeH hexScript :: Text -> ByteString hexScript = - either (error "Could not decode script") encodeScript - . runGetS deserialize + either (error "Could not decode script") U.encodeS + . U.decode @Script + . BSL.fromStrict . fromJust . decodeHex - where - encodeScript :: Script -> ByteString - encodeScript = runPutS . serialize invalidVecTest :: Text -> Assertion @@ -354,7 +407,7 @@ decodeVecTest i = assertBool (show i <> " decodes correctly") . isRight . decode encodeVecTest :: PartiallySignedTransaction -> Text -> Assertion -encodeVecTest psbt hex = assertEqual "encodes correctly" (S.encode psbt) (fromJust $ decodeHex hex) +encodeVecTest psbt hex = assertEqual "encodes correctly" (U.encodeS psbt) (fromJust $ decodeHex hex) trivialPSBT :: PartiallySignedTransaction @@ -398,7 +451,7 @@ unfinalizedPkhPSBT net (prvKey, pubKey) = prevOut = TxOut { outValue = 200000000 - , scriptOutput = runPutS (serialize prevOutScript) + , scriptOutput = U.encodeS prevOutScript } h = txSigHash net currTx prevOutScript (outValue prevOut) 0 sigHashAll sig = encodeTxSig $ TxSignature (signHash (secKeyData prvKey) h) sigHashAll @@ -605,6 +658,6 @@ instance FromJSON ComplexPsbtData where <*> psbtField "complete_psbt" obj <*> (obj .: "final_tx" >>= parseTx) where - parseTx = either fail pure . (S.decode <=< maybe (Left "hex") Right . decodeHex) - parsePsbt = either fail pure . (S.decode <=< first Text.unpack . decodeBase64) . encodeUtf8 + parseTx = either fail pure . (U.decode . BSL.fromStrict <=< maybe (Left "hex") Right . decodeHex) + parsePsbt = either fail pure . (U.decode . BSL.fromStrict <=< first Text.unpack . decodeBase64) . encodeUtf8 psbtField fieldName obj = obj .: fieldName >>= parsePsbt diff --git a/test/Bitcoin/Transaction/TaprootSpec.hs b/test/Bitcoin/Transaction/TaprootSpec.hs index 03ff256d..5846cf2e 100644 --- a/test/Bitcoin/Transaction/TaprootSpec.hs +++ b/test/Bitcoin/Transaction/TaprootSpec.hs @@ -27,6 +27,7 @@ import Bitcoin ( verifyScriptPathData, ) import Bitcoin.Orphans () +import qualified Bitcoin.Util as U import Bitcoin.UtilSpec (readTestFile) import Control.Applicative ((<|>)) import Control.Monad (zipWithM, (<=<)) @@ -35,9 +36,7 @@ import Data.Aeson.Types (Parser) import qualified Data.ByteArray as BA import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import Data.Bytes.Get (runGetS) -import Data.Bytes.Put (runPutS) -import Data.Bytes.Serial (deserialize, serialize) +import qualified Data.ByteString.Lazy as BSL import Data.Text (Text) import Data.Word (Word8) import Test.HUnit (assertBool, (@?=)) @@ -113,7 +112,7 @@ testControlBlocks testData = do keyParity :: PubKey -> Word8 -keyParity key = case BS.unpack . runPutS . serialize $ PubKeyI key True of +keyParity key = case BS.unpack . U.encodeS $ PubKeyI key True of 0x02 : _ -> 0x00 _ -> 0x01 @@ -140,14 +139,13 @@ instance FromJSON SpkGiven where <|> fail "Unable to parse scriptTree" parseScriptLeaf = withObject "ScriptTree leaf" $ \obj -> MASTLeaf - <$> obj - .: "leafVersion" + <$> obj .: "leafVersion" <*> (obj .: "script" >>= hexScript) parseScriptBranch v = parseJSON v >>= \case [v1, v2] -> MASTBranch <$> parseScriptTree v1 <*> parseScriptTree v2 _ -> fail "ScriptTree branch" - hexScript = either fail pure . runGetS deserialize <=< jsonHex + hexScript = either fail pure . U.decode . BSL.fromStrict <=< jsonHex data SpkIntermediary = SpkIntermediary @@ -175,11 +173,9 @@ data SpkExpected = SpkExpected instance FromJSON SpkExpected where parseJSON = withObject "SpkExpected" $ \obj -> SpkExpected - <$> obj - .: "scriptPubKey" + <$> obj .: "scriptPubKey" <*> (obj .:? "scriptPathControlBlocks" >>= (traverse . traverse) jsonHex) - <*> obj - .: "bip350Address" + <*> obj .: "bip350Address" data TestScriptPubKey = TestScriptPubKey @@ -193,10 +189,8 @@ instance FromJSON TestScriptPubKey where parseJSON = withObject "TestScriptPubKey" $ \obj -> TestScriptPubKey <$> (unSpkGiven <$> obj .: "given") - <*> obj - .: "intermediary" - <*> obj - .: "expected" + <*> obj .: "intermediary" + <*> obj .: "expected" newtype TestVector = TestVector diff --git a/test/Bitcoin/TransactionSpec.hs b/test/Bitcoin/TransactionSpec.hs index 6c60f9bc..0988dc61 100644 --- a/test/Bitcoin/TransactionSpec.hs +++ b/test/Bitcoin/TransactionSpec.hs @@ -2,30 +2,75 @@ module Bitcoin.TransactionSpec (spec) where -import Bitcoin.Address -import Bitcoin.Constants -import Bitcoin.Data -import Bitcoin.Keys +import Bitcoin.Address ( + Address (getAddrHash160), + addrToText, + isPubKeyAddress, + isScriptAddress, + ) +import Bitcoin.Constants (Network, btc) +import Bitcoin.Data () +import Bitcoin.Keys (SecKeyI (secKeyData)) import Bitcoin.Orphans () -import Bitcoin.Script -import Bitcoin.Transaction -import Bitcoin.Util -import Bitcoin.Util.Arbitrary -import Bitcoin.UtilSpec hiding (spec) -import qualified Data.ByteString as B -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Either -import Data.Maybe +import Bitcoin.Script ( + ScriptInput (RegularInput, ScriptHashInput), + ScriptOutput (PayPKHash, PayScriptHash), + SimpleInput (SpendMulSig), + decodeInputBS, + decodeOutputBS, + encodeOutput, + toP2SH, + ) +import Bitcoin.Transaction ( + OutPoint (OutPoint), + SigInput (SigInput), + Tx (txIn, txOut), + TxIn (scriptInput), + TxOut (scriptOutput), + buildAddrTx, + hexToTxHash, + isSegwit, + mergeTxs, + signNestedWitnessTx, + signTx, + txHash, + txHashToHex, + verifyStdTx, + ) +import Bitcoin.Util (decodeHex, eitherToMaybe, encodeHex) +import qualified Bitcoin.Util as U +import Bitcoin.Util.Arbitrary ( + TestCoin (TestCoin), + arbitraryAddress, + arbitraryLegacyTx, + arbitraryNetwork, + arbitraryOutPoint, + arbitraryPartialTxs, + arbitrarySatoshi, + arbitrarySigningData, + arbitraryTx, + arbitraryTxHash, + arbitraryTxIn, + arbitraryTxOut, + arbitraryWitnessTx, + ) +import Bitcoin.UtilSpec ( + JsonBox (..), + ReadBox (..), + SerialBox (..), + testIdentity, + ) +import qualified Data.ByteString.Lazy as BSL +import Data.Either (fromRight, isRight) +import Data.Maybe (fromJust) import Data.String (fromString) -import Data.String.Conversions +import Data.String.Conversions (cs) import Data.Text (Text) import Data.Word (Word32, Word64) -import Test.HUnit -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck +import Test.HUnit (Assertion, assertEqual) +import Test.Hspec (Spec, describe, it) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (Testable (property), forAll) serialVals :: [SerialBox] @@ -96,7 +141,7 @@ testTxidVector :: (Text, Text) -> Assertion testTxidVector (tid, tx) = assertEqual "txid" (Just tid) (txHashToHex . txHash <$> txM) where - txM = eitherToMaybe . runGetS deserialize =<< decodeHex tx + txM = eitherToMaybe . U.decode . BSL.fromStrict =<< decodeHex tx txidVectors :: [(Text, Text)] @@ -167,7 +212,7 @@ testPKHashVector (is, os, res) = assertEqual "Build PKHash Tx" (Right res) - (encodeHex . runPutS . serialize <$> txE) + (encodeHex . U.encodeS <$> txE) where txE = buildAddrTx btc (map f is) os f (tid, ix) = OutPoint (fromJust $ hexToTxHash tid) ix diff --git a/test/Bitcoin/UtilSpec.hs b/test/Bitcoin/UtilSpec.hs index fbc39e8d..ffa91e79 100644 --- a/test/Bitcoin/UtilSpec.hs +++ b/test/Bitcoin/UtilSpec.hs @@ -3,7 +3,6 @@ module Bitcoin.UtilSpec ( spec, - customCerealID, readTestFile, SerialBox (..), ReadBox (..), @@ -17,29 +16,46 @@ module Bitcoin.UtilSpec ( ) where import Bitcoin (Network) -import Bitcoin.Util -import Bitcoin.Util.Arbitrary +import Bitcoin.Util ( + bsToInteger, + decodeHex, + eitherToMaybe, + encodeHex, + integerToBS, + matchTemplate, + maybeToEither, + updateIndex, + ) +import qualified Bitcoin.Util as U +import Bitcoin.Util.Arbitrary (arbitraryBS, fromMap, toMap) import Control.Monad (forM_, (<=<)) import Data.Aeson (FromJSON, ToJSON) import qualified Data.Aeson as A -import Data.Aeson.Encoding -import Data.Aeson.Types +import Data.Aeson.Encoding ( + Encoding, + encodingToLazyByteString, + pair, + ) +import Data.Aeson.Types ( + Parser, + Result (Success), + ToJSON (toEncoding, toJSON), + Value, + fromJSON, + parseMaybe, + ) +import Data.Binary (Binary) +import qualified Data.Binary as Bin import qualified Data.ByteString as BS -import Data.ByteString.Lazy (fromStrict, toStrict) -import Data.Bytes.Get -import Data.Bytes.Put -import Data.Bytes.Serial -import Data.Either (fromLeft, fromRight, isLeft, isRight) +import qualified Data.ByteString.Lazy as BSL import Data.Foldable (toList) import Data.List (permutations) -import Data.Map.Strict (singleton) -import Data.Maybe +import Data.Maybe (catMaybes, isNothing) import qualified Data.Sequence as Seq -import Data.Serialize as S -import Data.Typeable -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.QuickCheck +import Data.Typeable (Proxy (..), Typeable, typeRep) +import Test.Hspec (Spec, describe, shouldBe, shouldSatisfy) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (Gen, forAll) spec :: Spec @@ -57,7 +73,7 @@ spec = {- Various utilities -} getPutInteger :: Integer -> Bool -getPutInteger i = bsToInteger (integerToBS $ abs i) == abs i +getPutInteger i = (bsToInteger . BSL.fromStrict . integerToBS . abs) i == abs i fromToHex :: BS.ByteString -> Bool @@ -98,10 +114,6 @@ testMaybeToEither m str = maybeToEither str m == Left str {-- Test Utilities --} -customCerealID :: Eq a => Get a -> Putter a -> a -> Bool -customCerealID g p a = runGet g (runPut (p a)) == Right a - - readTestFile :: A.FromJSON a => FilePath -> IO a readTestFile fp = A.eitherDecodeFileStrict ("data/" <> fp) >>= either (error . message) return @@ -113,7 +125,7 @@ readTestFile fp = data SerialBox = forall a. - (Show a, Eq a, Typeable a, Serial a) => + (Show a, Eq a, Typeable a, Binary a) => SerialBox (Gen a) @@ -200,14 +212,11 @@ testNetJson j e p g = do -- | Generate binary identity tests testSerial :: - (Eq a, Show a, Typeable a, Serial a) => Gen a -> Spec + (Eq a, Show a, Typeable a, Binary a) => Gen a -> Spec testSerial gen = prop ("Binary encoding/decoding identity for " <> name) $ forAll gen $ \x -> do - (runGetL deserialize . runPutL . serialize) x `shouldBe` x - (runGetL deserialize . fromStrict . runPutS . serialize) x `shouldBe` x - (runGetS deserialize . runPutS . serialize) x `shouldBe` Right x - (runGetS deserialize . toStrict . runPutL . serialize) x `shouldBe` Right x + (U.decode . Bin.encode) x `shouldBe` Right x where name = show $ typeRep $ proxy gen proxy :: Gen a -> Proxy a diff --git a/test/Spec.hs b/test/Spec.hs index 038e7c8e..c5e1636d 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,2 +1,36 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +module Main (main) where +import qualified Bitcoin.Address.Bech32Spec as Bech32 +import qualified Bitcoin.AddressSpec as Address +import qualified Bitcoin.BlockSpec as Block +import qualified Bitcoin.Crypto.HashSpec as Hash +import qualified Bitcoin.Crypto.SignatureSpec as Sig +import qualified Bitcoin.Keys.ExtendedSpec as Extended +import qualified Bitcoin.Keys.MnemonicSpec as Mnemonic +import qualified Bitcoin.KeysSpec as Keys +import qualified Bitcoin.NetworkSpec as Net +import qualified Bitcoin.ScriptSpec as Script +import qualified Bitcoin.Transaction.PartialSpec as Partial +import qualified Bitcoin.Transaction.TaprootSpec as Taproot +import qualified Bitcoin.TransactionSpec as Transaction +import qualified Bitcoin.UtilSpec as Utils +import Test.Hspec (hspec) + + +main :: IO () +main = hspec $ do + Address.spec + Bech32.spec + Block.spec + Hash.spec + Sig.spec + Keys.spec + Extended.spec + Mnemonic.spec + Net.spec + Script.spec + Transaction.spec + Partial.spec + Taproot.spec + Utils.spec + pure ()