From b62d19ae504faff24ac07542bbb4368b02eec6aa Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Tue, 4 Oct 2022 08:46:36 -0600 Subject: [PATCH 1/5] removes aeson and mtl --- bitcoin.cabal | 6 +- ...txt => test_vectors_asserti3-2d_run01.txt} | 0 ...txt => test_vectors_asserti3-2d_run02.txt} | 0 ...txt => test_vectors_asserti3-2d_run03.txt} | 0 ...txt => test_vectors_asserti3-2d_run04.txt} | 0 ...txt => test_vectors_asserti3-2d_run05.txt} | 0 ...txt => test_vectors_asserti3-2d_run06.txt} | 0 ...txt => test_vectors_asserti3-2d_run07.txt} | 0 ...txt => test_vectors_asserti3-2d_run08.txt} | 0 ...txt => test_vectors_asserti3-2d_run09.txt} | 0 ...txt => test_vectors_asserti3-2d_run10.txt} | 0 ...txt => test_vectors_asserti3-2d_run11.txt} | 0 ...txt => test_vectors_asserti3-2d_run12.txt} | 0 hie.yaml | 7 + package.yaml | 3 +- src/Bitcoin/Address.hs | 24 -- src/Bitcoin/Block/Common.hs | 75 ---- src/Bitcoin/Block/Headers.hs | 29 +- src/Bitcoin/Keys/Common.hs | 23 -- src/Bitcoin/Keys/Extended.hs | 89 ----- src/Bitcoin/Keys/Extended/Internal.hs | 15 - src/Bitcoin/Script/SigHash.hs | 12 - src/Bitcoin/Script/Standard.hs | 15 - src/Bitcoin/Transaction/Builder.hs | 1 - src/Bitcoin/Transaction/Builder/Sign.hs | 40 --- src/Bitcoin/Transaction/Common.hs | 98 ------ src/Bitcoin/Transaction/Taproot.hs | 14 - src/Bitcoin/Util.hs | 35 +- src/Bitcoin/Util/Arbitrary/Util.hs | 136 +------- stack.yaml | 2 +- stack.yaml.lock | 10 +- test/Bitcoin/AddressSpec.hs | 27 ++ test/Bitcoin/BlockSpec.hs | 46 ++- test/Bitcoin/Crypto/HashSpec.hs | 1 + test/Bitcoin/Keys/ExtendedSpec.hs | 26 +- test/Bitcoin/KeysSpec.hs | 3 +- test/Bitcoin/NetworkSpec.hs | 2 +- test/Bitcoin/Orphans.hs | 323 ++++++++++++++++++ test/Bitcoin/ScriptSpec.hs | 3 +- test/Bitcoin/Transaction/TaprootSpec.hs | 16 +- test/Bitcoin/TransactionSpec.hs | 2 + test/Bitcoin/UtilSpec.hs | 145 +++++++- 42 files changed, 595 insertions(+), 633 deletions(-) rename data/{test_vectors_aserti3-2d_run01.txt => test_vectors_asserti3-2d_run01.txt} (100%) rename data/{test_vectors_aserti3-2d_run02.txt => test_vectors_asserti3-2d_run02.txt} (100%) rename data/{test_vectors_aserti3-2d_run03.txt => test_vectors_asserti3-2d_run03.txt} (100%) rename data/{test_vectors_aserti3-2d_run04.txt => test_vectors_asserti3-2d_run04.txt} (100%) rename data/{test_vectors_aserti3-2d_run05.txt => test_vectors_asserti3-2d_run05.txt} (100%) rename data/{test_vectors_aserti3-2d_run06.txt => test_vectors_asserti3-2d_run06.txt} (100%) rename data/{test_vectors_aserti3-2d_run07.txt => test_vectors_asserti3-2d_run07.txt} (100%) rename data/{test_vectors_aserti3-2d_run08.txt => test_vectors_asserti3-2d_run08.txt} (100%) rename data/{test_vectors_aserti3-2d_run09.txt => test_vectors_asserti3-2d_run09.txt} (100%) rename data/{test_vectors_aserti3-2d_run10.txt => test_vectors_asserti3-2d_run10.txt} (100%) rename data/{test_vectors_aserti3-2d_run11.txt => test_vectors_asserti3-2d_run11.txt} (100%) rename data/{test_vectors_aserti3-2d_run12.txt => test_vectors_asserti3-2d_run12.txt} (100%) create mode 100644 hie.yaml create mode 100644 test/Bitcoin/Orphans.hs diff --git a/bitcoin.cabal b/bitcoin.cabal index 2cf10f3c..e7076878 100644 --- a/bitcoin.cabal +++ b/bitcoin.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack @@ -93,7 +93,6 @@ library src build-depends: QuickCheck >=2.13.2 - , aeson >=1.4.6.0 , array >=0.5.4.0 , base >=4.9 && <5 , base16 >=0.3.0.1 @@ -108,7 +107,6 @@ library , hashable >=1.3.0.0 , hspec >=2.7.1 , memory >=0.15.0 - , mtl >=2.2.2 , murmur3 >=1.0.3 , network >=3.1.1.1 , safe >=0.3.18 @@ -136,6 +134,7 @@ test-suite spec Bitcoin.Keys.MnemonicSpec Bitcoin.KeysSpec Bitcoin.NetworkSpec + Bitcoin.Orphans Bitcoin.ScriptSpec Bitcoin.Transaction.PartialSpec Bitcoin.Transaction.TaprootSpec @@ -166,7 +165,6 @@ test-suite spec , lens >=4.18.1 , lens-aeson >=1.1 , memory >=0.15.0 - , mtl >=2.2.2 , murmur3 >=1.0.3 , network >=3.1.1.1 , safe >=0.3.18 diff --git a/data/test_vectors_aserti3-2d_run01.txt b/data/test_vectors_asserti3-2d_run01.txt similarity index 100% rename from data/test_vectors_aserti3-2d_run01.txt rename to data/test_vectors_asserti3-2d_run01.txt diff --git a/data/test_vectors_aserti3-2d_run02.txt b/data/test_vectors_asserti3-2d_run02.txt similarity index 100% rename from data/test_vectors_aserti3-2d_run02.txt rename to data/test_vectors_asserti3-2d_run02.txt diff --git a/data/test_vectors_aserti3-2d_run03.txt b/data/test_vectors_asserti3-2d_run03.txt similarity index 100% rename from data/test_vectors_aserti3-2d_run03.txt rename to data/test_vectors_asserti3-2d_run03.txt diff --git a/data/test_vectors_aserti3-2d_run04.txt b/data/test_vectors_asserti3-2d_run04.txt similarity index 100% rename from data/test_vectors_aserti3-2d_run04.txt rename to data/test_vectors_asserti3-2d_run04.txt diff --git a/data/test_vectors_aserti3-2d_run05.txt b/data/test_vectors_asserti3-2d_run05.txt similarity index 100% rename from data/test_vectors_aserti3-2d_run05.txt rename to data/test_vectors_asserti3-2d_run05.txt diff --git a/data/test_vectors_aserti3-2d_run06.txt b/data/test_vectors_asserti3-2d_run06.txt similarity index 100% rename from data/test_vectors_aserti3-2d_run06.txt rename to data/test_vectors_asserti3-2d_run06.txt diff --git a/data/test_vectors_aserti3-2d_run07.txt b/data/test_vectors_asserti3-2d_run07.txt similarity index 100% rename from data/test_vectors_aserti3-2d_run07.txt rename to data/test_vectors_asserti3-2d_run07.txt diff --git a/data/test_vectors_aserti3-2d_run08.txt b/data/test_vectors_asserti3-2d_run08.txt similarity index 100% rename from data/test_vectors_aserti3-2d_run08.txt rename to data/test_vectors_asserti3-2d_run08.txt diff --git a/data/test_vectors_aserti3-2d_run09.txt b/data/test_vectors_asserti3-2d_run09.txt similarity index 100% rename from data/test_vectors_aserti3-2d_run09.txt rename to data/test_vectors_asserti3-2d_run09.txt diff --git a/data/test_vectors_aserti3-2d_run10.txt b/data/test_vectors_asserti3-2d_run10.txt similarity index 100% rename from data/test_vectors_aserti3-2d_run10.txt rename to data/test_vectors_asserti3-2d_run10.txt diff --git a/data/test_vectors_aserti3-2d_run11.txt b/data/test_vectors_asserti3-2d_run11.txt similarity index 100% rename from data/test_vectors_aserti3-2d_run11.txt rename to data/test_vectors_asserti3-2d_run11.txt diff --git a/data/test_vectors_aserti3-2d_run12.txt b/data/test_vectors_asserti3-2d_run12.txt similarity index 100% rename from data/test_vectors_aserti3-2d_run12.txt rename to data/test_vectors_asserti3-2d_run12.txt diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 00000000..470c57cb --- /dev/null +++ b/hie.yaml @@ -0,0 +1,7 @@ +cradle: + cabal: + - path: "src" + component: "lib:bitcoin" + + - path: "test" + component: "bitcoin:test:spec" diff --git a/package.yaml b/package.yaml index 9c26e25b..7bc8c322 100644 --- a/package.yaml +++ b/package.yaml @@ -19,7 +19,6 @@ extra-source-files: - README.md - CHANGELOG.md dependencies: - - aeson >= 1.4.6.0 - array >= 0.5.4.0 - base >=4.9 && <5 - base16 >= 0.3.0.1 @@ -34,7 +33,6 @@ dependencies: - hashable >= 1.3.0.0 - hspec >= 2.7.1 - memory >= 0.15.0 - - mtl >= 2.2.2 - murmur3 >= 1.0.3 - network >= 3.1.1.1 - QuickCheck >= 2.13.2 @@ -61,6 +59,7 @@ tests: verbatim: build-tool-depends: hspec-discover:hspec-discover dependencies: + - aeson >= 1.4.6.0 - base64 ^>= 0.4 - bitcoin - hspec >= 2.7.1 diff --git a/src/Bitcoin/Address.hs b/src/Bitcoin/Address.hs index 4c57a451..29f83a7c 100644 --- a/src/Bitcoin/Address.hs +++ b/src/Bitcoin/Address.hs @@ -22,9 +22,6 @@ module Bitcoin.Address ( textToAddr, bech32ToAddr, base58ToAddr, - addrToJSON, - addrToEncoding, - addrFromJSON, pubKeyAddr, pubKeyWitnessAddr, pubKeyCompatWitnessAddr, @@ -57,9 +54,6 @@ import Control.Applicative import Control.Arrow (second) import Control.DeepSeq import Control.Monad -import Data.Aeson as A -import Data.Aeson.Encoding as A -import Data.Aeson.Types import Data.Binary (Binary (..)) import Data.ByteString (ByteString) import qualified Data.ByteString as B @@ -181,24 +175,6 @@ isWitnessAddress WitnessAddress{} = True isWitnessAddress _ = False -addrToJSON :: Network -> Address -> Value -addrToJSON net a = toJSON (addrToText net a) - - -addrToEncoding :: Network -> Address -> Encoding -addrToEncoding net = maybe null_ text . addrToText net - - --- | JSON parsing for Bitcoin addresses. Works with 'Base58', and --- 'Bech32'. -addrFromJSON :: Network -> Value -> Parser Address -addrFromJSON net = - withText "address" $ \t -> - case textToAddr net t of - Nothing -> fail "could not decode address" - Just x -> return x - - -- | Convert address to human-readable string. Uses 'Base58', or 'Bech32' -- depending on network. addrToText :: Network -> Address -> Maybe Text diff --git a/src/Bitcoin/Block/Common.hs b/src/Bitcoin/Block/Common.hs index 7594beca..50fc3eb9 100644 --- a/src/Bitcoin/Block/Common.hs +++ b/src/Bitcoin/Block/Common.hs @@ -32,18 +32,6 @@ import Bitcoin.Transaction.Common import Bitcoin.Util import Control.DeepSeq import Control.Monad (forM_, liftM2, mzero, replicateM, (<=<)) -import Data.Aeson ( - FromJSON (..), - ToJSON (..), - Value (..), - object, - toJSON, - withObject, - withText, - (.:), - (.=), - ) -import Data.Aeson.Encoding (pairs, unsafeToEncoding) import Data.Binary (Binary (..)) import Data.Bits (shiftL, shiftR, (.&.), (.|.)) import qualified Data.ByteString as B @@ -111,17 +99,6 @@ instance Binary Block where put = serialize -instance ToJSON Block where - toJSON (Block h t) = object ["header" .= h, "transactions" .= t] - toEncoding (Block h t) = pairs $ "header" .= h <> "transactions" .= t - - -instance FromJSON Block where - parseJSON = - withObject "Block" $ \o -> - Block <$> o .: "header" <*> o .: "transactions" - - -- | Block header hash. To be serialized reversed for display purposes. newtype BlockHash = BlockHash { getBlockHash :: Hash256 @@ -155,21 +132,6 @@ instance IsString BlockHash where in fromMaybe e $ hexToBlockHash $ cs s -instance FromJSON BlockHash where - parseJSON = - withText "BlockHash" $ - maybe mzero return . hexToBlockHash - - -instance ToJSON BlockHash where - toJSON = String . blockHashToHex - toEncoding h = - unsafeToEncoding $ - char7 '"' - <> hexBuilder (BL.reverse (runPutL (serialize h))) - <> char7 '"' - - -- | Block hashes are reversed with respect to the in-memory byte order in a -- block hash when displayed. blockHashToHex :: BlockHash -> Text @@ -212,43 +174,6 @@ data BlockHeader = BlockHeader deriving (Eq, Ord, Show, Read, Generic, Hashable, NFData) --- 80 bytes - -instance ToJSON BlockHeader where - toJSON (BlockHeader v p m t b n) = - object - [ "version" .= v - , "prevblock" .= p - , "merkleroot" .= encodeHex (runPutS (serialize m)) - , "timestamp" .= t - , "bits" .= b - , "nonce" .= n - ] - toEncoding (BlockHeader v p m t b n) = - pairs - ( "version" .= v - <> "prevblock" .= p - <> "merkleroot" .= encodeHex (runPutS (serialize m)) - <> "timestamp" .= t - <> "bits" .= b - <> "nonce" .= n - ) - - -instance FromJSON BlockHeader where - parseJSON = - withObject "BlockHeader" $ \o -> - BlockHeader - <$> o .: "version" - <*> o .: "prevblock" - <*> (f =<< o .: "merkleroot") - <*> o .: "timestamp" - <*> o .: "bits" - <*> o .: "nonce" - where - f = maybe mzero return . (eitherToMaybe . runGetS deserialize <=< decodeHex) - - instance Serial BlockHeader where deserialize = do v <- getWord32le diff --git a/src/Bitcoin/Block/Headers.hs b/src/Bitcoin/Block/Headers.hs index d37a8089..2190aec9 100644 --- a/src/Bitcoin/Block/Headers.hs +++ b/src/Bitcoin/Block/Headers.hs @@ -45,7 +45,7 @@ module Bitcoin.Block.Headers ( bip34, validVersion, lastNoMinDiff, - computeAsertBits, + computeAssertBits, nextPowWorkRequired, calcNextWork, isValidPOW, @@ -68,19 +68,10 @@ import Bitcoin.Util import Control.Applicative ((<|>)) import Control.DeepSeq import Control.Monad (guard, mzero, unless, when) -import Control.Monad.Except ( - ExceptT (..), - runExceptT, - throwError, - ) -import Control.Monad.State.Strict as State ( - StateT, - get, - gets, - lift, - modify, - ) +import Control.Monad.Trans.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 Data.Binary (Binary (..)) import Data.Bits (shiftL, shiftR, (.&.)) import qualified Data.ByteString as B @@ -323,7 +314,7 @@ connectBlocks _ _ [] = return $ Right [] connectBlocks net t bhs@(bh : _) = runExceptT $ do unless (chained bhs) $ - throwError "Blocks to connect do not form a chain" + throwE "Blocks to connect do not form a chain" par <- maybeToExceptT "Could not get parent block" @@ -347,13 +338,13 @@ connectBlocks net t bhs@(bh : _) = case skM of Just sk -> return sk Nothing -> - throwError $ + throwE $ "BUG: Could not get skip for block " ++ show (headerHash $ nodeHeader par) | otherwise = do let sn = ls !! fromIntegral (nodeHeight par - sh) when (nodeHeight sn /= sh) $ - throwError "BUG: Node height not right in skip" + throwE "BUG: Node height not right in skip" return sn where sh = skipHeight (nodeHeight par + 1) @@ -394,7 +385,7 @@ connectBlock net t bh = case skM of Just sk -> return sk Nothing -> - throwError $ + throwE $ "BUG: Could not get skip for block " ++ show (headerHash $ nodeHeader par) bb <- lift getBestBlockHeader @@ -686,13 +677,13 @@ maxTarget :: Integer maxTarget = fst $ decodeCompact maxBits -computeAsertBits :: +computeAssertBits :: Integer -> Word32 -> Integer -> Integer -> Word32 -computeAsertBits halflife anchor_bits time_diff height_diff = +computeAssertBits halflife anchor_bits time_diff height_diff = if e2 >= 0 && e2 < 65536 then if g4 == 0 diff --git a/src/Bitcoin/Keys/Common.hs b/src/Bitcoin/Keys/Common.hs index cd796c67..5aa9f5e0 100644 --- a/src/Bitcoin/Keys/Common.hs +++ b/src/Bitcoin/Keys/Common.hs @@ -38,14 +38,6 @@ import Bitcoin.Util import Control.DeepSeq import Control.Monad (guard, mzero, (<=<)) import Crypto.Secp256k1 -import Data.Aeson ( - FromJSON, - ToJSON (..), - Value (String), - parseJSON, - withText, - ) -import Data.Aeson.Encoding (unsafeToEncoding) import Data.Binary (Binary (..)) import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -76,21 +68,6 @@ instance IsString PubKeyI where e = error "Could not decode public key" -instance ToJSON PubKeyI where - toJSON = String . encodeHex . runPutS . serialize - toEncoding s = - unsafeToEncoding $ - char7 '"' - <> hexBuilder (runPutL (serialize s)) - <> char7 '"' - - -instance FromJSON PubKeyI where - parseJSON = - withText "PubKeyI" $ - maybe mzero return . ((eitherToMaybe . runGetS deserialize) <=< decodeHex) - - instance Serial PubKeyI where deserialize = s >>= \case diff --git a/src/Bitcoin/Keys/Extended.hs b/src/Bitcoin/Keys/Extended.hs index 3b82c190..53172dd1 100644 --- a/src/Bitcoin/Keys/Extended.hs +++ b/src/Bitcoin/Keys/Extended.hs @@ -36,13 +36,7 @@ module Bitcoin.Keys.Extended ( xPubWitnessAddr, xPubCompatWitnessAddr, xPubExport, - xPubToJSON, - xPubToEncoding, - xPubFromJSON, xPrvExport, - xPrvToJSON, - xPrvToEncoding, - xPrvFromJSON, xPubImport, xPrvImport, xPrvWif, @@ -116,16 +110,6 @@ import Control.DeepSeq import Control.Exception (Exception, throw) import Control.Monad (guard, mzero, unless, (<=<)) import Crypto.Secp256k1 -import Data.Aeson as A ( - FromJSON, - ToJSON (..), - Value (String), - parseJSON, - toJSON, - withText, - ) -import Data.Aeson.Encoding (Encoding, text) -import Data.Aeson.Types (Parser) import Data.Binary (Binary (get, put)) import Data.Bits (clearBit, setBit, testBit) import Data.ByteString (ByteString) @@ -211,23 +195,6 @@ instance Serialize XPrvKey where get = deserialize -xPrvToJSON :: Network -> XPrvKey -> Value -xPrvToJSON net = A.String . xPrvExport net - - -xPrvToEncoding :: Network -> XPrvKey -> Encoding -xPrvToEncoding net = text . xPrvExport net - - --- | Decode an extended private key from a JSON string -xPrvFromJSON :: Network -> Value -> Parser XPrvKey -xPrvFromJSON net = - withText "xprv" $ \t -> - case xPrvImport net t of - Nothing -> fail "could not read xprv" - Just x -> return x - - -- | Data type representing an extended BIP32 public key. data XPubKey = XPubKey { xPubDepth :: !Word8 @@ -270,24 +237,6 @@ instance Binary XPubKey where get = deserialize --- | Decode an extended public key from a JSON string -xPubFromJSON :: Network -> Value -> Parser XPubKey -xPubFromJSON net = - withText "xpub" $ \t -> - case xPubImport net t of - Nothing -> fail "could not read xpub" - Just x -> return x - - --- | Get JSON 'Value' from 'XPubKey'. -xPubToJSON :: Network -> XPubKey -> Value -xPubToJSON net = A.String . xPubExport net - - -xPubToEncoding :: Network -> XPubKey -> Encoding -xPubToEncoding net = text . xPubExport net - - -- | Build a BIP32 compatible extended private key from a bytestring. This will -- produce a root node (@depth=0@ and @parent=0@). makeXPrvKey :: ByteString -> XPrvKey @@ -922,44 +871,6 @@ instance IsString SoftPath where e = error "Could not parse soft derivation path" -instance FromJSON ParsedPath where - parseJSON = withText "ParsedPath" $ \str -> case parsePath $ cs str of - Just p -> return p - _ -> mzero - - -instance FromJSON DerivPath where - parseJSON = withText "DerivPath" $ \str -> case parsePath $ cs str of - Just p -> return $ getParsedPath p - _ -> mzero - - -instance FromJSON HardPath where - parseJSON = withText "HardPath" $ \str -> case parseHard $ cs str of - Just p -> return p - _ -> mzero - - -instance FromJSON SoftPath where - parseJSON = withText "SoftPath" $ \str -> case parseSoft $ cs str of - Just p -> return p - _ -> mzero - - -instance ToJSON (DerivPathI t) where - toJSON = A.String . cs . pathToStr - toEncoding = text . cs . pathToStr - - -instance ToJSON ParsedPath where - toJSON (ParsedPrv p) = A.String . cs . ("m" ++) . pathToStr $ p - toJSON (ParsedPub p) = A.String . cs . ("M" ++) . pathToStr $ p - toJSON (ParsedEmpty p) = A.String . cs . ("" ++) . pathToStr $ p - toEncoding (ParsedPrv p) = text . cs . ("m" ++) . pathToStr $ p - toEncoding (ParsedPub p) = text . cs . ("M" ++) . pathToStr $ p - toEncoding (ParsedEmpty p) = text . cs . ("" ++) . pathToStr $ p - - {- Parsing derivation paths of the form m/1/2'/3 or M/1/2'/3 -} -- | Type for parsing derivation paths of the form /m\/1\/2'\/3/ or diff --git a/src/Bitcoin/Keys/Extended/Internal.hs b/src/Bitcoin/Keys/Extended/Internal.hs index d7f23a10..8bdc8595 100644 --- a/src/Bitcoin/Keys/Extended/Internal.hs +++ b/src/Bitcoin/Keys/Extended/Internal.hs @@ -10,13 +10,6 @@ module Bitcoin.Keys.Extended.Internal ( import Bitcoin.Util (decodeHex, encodeHex) import Control.DeepSeq (NFData) import Control.Monad ((>=>)) -import Data.Aeson ( - FromJSON, - ToJSON, - parseJSON, - toJSON, - withText, - ) import Data.Binary (Binary (..)) import Data.Bytes.Get (getWord32be) import Data.Bytes.Put (putWord32be) @@ -84,11 +77,3 @@ instance Binary Fingerprint where instance Serialize Fingerprint where put = serialize get = deserialize - - -instance FromJSON Fingerprint where - parseJSON = withText "Fingerprint" $ either fail pure . textToFingerprint - - -instance ToJSON Fingerprint where - toJSON = toJSON . fingerprintToText diff --git a/src/Bitcoin/Script/SigHash.hs b/src/Bitcoin/Script/SigHash.hs index 6d956192..fb672175 100644 --- a/src/Bitcoin/Script/SigHash.hs +++ b/src/Bitcoin/Script/SigHash.hs @@ -36,7 +36,6 @@ import Bitcoin.Transaction.Common import Bitcoin.Util import Control.DeepSeq import Control.Monad -import qualified Data.Aeson as J import Data.Bits import qualified Data.ByteString as BS import Data.Bytes.Get @@ -109,17 +108,6 @@ newtype SigHash ) -instance J.FromJSON SigHash where - parseJSON = - J.withScientific "sighash" $ - maybe mzero (return . SigHash) . toBoundedInteger - - -instance J.ToJSON SigHash where - toJSON = J.Number . fromIntegral - toEncoding (SigHash n) = J.toEncoding n - - -- | SIGHASH_NONE as a byte. sigHashNone :: SigHash sigHashNone = fromIntegral $ fromEnum SIGHASH_NONE diff --git a/src/Bitcoin/Script/Standard.hs b/src/Bitcoin/Script/Standard.hs index 598c11db..36042d49 100644 --- a/src/Bitcoin/Script/Standard.hs +++ b/src/Bitcoin/Script/Standard.hs @@ -50,8 +50,6 @@ import Bitcoin.Util import Control.Applicative ((<|>)) import Control.DeepSeq import Control.Monad (guard, liftM2, (<=<)) -import qualified Data.Aeson as A -import qualified Data.Aeson.Encoding as A import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.Bytes.Get @@ -94,19 +92,6 @@ data ScriptOutput deriving (Eq, Show, Read, Generic, Hashable, NFData) -instance A.FromJSON ScriptOutput where - parseJSON = - A.withText "scriptoutput" $ \t -> - either fail return $ - maybeToEither "scriptoutput not hex" (decodeHex t) - >>= decodeOutputBS - - -instance A.ToJSON ScriptOutput where - toJSON = A.String . encodeHex . encodeOutputBS - toEncoding = A.text . encodeHex . encodeOutputBS - - -- | Is script a pay-to-public-key output? isPayPK :: ScriptOutput -> Bool isPayPK (PayPK _) = True diff --git a/src/Bitcoin/Transaction/Builder.hs b/src/Bitcoin/Transaction/Builder.hs index 94aa7aa2..353161d0 100644 --- a/src/Bitcoin/Transaction/Builder.hs +++ b/src/Bitcoin/Transaction/Builder.hs @@ -51,7 +51,6 @@ import Bitcoin.Util import Control.Applicative ((<|>)) import Control.Arrow (first) import Control.Monad (foldM, unless) -import Control.Monad.Identity (runIdentity) import Crypto.Secp256k1 import qualified Data.ByteString as B import Data.Bytes.Get diff --git a/src/Bitcoin/Transaction/Builder/Sign.hs b/src/Bitcoin/Transaction/Builder/Sign.hs index e1e82c17..ea885017 100644 --- a/src/Bitcoin/Transaction/Builder/Sign.hs +++ b/src/Bitcoin/Transaction/Builder/Sign.hs @@ -35,17 +35,6 @@ import Bitcoin.Transaction.Segwit import Bitcoin.Util (matchTemplate, updateIndex) import Control.DeepSeq (NFData) import Control.Monad (foldM, when) -import Data.Aeson ( - FromJSON, - ToJSON (..), - object, - pairs, - parseJSON, - withObject, - (.:), - (.:?), - (.=), - ) import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial @@ -85,35 +74,6 @@ data SigInput = SigInput deriving (Eq, Show, Read, Generic, Hashable, NFData) -instance ToJSON SigInput where - toJSON (SigInput so val op sh rdm) = - object $ - [ "pkscript" .= so - , "value" .= val - , "outpoint" .= op - , "sighash" .= sh - ] - ++ ["redeem" .= r | r <- maybeToList rdm] - toEncoding (SigInput so val op sh rdm) = - pairs $ - "pkscript" .= so - <> "value" .= val - <> "outpoint" .= op - <> "sighash" .= sh - <> maybe mempty ("redeem" .=) rdm - - -instance FromJSON SigInput where - parseJSON = - withObject "SigInput" $ \o -> - SigInput - <$> o .: "pkscript" - <*> o .: "value" - <*> o .: "outpoint" - <*> o .: "sighash" - <*> o .:? "redeem" - - -- | Sign a transaction by providing the 'SigInput' signing parameters and a -- list of private keys. The signature is computed deterministically as defined -- in RFC-6979. diff --git a/src/Bitcoin/Transaction/Common.hs b/src/Bitcoin/Transaction/Common.hs index 56a2ec2a..d370b127 100644 --- a/src/Bitcoin/Transaction/Common.hs +++ b/src/Bitcoin/Transaction/Common.hs @@ -39,8 +39,6 @@ import Control.Monad ( when, (<=<), ) -import Data.Aeson as A -import Data.Aeson.Encoding (unsafeToEncoding) import Data.Binary (Binary (..)) import Data.ByteString (ByteString) import qualified Data.ByteString as B @@ -91,21 +89,6 @@ instance IsString TxHash where in fromMaybe e $ hexToTxHash $ cs s -instance FromJSON TxHash where - parseJSON = - withText "txid" $ - maybe mzero return . hexToTxHash - - -instance ToJSON TxHash where - toJSON = A.String . txHashToHex - toEncoding h = - unsafeToEncoding $ - char7 '"' - <> hexBuilder (BL.reverse (runPutL (serialize h))) - <> char7 '"' - - -- | Transaction hash excluding signatures. nosigTxHash :: Tx -> TxHash nosigTxHash tx = @@ -284,37 +267,6 @@ putWitnessData = mapM_ putWitnessStack putByteString bs -instance FromJSON Tx where - parseJSON = withObject "Tx" $ \o -> - Tx - <$> o .: "version" - <*> o .: "inputs" - <*> o .: "outputs" - <*> (mapM (mapM f) =<< o .: "witnessdata") - <*> o .: "locktime" - where - f = maybe mzero return . decodeHex - - -instance ToJSON Tx where - toJSON (Tx v i o w l) = - object - [ "version" .= v - , "inputs" .= i - , "outputs" .= o - , "witnessdata" .= fmap (fmap encodeHex) w - , "locktime" .= l - ] - toEncoding (Tx v i o w l) = - pairs - ( "version" .= v - <> "inputs" .= i - <> "outputs" .= o - <> "witnessdata" .= fmap (fmap encodeHex) w - <> "locktime" .= l - ) - - -- | Data type representing a transaction input. data TxIn = TxIn { prevOutput :: !OutPoint @@ -351,30 +303,6 @@ instance Serialize TxIn where put = serialize -instance FromJSON TxIn where - parseJSON = - withObject "TxIn" $ \o -> - TxIn - <$> o .: "prevoutput" - <*> (maybe mzero return . decodeHex =<< o .: "inputscript") - <*> o .: "sequence" - - -instance ToJSON TxIn where - toJSON (TxIn o s q) = - object - [ "prevoutput" .= o - , "inputscript" .= encodeHex s - , "sequence" .= q - ] - toEncoding (TxIn o s q) = - pairs - ( "prevoutput" .= o - <> "inputscript" .= encodeHex s - <> "sequence" .= q - ) - - -- | Data type representing a transaction output. data TxOut = TxOut { outValue :: !Word64 @@ -408,21 +336,6 @@ instance Serialize TxOut where get = deserialize -instance FromJSON TxOut where - parseJSON = - withObject "TxOut" $ \o -> - TxOut - <$> o .: "value" - <*> (maybe mzero return . decodeHex =<< o .: "outputscript") - - -instance ToJSON TxOut where - toJSON (TxOut o s) = - object ["value" .= o, "outputscript" .= encodeHex s] - toEncoding (TxOut o s) = - pairs ("value" .= o <> "outputscript" .= encodeHex s) - - -- | The 'OutPoint' refers to a transaction output being spent. data OutPoint = OutPoint { outPointHash :: !TxHash @@ -450,17 +363,6 @@ instance Serialize OutPoint where get = deserialize -instance FromJSON OutPoint where - parseJSON = - withObject "OutPoint" $ \o -> - OutPoint <$> o .: "txid" <*> o .: "index" - - -instance ToJSON OutPoint where - toJSON (OutPoint h i) = object ["txid" .= h, "index" .= i] - toEncoding (OutPoint h i) = pairs ("txid" .= h <> "index" .= i) - - -- | Outpoint used in coinbase transactions. nullOutPoint :: OutPoint nullOutPoint = diff --git a/src/Bitcoin/Transaction/Taproot.hs b/src/Bitcoin/Transaction/Taproot.hs index f3f1bcf5..594d1bae 100644 --- a/src/Bitcoin/Transaction/Taproot.hs +++ b/src/Bitcoin/Transaction/Taproot.hs @@ -41,7 +41,6 @@ import Crypto.Hash ( hashUpdate, hashUpdates, ) -import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), withText) import Data.Binary (Binary (..)) import Data.Bits ((.&.), (.|.)) import Data.Bool (bool) @@ -93,19 +92,6 @@ instance Binary XOnlyPubKey where get = deserialize --- | Hex encoding -instance FromJSON XOnlyPubKey where - parseJSON = - withText "XOnlyPubKey" $ - either fail pure - . (runGetS deserialize <=< maybe (Left "Unable to decode hex") Right . decodeHex) - - --- | Hex encoding -instance ToJSON XOnlyPubKey where - toJSON = toJSON . encodeHex . runPutS . serialize - - type TapLeafVersion = Word8 diff --git a/src/Bitcoin/Util.hs b/src/Bitcoin/Util.hs index fc884f48..2f6d95a3 100644 --- a/src/Bitcoin/Util.hs +++ b/src/Bitcoin/Util.hs @@ -21,7 +21,6 @@ module Bitcoin.Util ( -- * Maybe & Either Helpers eitherToMaybe, maybeToEither, - liftEither, liftMaybe, -- * Other Helpers @@ -34,10 +33,6 @@ module Bitcoin.Util ( snd3, lst3, - -- * JSON Utilities - dropFieldLabel, - dropSumLabels, - -- * Serialization Helpers putList, getList, @@ -58,13 +53,7 @@ module Bitcoin.Util ( ) where import Control.Monad -import Control.Monad.Except (ExceptT (..), liftEither) -import Data.Aeson.Types ( - Options (..), - SumEncoding (..), - defaultOptions, - defaultTaggedObject, - ) +import Control.Monad.Trans.Except (ExceptT (..)) import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -160,7 +149,7 @@ maybeToEither err = maybe (Left err) Right -- | Lift a 'Maybe' computation into the 'ExceptT' monad. liftMaybe :: Monad m => b -> Maybe a -> ExceptT b m a -liftMaybe err = liftEither . maybeToEither err +liftMaybe err = ExceptT . pure . maybeToEither err -- Various helpers @@ -217,26 +206,6 @@ lst3 :: (a, b, c) -> c lst3 (_, _, c) = c --- | Field label goes lowercase and first @n@ characters get removed. -dropFieldLabel :: Int -> Options -dropFieldLabel n = - defaultOptions - { fieldLabelModifier = map toLower . drop n - } - - --- | Transformation from 'dropFieldLabel' is applied with argument @f@, plus --- constructor tags are lowercased and first @c@ characters removed. @tag@ is --- used as the name of the object field name that will hold the transformed --- constructor tag as its value. -dropSumLabels :: Int -> Int -> String -> Options -dropSumLabels c f tag = - (dropFieldLabel f) - { constructorTagModifier = map toLower . drop c - , sumEncoding = defaultTaggedObject{tagFieldName = tag} - } - - -- | Convert from one power-of-two base to another, as long as it fits in a -- 'Word'. convertBits :: Bool -> Int -> Int -> [Word] -> ([Word], Bool) diff --git a/src/Bitcoin/Util/Arbitrary/Util.hs b/src/Bitcoin/Util/Arbitrary/Util.hs index f884edbd..845a2cd3 100644 --- a/src/Bitcoin/Util/Arbitrary/Util.hs +++ b/src/Bitcoin/Util/Arbitrary/Util.hs @@ -14,25 +14,15 @@ module Bitcoin.Util.Arbitrary.Util ( arbitraryMaybe, arbitraryNetwork, arbitraryUTCTime, - SerialBox (..), - JsonBox (..), - NetBox (..), - ReadBox (..), - testIdentity, - testSerial, - testRead, - testJson, - testNetJson, arbitraryNetData, genNetData, + toMap, + fromMap, ) where import Bitcoin.Constants import Bitcoin.Data import Control.Monad (forM_, (<=<)) -import qualified Data.Aeson as A -import qualified Data.Aeson.Encoding as A -import qualified Data.Aeson.Types as A import Data.ByteString (ByteString, pack) import Data.ByteString.Lazy (fromStrict, toStrict) import qualified Data.ByteString.Short as BSS @@ -101,124 +91,6 @@ arbitraryNetwork :: Gen Network arbitraryNetwork = elements allNets --- Helpers for creating Serial and JSON Identity tests - -data SerialBox - = forall a. - (Show a, Eq a, T.Typeable a, Serial a) => - SerialBox (Gen a) - - -data ReadBox - = forall a. - (Read a, Show a, Eq a, T.Typeable a) => - ReadBox (Gen a) - - -data JsonBox - = forall a. - (Show a, Eq a, T.Typeable a, A.ToJSON a, A.FromJSON a) => - JsonBox (Gen a) - - -data NetBox - = forall a. - (Show a, Eq a, T.Typeable a) => - NetBox - ( Network -> a -> A.Value - , Network -> a -> A.Encoding - , Network -> A.Value -> A.Parser a - , Gen (Network, a) - ) - - -testIdentity :: [SerialBox] -> [ReadBox] -> [JsonBox] -> [NetBox] -> Spec -testIdentity serialVals readVals jsonVals netVals = do - describe "Binary Encoding" $ - forM_ serialVals $ - \(SerialBox g) -> testSerial g - describe "Read/Show Encoding" $ - forM_ readVals $ - \(ReadBox g) -> testRead g - describe "Data.Aeson Encoding" $ - forM_ jsonVals $ - \(JsonBox g) -> testJson g - describe "Data.Aeson Encoding with Network" $ - forM_ netVals $ - \(NetBox (j, e, p, g)) -> testNetJson j e p g - - --- | Generate binary identity tests -testSerial :: - (Eq a, Show a, T.Typeable a, Serial a) => Gen a -> Spec -testSerial gen = - prop ("Binary encoding/decoding identity for " <> name) $ - forAll gen $ \x -> do - (runGetL deserialize . runPutL . serialize) x `shouldBe` x - (runGetL deserialize . fromStrict . runPutS . serialize) x `shouldBe` x - (runGetS deserialize . runPutS . serialize) x `shouldBe` Right x - (runGetS deserialize . toStrict . runPutL . serialize) x `shouldBe` Right x - where - name = show $ T.typeRep $ proxy gen - proxy :: Gen a -> Proxy a - proxy = const Proxy - - --- | Generate Read/Show identity tests -testRead :: - (Eq a, Read a, Show a, T.Typeable a) => Gen a -> Spec -testRead gen = - prop ("read/show identity for " <> name) $ - forAll gen $ - \x -> (read . show) x `shouldBe` x - where - name = show $ T.typeRep $ proxy gen - proxy :: Gen a -> Proxy a - proxy = const Proxy - - --- | Generate Data.Aeson identity tests -testJson :: - (Eq a, Show a, T.Typeable a, A.ToJSON a, A.FromJSON a) => Gen a -> Spec -testJson gen = do - prop ("Data.Aeson toJSON/fromJSON identity for " <> name) $ - forAll gen (`shouldSatisfy` jsonID) - prop ("Data.Aeson toEncoding/fromJSON identity for " <> name) $ - forAll gen (`shouldSatisfy` encodingID) - where - name = show $ T.typeRep $ proxy gen - proxy :: Gen a -> Proxy a - proxy = const Proxy - jsonID x = (A.fromJSON . A.toJSON) (toMap x) == A.Success (toMap x) - encodingID x = - (A.decode . A.encodingToLazyByteString . A.toEncoding) (toMap x) - == Just (toMap x) - - --- | Generate Data.Aeson identity tests for type that need the @Network@ -testNetJson :: - (Eq a, Show a, T.Typeable a) => - (Network -> a -> A.Value) -> - (Network -> a -> A.Encoding) -> - (Network -> A.Value -> A.Parser a) -> - Gen (Network, a) -> - Spec -testNetJson j e p g = do - prop ("Data.Aeson toJSON/fromJSON identity (with network) for " <> name) $ - forAll g $ - \(net, x) -> dec net (encVal net x) `shouldBe` Just x - prop ("Data.Aeson toEncoding/fromJSON identity (with network) for " <> name) $ - forAll g $ - \(net, x) -> dec net (encEnc net x) `shouldBe` Just x - where - encVal net = A.encode . toMap . j net - encEnc net = A.encodingToLazyByteString . toMapE . e net - dec net = A.parseMaybe (p net) . fromMap <=< A.decode - name = show $ T.typeRep $ proxy j - proxy :: (Network -> a -> A.Value) -> Proxy a - proxy = const Proxy - - arbitraryNetData :: Arbitrary a => Gen (Network, a) arbitraryNetData = do net <- arbitraryNetwork @@ -237,9 +109,5 @@ toMap :: a -> Map.Map String a toMap = Map.singleton "object" -toMapE :: A.Encoding -> A.Encoding -toMapE = A.pairs . A.pair "object" - - fromMap :: Map.Map String a -> a fromMap = (Map.! "object") diff --git a/stack.yaml b/stack.yaml index f3a4011d..5f3db2d3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-19.22 +resolver: lts-19.27 system-ghc: true nix: packages: diff --git a/stack.yaml.lock b/stack.yaml.lock index eefaa121..64fdfd07 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -7,13 +7,13 @@ packages: - completed: hackage: fourmolu-0.8.2.0@sha256:2cc2e4b296897b14e937c6a22e1b9840699b2b7bf5021fbdc6f212376d44edb6,7469 pantry-tree: - size: 143718 sha256: e467a3bce53e6bbb71414a368369095eee13e423d093a5aff2cd128317362c3e + size: 143718 original: hackage: fourmolu-0.8.2.0 snapshots: - completed: - size: 619399 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/22.yaml - sha256: 5098594e71bdefe0c13e9e6236f12e3414ef91a2b89b029fd30e8fc8087f3a07 - original: lts-19.22 + sha256: 1ecad1f0bd2c27de88dbff6572446cfdf647c615d58a7e2e2085c6b7dfc04176 + size: 619403 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/27.yaml + original: lts-19.27 diff --git a/test/Bitcoin/AddressSpec.hs b/test/Bitcoin/AddressSpec.hs index a88dcea6..8a5b3224 100644 --- a/test/Bitcoin/AddressSpec.hs +++ b/test/Bitcoin/AddressSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} module Bitcoin.AddressSpec (spec) where @@ -8,17 +9,43 @@ 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 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 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 +addrToJSON :: Network -> Address -> Value +addrToJSON net a = toJSON (addrToText net a) + + +addrToEncoding :: Network -> Address -> Encoding +addrToEncoding net = maybe null_ text . addrToText net + + +-- | JSON parsing for Bitcoin addresses. Works with 'Base58', and +-- 'Bech32'. +addrFromJSON :: Network -> Value -> Parser Address +addrFromJSON net = + withText "address" $ \t -> + case textToAddr net t of + Nothing -> fail "could not decode address" + Just x -> return x + + serialVals :: [SerialBox] serialVals = [SerialBox arbitraryAddressAll] diff --git a/test/Bitcoin/BlockSpec.hs b/test/Bitcoin/BlockSpec.hs index c129761a..7ea9ff84 100644 --- a/test/Bitcoin/BlockSpec.hs +++ b/test/Bitcoin/BlockSpec.hs @@ -7,9 +7,19 @@ module Bitcoin.BlockSpec ( import Bitcoin.Block import Bitcoin.Constants import Bitcoin.Data +import Bitcoin.Orphans () import Bitcoin.Transaction +import Bitcoin.Util import Bitcoin.Util.Arbitrary -import Control.Monad.State.Strict +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 Data.Either (fromRight) import Data.Maybe (fromJust) import Data.String (fromString) @@ -95,11 +105,11 @@ spec = do describe "compact number" $ do it "compact number local vectors" testCompact it "compact number imported vectors" testCompactBitcoinCore - describe "asert" $ + describe "assert" $ mapM_ ( \x -> - asertTests $ - "test_vectors_aserti3-2d_run" ++ printf "%02d" x ++ ".txt" + assertTests $ + "test_vectors_asserti3-2d_run" ++ printf "%02d" x ++ ".txt" ) [(1 :: Int) .. 12] describe "helper functions" $ do @@ -377,14 +387,14 @@ testSubsidy net = go (2 * 50 * 100 * 1000 * 1000) 0 go subsidy (halvings + 1) -data AsertBlock = AsertBlock Int Integer Integer Word32 +data AssertBlock = AssertBlock Int Integer Integer Word32 -data AsertVector = AsertVector String Integer Integer Word32 [AsertBlock] +data AssertVector = AssertVector String Integer Integer Word32 [AssertBlock] -readAsertVector :: FilePath -> IO AsertVector -readAsertVector p = do +readAssertVector :: FilePath -> IO AssertVector +readAssertVector p = do (d : ah : apt : ab : _ : _ : _ : _ : xs) <- lines <$> readFile ("data/" ++ p) let desc = drop 16 d anchor_height = read (words ah !! 3) @@ -392,27 +402,27 @@ readAsertVector p = do anchor_nbits = read (words ab !! 3) blocks = map (f . words) (init xs) return $ - AsertVector + AssertVector desc anchor_height anchor_parent_time anchor_nbits blocks where - f [i, h, t, g] = AsertBlock (read i) (read h) (read t) (read g) + f [i, h, t, g] = AssertBlock (read i) (read h) (read t) (read g) f _ = undefined -asertTests :: FilePath -> SpecWith () -asertTests file = do - v@(AsertVector d _ _ _ _) <- runIO $ readAsertVector file - it d $ testAsertBits v +assertTests :: FilePath -> SpecWith () +assertTests file = do + v@(AssertVector d _ _ _ _) <- runIO $ readAssertVector file + it d $ testAssertBits v -testAsertBits :: AsertVector -> Assertion -testAsertBits (AsertVector _ anchor_height anchor_parent_time anchor_bits blocks) = - forM_ blocks $ \(AsertBlock _ h t g) -> - computeAsertBits +testAssertBits :: AssertVector -> Assertion +testAssertBits (AssertVector _ anchor_height anchor_parent_time anchor_bits blocks) = + forM_ blocks $ \(AssertBlock _ h t g) -> + computeAssertBits (2 * 24 * 60 * 60) anchor_bits (t - anchor_parent_time) diff --git a/test/Bitcoin/Crypto/HashSpec.hs b/test/Bitcoin/Crypto/HashSpec.hs index 0b8d2196..65a8d65c 100644 --- a/test/Bitcoin/Crypto/HashSpec.hs +++ b/test/Bitcoin/Crypto/HashSpec.hs @@ -6,6 +6,7 @@ import Bitcoin.Block import Bitcoin.Crypto import Bitcoin.Util import Bitcoin.Util.Arbitrary +import Bitcoin.UtilSpec hiding (spec) import Data.Bits import Data.ByteString (ByteString) import Data.ByteString.Builder diff --git a/test/Bitcoin/Keys/ExtendedSpec.hs b/test/Bitcoin/Keys/ExtendedSpec.hs index d4c5f838..f8254327 100644 --- a/test/Bitcoin/Keys/ExtendedSpec.hs +++ b/test/Bitcoin/Keys/ExtendedSpec.hs @@ -6,11 +6,14 @@ module Bitcoin.Keys.ExtendedSpec (spec) where import Bitcoin.Address import Bitcoin.Constants import Bitcoin.Keys +import Bitcoin.Orphans () import Bitcoin.Util import Bitcoin.Util.Arbitrary -import Bitcoin.UtilSpec (customCerealID) +import Bitcoin.UtilSpec (JsonBox (..), NetBox (..), ReadBox (..), SerialBox (..), customCerealID, testIdentity) import Control.Monad (forM_) import Data.Aeson as A +import Data.Aeson.Encoding +import Data.Aeson.Types import Data.Bits ((.&.)) import qualified Data.ByteString.Lazy.Char8 as B8 import Data.Bytes.Get @@ -72,6 +75,27 @@ netVals = , genNetData (snd <$> arbitraryXPubKey) ) ] + where + xPrvToJSON :: Network -> XPrvKey -> Value + xPrvToJSON net = A.String . xPrvExport net + xPrvToEncoding :: Network -> XPrvKey -> Encoding + xPrvToEncoding net = text . xPrvExport net + xPrvFromJSON :: Network -> Value -> Parser XPrvKey + xPrvFromJSON net = + withText "xprv" $ \t -> + case xPrvImport net t of + Nothing -> fail "could not read xprv" + Just x -> return x + xPubFromJSON :: Network -> Value -> Parser XPubKey + xPubFromJSON net = + withText "xpub" $ \t -> + case xPubImport net t of + Nothing -> fail "could not read xpub" + Just x -> return x + xPubToJSON :: Network -> XPubKey -> Value + xPubToJSON net = A.String . xPubExport net + xPubToEncoding :: Network -> XPubKey -> Encoding + xPubToEncoding net = text . xPubExport net spec :: Spec diff --git a/test/Bitcoin/KeysSpec.hs b/test/Bitcoin/KeysSpec.hs index 1f64ee9b..b01a1b20 100644 --- a/test/Bitcoin/KeysSpec.hs +++ b/test/Bitcoin/KeysSpec.hs @@ -6,10 +6,11 @@ import Bitcoin.Address import Bitcoin.Constants import Bitcoin.Crypto import Bitcoin.Keys +import Bitcoin.Orphans () import Bitcoin.Script import Bitcoin.Util import Bitcoin.Util.Arbitrary -import Bitcoin.UtilSpec (readTestFile) +import Bitcoin.UtilSpec hiding (spec) import Control.Lens import Control.Monad import Data.Aeson as A diff --git a/test/Bitcoin/NetworkSpec.hs b/test/Bitcoin/NetworkSpec.hs index 1d1fcb03..f587cc9b 100644 --- a/test/Bitcoin/NetworkSpec.hs +++ b/test/Bitcoin/NetworkSpec.hs @@ -9,7 +9,7 @@ import Bitcoin.Network import Bitcoin.Transaction import Bitcoin.Util import Bitcoin.Util.Arbitrary -import Bitcoin.UtilSpec (customCerealID) +import Bitcoin.UtilSpec hiding (spec) import Data.Bytes.Get import Data.Bytes.Put import Data.Bytes.Serial diff --git a/test/Bitcoin/Orphans.hs b/test/Bitcoin/Orphans.hs new file mode 100644 index 00000000..5a06528b --- /dev/null +++ b/test/Bitcoin/Orphans.hs @@ -0,0 +1,323 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +module Bitcoin.Orphans where + +import Bitcoin +import Control.Monad +import Data.Aeson +import Data.Aeson.Encoding +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 + + +instance FromJSON BlockHash where + parseJSON = + withText "BlockHash" $ + maybe mzero return . hexToBlockHash + + +instance ToJSON BlockHash where + toJSON = String . blockHashToHex + toEncoding h = + unsafeToEncoding $ + char7 '"' + <> hexBuilder (BL.reverse (runPutL (serialize h))) + <> char7 '"' + + +instance ToJSON BlockHeader where + toJSON (BlockHeader v p m t b n) = + object + [ "version" .= v + , "prevblock" .= p + , "merkleroot" .= encodeHex (runPutS (serialize m)) + , "timestamp" .= t + , "bits" .= b + , "nonce" .= n + ] + toEncoding (BlockHeader v p m t b n) = + pairs + ( "version" + .= v + <> "prevblock" + .= p + <> "merkleroot" + .= encodeHex (runPutS (serialize m)) + <> "timestamp" + .= t + <> "bits" + .= b + <> "nonce" + .= n + ) + + +instance FromJSON BlockHeader where + parseJSON = + withObject "BlockHeader" $ \o -> + BlockHeader + <$> o + .: "version" + <*> o + .: "prevblock" + <*> (f =<< o .: "merkleroot") + <*> o + .: "timestamp" + <*> o + .: "bits" + <*> o + .: "nonce" + where + f = maybe mzero return . (eitherToMaybe . runGetS deserialize <=< decodeHex) + + +instance FromJSON TxHash where + parseJSON = + withText "txid" $ + maybe mzero return . hexToTxHash + + +instance ToJSON TxHash where + toJSON = String . txHashToHex + toEncoding h = + unsafeToEncoding $ + char7 '"' + <> hexBuilder (BL.reverse (runPutL (serialize h))) + <> char7 '"' + + +instance FromJSON OutPoint where + parseJSON = + withObject "OutPoint" $ \o -> + OutPoint <$> o .: "txid" <*> o .: "index" + + +instance ToJSON OutPoint where + toJSON (OutPoint h i) = object ["txid" .= h, "index" .= i] + toEncoding (OutPoint h i) = pairs ("txid" .= h <> "index" .= i) + + +instance FromJSON TxIn where + parseJSON = + withObject "TxIn" $ \o -> + TxIn + <$> o + .: "prevoutput" + <*> (maybe mzero return . decodeHex =<< o .: "inputscript") + <*> o + .: "sequence" + + +instance ToJSON TxIn where + toJSON (TxIn o s q) = + object + [ "prevoutput" .= o + , "inputscript" .= encodeHex s + , "sequence" .= q + ] + toEncoding (TxIn o s q) = + pairs + ( "prevoutput" + .= o + <> "inputscript" + .= encodeHex s + <> "sequence" + .= q + ) + + +instance FromJSON TxOut where + parseJSON = + withObject "TxOut" $ \o -> + TxOut + <$> o + .: "value" + <*> (maybe mzero return . decodeHex =<< o .: "outputscript") + + +instance ToJSON TxOut where + toJSON (TxOut o s) = + object ["value" .= o, "outputscript" .= encodeHex s] + toEncoding (TxOut o s) = + pairs ("value" .= o <> "outputscript" .= encodeHex s) + + +instance FromJSON Tx where + parseJSON = withObject "Tx" $ \o -> + Tx + <$> o + .: "version" + <*> o + .: "inputs" + <*> o + .: "outputs" + <*> (mapM (mapM f) =<< o .: "witnessdata") + <*> o + .: "locktime" + where + f = maybe mzero return . decodeHex + + +instance ToJSON Tx where + toJSON (Tx v i o w l) = + object + [ "version" .= v + , "inputs" .= i + , "outputs" .= o + , "witnessdata" .= fmap (fmap encodeHex) w + , "locktime" .= l + ] + toEncoding (Tx v i o w l) = + pairs + ( "version" + .= v + <> "inputs" + .= i + <> "outputs" + .= o + <> "witnessdata" + .= fmap (fmap encodeHex) w + <> "locktime" + .= l + ) + + +instance ToJSON Block where + toJSON (Block h t) = object ["header" .= h, "transactions" .= t] + toEncoding (Block h t) = pairs $ "header" .= h <> "transactions" .= t + + +instance FromJSON Block where + parseJSON = + withObject "Block" $ \o -> + Block <$> o .: "header" <*> o .: "transactions" + + +instance ToJSON (DerivPathI t) where + toJSON = String . cs . pathToStr + toEncoding = text . cs . pathToStr + + +instance FromJSON DerivPath where + parseJSON = withText "DerivPath" $ \str -> case parsePath $ cs str of + Just p -> return $ getParsedPath p + _ -> mzero + + +instance ToJSON ParsedPath where + toJSON (ParsedPrv p) = String . cs . ("m" ++) . pathToStr $ p + toJSON (ParsedPub p) = String . cs . ("M" ++) . pathToStr $ p + toJSON (ParsedEmpty p) = String . cs . ("" ++) . pathToStr $ p + toEncoding (ParsedPrv p) = text . cs . ("m" ++) . pathToStr $ p + toEncoding (ParsedPub p) = text . cs . ("M" ++) . pathToStr $ p + toEncoding (ParsedEmpty p) = text . cs . ("" ++) . pathToStr $ p + + +instance FromJSON ParsedPath where + parseJSON = withText "ParsedPath" $ \str -> case parsePath $ cs str of + Just p -> return p + _ -> mzero + + +instance FromJSON HardPath where + parseJSON = withText "HardPath" $ \str -> case parseHard $ cs str of + Just p -> return p + _ -> mzero + + +instance FromJSON SoftPath where + parseJSON = withText "SoftPath" $ \str -> case parseSoft $ cs str of + Just p -> return p + _ -> mzero + + +instance ToJSON PubKeyI where + toJSON = String . encodeHex . runPutS . serialize + toEncoding s = + unsafeToEncoding $ + char7 '"' + <> hexBuilder (runPutL (serialize s)) + <> char7 '"' + + +instance FromJSON PubKeyI where + parseJSON = + withText "PubKeyI" $ + maybe mzero return . ((eitherToMaybe . runGetS deserialize) <=< decodeHex) + + +instance FromJSON SigHash where + parseJSON = + withScientific "sighash" $ + maybe mzero (return . SigHash) . toBoundedInteger + + +instance ToJSON SigHash where + toJSON = Number . fromIntegral + toEncoding (SigHash n) = toEncoding n + + +instance FromJSON ScriptOutput where + parseJSON = + withText "scriptoutput" $ \t -> + either fail return $ + maybeToEither "scriptoutput not hex" (decodeHex t) + >>= decodeOutputBS + + +instance ToJSON ScriptOutput where + toJSON = String . encodeHex . encodeOutputBS + toEncoding = text . encodeHex . encodeOutputBS + + +instance ToJSON SigInput where + toJSON (SigInput so val op sh rdm) = + object $ + [ "pkscript" .= so + , "value" .= val + , "outpoint" .= op + , "sighash" .= sh + ] + ++ ["redeem" .= r | r <- maybeToList rdm] + toEncoding (SigInput so val op sh rdm) = + pairs $ + "pkscript" + .= so + <> "value" + .= val + <> "outpoint" + .= op + <> "sighash" + .= sh + <> maybe mempty ("redeem" .=) rdm + + +instance FromJSON SigInput where + parseJSON = + withObject "SigInput" $ \o -> + SigInput + <$> o + .: "pkscript" + <*> o + .: "value" + <*> o + .: "outpoint" + <*> o + .: "sighash" + <*> o + .:? "redeem" + + +-- | Hex encoding +instance FromJSON XOnlyPubKey where + parseJSON = + withText "XOnlyPubKey" $ + either fail pure + . (runGetS deserialize <=< maybe (Left "Unable to decode hex") Right . decodeHex) diff --git a/test/Bitcoin/ScriptSpec.hs b/test/Bitcoin/ScriptSpec.hs index 0500ba8f..85cb4252 100644 --- a/test/Bitcoin/ScriptSpec.hs +++ b/test/Bitcoin/ScriptSpec.hs @@ -6,11 +6,12 @@ import Bitcoin.Address import Bitcoin.Constants import Bitcoin.Data import Bitcoin.Keys +import Bitcoin.Orphans () import Bitcoin.Script import Bitcoin.Transaction import Bitcoin.Util import Bitcoin.Util.Arbitrary -import Bitcoin.UtilSpec (readTestFile) +import Bitcoin.UtilSpec hiding (spec) import Control.Monad import Data.Aeson as A import Data.ByteString (ByteString) diff --git a/test/Bitcoin/Transaction/TaprootSpec.hs b/test/Bitcoin/Transaction/TaprootSpec.hs index 16f707d2..03ff256d 100644 --- a/test/Bitcoin/Transaction/TaprootSpec.hs +++ b/test/Bitcoin/Transaction/TaprootSpec.hs @@ -26,6 +26,7 @@ import Bitcoin ( taprootScriptOutput, verifyScriptPathData, ) +import Bitcoin.Orphans () import Bitcoin.UtilSpec (readTestFile) import Control.Applicative ((<|>)) import Control.Monad (zipWithM, (<=<)) @@ -139,7 +140,8 @@ 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 @@ -173,9 +175,11 @@ 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 @@ -189,8 +193,10 @@ 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 577eb849..6c60f9bc 100644 --- a/test/Bitcoin/TransactionSpec.hs +++ b/test/Bitcoin/TransactionSpec.hs @@ -6,10 +6,12 @@ import Bitcoin.Address import Bitcoin.Constants import Bitcoin.Data import Bitcoin.Keys +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 diff --git a/test/Bitcoin/UtilSpec.hs b/test/Bitcoin/UtilSpec.hs index f87f56a9..fbc39e8d 100644 --- a/test/Bitcoin/UtilSpec.hs +++ b/test/Bitcoin/UtilSpec.hs @@ -1,16 +1,34 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} + module Bitcoin.UtilSpec ( spec, customCerealID, readTestFile, + SerialBox (..), + ReadBox (..), + JsonBox (..), + NetBox (..), + testIdentity, + testJson, + testRead, + testSerial, + testNetJson, ) where +import Bitcoin (Network) import Bitcoin.Util import Bitcoin.Util.Arbitrary +import Control.Monad (forM_, (<=<)) import Data.Aeson (FromJSON, ToJSON) import qualified Data.Aeson as A -import Data.Aeson.Encoding (encodingToLazyByteString) -import Data.Aeson.Types (Parser, parseMaybe) +import Data.Aeson.Encoding +import Data.Aeson.Types 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 Data.Foldable (toList) import Data.List (permutations) @@ -18,6 +36,7 @@ import Data.Map.Strict (singleton) import Data.Maybe import qualified Data.Sequence as Seq import Data.Serialize as S +import Data.Typeable import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck @@ -88,3 +107,125 @@ readTestFile fp = A.eitherDecodeFileStrict ("data/" <> fp) >>= either (error . message) return where message aesonErr = "Could not read test file " <> fp <> ": " <> aesonErr + + +-- Helpers for creating Serial and JSON Identity tests + +data SerialBox + = forall a. + (Show a, Eq a, Typeable a, Serial a) => + SerialBox (Gen a) + + +data ReadBox + = forall a. + (Read a, Show a, Eq a, Typeable a) => + ReadBox (Gen a) + + +data JsonBox + = forall a. + (Show a, Eq a, Typeable a, ToJSON a, FromJSON a) => + JsonBox (Gen a) + + +data NetBox + = forall a. + (Show a, Eq a, Typeable a) => + NetBox + ( Network -> a -> Value + , Network -> a -> Encoding + , Network -> Value -> Parser a + , Gen (Network, a) + ) + + +testIdentity :: [SerialBox] -> [ReadBox] -> [JsonBox] -> [NetBox] -> Spec +testIdentity serialVals readVals jsonVals netVals = do + describe "Binary Encoding" $ + forM_ serialVals $ + \(SerialBox g) -> testSerial g + describe "Read/Show Encoding" $ + forM_ readVals $ + \(ReadBox g) -> testRead g + describe "Data.Aeson Encoding" $ + forM_ jsonVals $ + \(JsonBox g) -> testJson g + describe "Data.Aeson Encoding with Network" $ + forM_ netVals $ + \(NetBox (j, e, p, g)) -> testNetJson j e p g + + +-- | Generate Data.Aeson identity tests +testJson :: + (Eq a, Show a, Typeable a, ToJSON a, FromJSON a) => Gen a -> Spec +testJson gen = do + prop ("Data.Aeson toJSON/fromJSON identity for " <> name) $ + forAll gen (`shouldSatisfy` jsonID) + prop ("Data.Aeson toEncoding/fromJSON identity for " <> name) $ + forAll gen (`shouldSatisfy` encodingID) + where + name = show $ typeRep $ proxy gen + proxy :: Gen a -> Proxy a + proxy = const Proxy + jsonID x = (fromJSON . toJSON) (toMap x) == Data.Aeson.Types.Success (toMap x) + encodingID x = + (A.decode . encodingToLazyByteString . toEncoding) (toMap x) + == Just (toMap x) + + +-- | Generate Data.Aeson identity tests for type that need the @Network@ +testNetJson :: + (Eq a, Show a, Typeable a) => + (Network -> a -> Value) -> + (Network -> a -> Encoding) -> + (Network -> Value -> Parser a) -> + Gen (Network, a) -> + Spec +testNetJson j e p g = do + prop ("Data.Aeson toJSON/fromJSON identity (with network) for " <> name) $ + forAll g $ + \(net, x) -> dec net (encVal net x) `shouldBe` Just x + prop ("Data.Aeson toEncoding/fromJSON identity (with network) for " <> name) $ + forAll g $ + \(net, x) -> dec net (encEnc net x) `shouldBe` Just x + where + encVal net = A.encode . toMap . j net + encEnc net = encodingToLazyByteString . toMapE . e net + dec net = parseMaybe (p net) . fromMap <=< A.decode + name = show $ typeRep $ proxy j + proxy :: (Network -> a -> Value) -> Proxy a + proxy = const Proxy + + +-- | Generate binary identity tests +testSerial :: + (Eq a, Show a, Typeable a, Serial a) => Gen a -> Spec +testSerial gen = + prop ("Binary encoding/decoding identity for " <> name) $ + forAll gen $ \x -> do + (runGetL deserialize . runPutL . serialize) x `shouldBe` x + (runGetL deserialize . fromStrict . runPutS . serialize) x `shouldBe` x + (runGetS deserialize . runPutS . serialize) x `shouldBe` Right x + (runGetS deserialize . toStrict . runPutL . serialize) x `shouldBe` Right x + where + name = show $ typeRep $ proxy gen + proxy :: Gen a -> Proxy a + proxy = const Proxy + + +-- | Generate Read/Show identity tests +testRead :: + (Eq a, Read a, Show a, Typeable a) => Gen a -> Spec +testRead gen = + prop ("read/show identity for " <> name) $ + forAll gen $ + \x -> (read . show) x `shouldBe` x + where + name = show $ typeRep $ proxy gen + proxy :: Gen a -> Proxy a + proxy = const Proxy + + +toMapE :: A.Encoding -> A.Encoding +toMapE = A.pairs . pair "object" From 0ab2de0f395759bc201f032f706c4a10334068d2 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Sun, 9 Oct 2022 18:15:46 -0600 Subject: [PATCH 2/5] change to stack cradle --- hie.yaml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/hie.yaml b/hie.yaml index 470c57cb..dc17d2a2 100644 --- a/hie.yaml +++ b/hie.yaml @@ -1,7 +1,7 @@ cradle: - cabal: - - path: "src" - component: "lib:bitcoin" + stack: + - path: "./src" + component: "bitcoin:lib" - - path: "test" + - path: "./test" component: "bitcoin:test:spec" From 45d0fffb7cb69ad65098394a284e0c01ab58efab Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Sun, 9 Oct 2022 18:16:46 -0600 Subject: [PATCH 3/5] suppress orphans warning in orphan module --- test/Bitcoin/Orphans.hs | 35 ++++++++++++++++++----------------- 1 file changed, 18 insertions(+), 17 deletions(-) diff --git a/test/Bitcoin/Orphans.hs b/test/Bitcoin/Orphans.hs index 5a06528b..42f814c4 100644 --- a/test/Bitcoin/Orphans.hs +++ b/test/Bitcoin/Orphans.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Bitcoin.Orphans where @@ -64,16 +65,16 @@ instance FromJSON BlockHeader where withObject "BlockHeader" $ \o -> BlockHeader <$> o - .: "version" + .: "version" <*> o - .: "prevblock" + .: "prevblock" <*> (f =<< o .: "merkleroot") <*> o - .: "timestamp" + .: "timestamp" <*> o - .: "bits" + .: "bits" <*> o - .: "nonce" + .: "nonce" where f = maybe mzero return . (eitherToMaybe . runGetS deserialize <=< decodeHex) @@ -109,10 +110,10 @@ instance FromJSON TxIn where withObject "TxIn" $ \o -> TxIn <$> o - .: "prevoutput" + .: "prevoutput" <*> (maybe mzero return . decodeHex =<< o .: "inputscript") <*> o - .: "sequence" + .: "sequence" instance ToJSON TxIn where @@ -138,7 +139,7 @@ instance FromJSON TxOut where withObject "TxOut" $ \o -> TxOut <$> o - .: "value" + .: "value" <*> (maybe mzero return . decodeHex =<< o .: "outputscript") @@ -153,14 +154,14 @@ instance FromJSON Tx where parseJSON = withObject "Tx" $ \o -> Tx <$> o - .: "version" + .: "version" <*> o - .: "inputs" + .: "inputs" <*> o - .: "outputs" + .: "outputs" <*> (mapM (mapM f) =<< o .: "witnessdata") <*> o - .: "locktime" + .: "locktime" where f = maybe mzero return . decodeHex @@ -304,15 +305,15 @@ instance FromJSON SigInput where withObject "SigInput" $ \o -> SigInput <$> o - .: "pkscript" + .: "pkscript" <*> o - .: "value" + .: "value" <*> o - .: "outpoint" + .: "outpoint" <*> o - .: "sighash" + .: "sighash" <*> o - .:? "redeem" + .:? "redeem" -- | Hex encoding From de7d4d52e7d0962846dd47bdcd13aa91e1e3af77 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Sun, 9 Oct 2022 18:17:36 -0600 Subject: [PATCH 4/5] except --- src/Bitcoin/Util.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Bitcoin/Util.hs b/src/Bitcoin/Util.hs index 2f6d95a3..11845d26 100644 --- a/src/Bitcoin/Util.hs +++ b/src/Bitcoin/Util.hs @@ -53,7 +53,7 @@ module Bitcoin.Util ( ) where import Control.Monad -import Control.Monad.Trans.Except (ExceptT (..)) +import Control.Monad.Trans.Except (ExceptT (..), except) import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -149,7 +149,7 @@ maybeToEither err = maybe (Left err) Right -- | Lift a 'Maybe' computation into the 'ExceptT' monad. liftMaybe :: Monad m => b -> Maybe a -> ExceptT b m a -liftMaybe err = ExceptT . pure . maybeToEither err +liftMaybe err = except . maybeToEither err -- Various helpers From 2c58cab65b69888bb5d3ada7c48509d609bb5b92 Mon Sep 17 00:00:00 2001 From: Keagan McClelland Date: Sun, 9 Oct 2022 18:45:27 -0600 Subject: [PATCH 5/5] fourmolu --- test/Bitcoin/Orphans.hs | 34 +++++++++++++++++----------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/test/Bitcoin/Orphans.hs b/test/Bitcoin/Orphans.hs index 42f814c4..422072d2 100644 --- a/test/Bitcoin/Orphans.hs +++ b/test/Bitcoin/Orphans.hs @@ -65,16 +65,16 @@ instance FromJSON BlockHeader where withObject "BlockHeader" $ \o -> BlockHeader <$> o - .: "version" + .: "version" <*> o - .: "prevblock" + .: "prevblock" <*> (f =<< o .: "merkleroot") <*> o - .: "timestamp" + .: "timestamp" <*> o - .: "bits" + .: "bits" <*> o - .: "nonce" + .: "nonce" where f = maybe mzero return . (eitherToMaybe . runGetS deserialize <=< decodeHex) @@ -110,10 +110,10 @@ instance FromJSON TxIn where withObject "TxIn" $ \o -> TxIn <$> o - .: "prevoutput" + .: "prevoutput" <*> (maybe mzero return . decodeHex =<< o .: "inputscript") <*> o - .: "sequence" + .: "sequence" instance ToJSON TxIn where @@ -139,7 +139,7 @@ instance FromJSON TxOut where withObject "TxOut" $ \o -> TxOut <$> o - .: "value" + .: "value" <*> (maybe mzero return . decodeHex =<< o .: "outputscript") @@ -154,14 +154,14 @@ instance FromJSON Tx where parseJSON = withObject "Tx" $ \o -> Tx <$> o - .: "version" + .: "version" <*> o - .: "inputs" + .: "inputs" <*> o - .: "outputs" + .: "outputs" <*> (mapM (mapM f) =<< o .: "witnessdata") <*> o - .: "locktime" + .: "locktime" where f = maybe mzero return . decodeHex @@ -305,15 +305,15 @@ instance FromJSON SigInput where withObject "SigInput" $ \o -> SigInput <$> o - .: "pkscript" + .: "pkscript" <*> o - .: "value" + .: "value" <*> o - .: "outpoint" + .: "outpoint" <*> o - .: "sighash" + .: "sighash" <*> o - .:? "redeem" + .:? "redeem" -- | Hex encoding