mirror of
https://github.com/haskoin/haskoin-core.git
synced 2024-09-11 10:05:34 +03:00
Use the bytes library for serialization
This commit is contained in:
parent
323433e680
commit
1196c5a3ef
@ -4,6 +4,11 @@ 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.20.0
|
||||
### Chaged
|
||||
- Use bytes instead of binary or cereal.
|
||||
|
||||
## 0.19.0
|
||||
### Added
|
||||
- Hashable instances for extended keys.
|
||||
|
@ -1,13 +1,13 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.34.2.
|
||||
-- This file has been generated from package.yaml by hpack version 0.33.0.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 90de304467308666144472c303ad361258687f7e36e27e916ba836799ea6833c
|
||||
-- hash: f90b7b9353df059b5744c2454f8f514133d3e989a66c8137a87030db88a73a2a
|
||||
|
||||
name: haskoin-core
|
||||
version: 0.19.0
|
||||
version: 0.20.0
|
||||
synopsis: Bitcoin & Bitcoin Cash library for Haskell
|
||||
description: Please see the README on GitHub at <https://github.com/haskoin/haskoin-core#readme>
|
||||
category: Bitcoin, Finance, Network
|
||||
@ -94,9 +94,11 @@ library
|
||||
, aeson >=1.4.6.0
|
||||
, array >=0.5.4.0
|
||||
, base >=4.9 && <5
|
||||
, base16-bytestring >=0.1.1.6
|
||||
, base16 >=0.3.0.1
|
||||
, binary >=0.8.8
|
||||
, bytes >=0.17
|
||||
, bytestring >=0.10.10.0
|
||||
, cereal >=0.5.8.1
|
||||
, cereal >=0.5.8
|
||||
, conduit >=1.3.1.2
|
||||
, containers >=0.6.2.1
|
||||
, cryptonite >=0.26
|
||||
@ -147,9 +149,11 @@ test-suite spec
|
||||
, aeson >=1.4.6.0
|
||||
, array >=0.5.4.0
|
||||
, base >=4.9 && <5
|
||||
, base16-bytestring >=0.1.1.6
|
||||
, base16 >=0.3.0.1
|
||||
, binary >=0.8.8
|
||||
, bytes >=0.17
|
||||
, bytestring >=0.10.10.0
|
||||
, cereal >=0.5.8.1
|
||||
, cereal >=0.5.8
|
||||
, conduit >=1.3.1.2
|
||||
, containers >=0.6.2.1
|
||||
, cryptonite >=0.26
|
||||
|
@ -1,5 +1,5 @@
|
||||
name: haskoin-core
|
||||
version: 0.19.0
|
||||
version: 0.20.0
|
||||
synopsis: Bitcoin & Bitcoin Cash library for Haskell
|
||||
description: Please see the README on GitHub at <https://github.com/haskoin/haskoin-core#readme>
|
||||
category: Bitcoin, Finance, Network
|
||||
@ -21,9 +21,11 @@ dependencies:
|
||||
- aeson >= 1.4.6.0
|
||||
- array >= 0.5.4.0
|
||||
- base >=4.9 && <5
|
||||
- base16-bytestring >= 0.1.1.6
|
||||
- base16 >= 0.3.0.1
|
||||
- binary >= 0.8.8
|
||||
- bytes >= 0.17
|
||||
- bytestring >= 0.10.10.0
|
||||
- cereal >= 0.5.8.1
|
||||
- cereal >= 0.5.8
|
||||
- conduit >= 1.3.1.2
|
||||
- containers >= 0.6.2.1
|
||||
- cryptonite >= 0.26
|
||||
|
@ -58,12 +58,17 @@ import Control.Monad
|
||||
import Data.Aeson as A
|
||||
import Data.Aeson.Encoding as A
|
||||
import Data.Aeson.Types
|
||||
import Data.Binary (Binary (..))
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as B
|
||||
import Data.Bytes.Get
|
||||
import Data.Bytes.Put
|
||||
import Data.Bytes.Serial
|
||||
import Data.Hashable
|
||||
import Data.Maybe
|
||||
import Data.Serialize as S
|
||||
import Data.Serialize (Serialize (..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Word (Word8)
|
||||
import GHC.Generics (Generic)
|
||||
import Haskoin.Address.Base58
|
||||
@ -102,7 +107,47 @@ data Address
|
||||
{ getAddrVersion :: !Word8
|
||||
, getAddrData :: !ByteString
|
||||
}
|
||||
deriving (Eq, Ord, Generic, Show, Read, Serialize, Hashable, NFData)
|
||||
deriving
|
||||
(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
|
||||
0x04 -> WitnessAddress <$> getWord8 <*>
|
||||
(getByteString . fromIntegral =<< getWord64be)
|
||||
b -> fail . T.unpack $
|
||||
"Could not decode address type byte: " <>
|
||||
encodeHex (B.singleton b)
|
||||
|
||||
instance Serialize Address where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Binary Address where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
-- | 'Address' pays to a public key hash.
|
||||
isPubKeyAddress :: Address -> Bool
|
||||
@ -148,19 +193,19 @@ addrFromJSON net =
|
||||
addrToText :: Network -> Address -> Maybe Text
|
||||
addrToText net a@PubKeyAddress {getAddrHash160 = h}
|
||||
| isNothing (getCashAddrPrefix net) =
|
||||
Just . encodeBase58Check . runPut $ base58put net a
|
||||
| otherwise = cashAddrEncode net 0 (S.encode h)
|
||||
Just . encodeBase58Check . runPutS $ base58put net a
|
||||
| otherwise = cashAddrEncode net 0 (runPutS $ serialize h)
|
||||
addrToText net a@ScriptAddress {getAddrHash160 = h}
|
||||
| isNothing (getCashAddrPrefix net) =
|
||||
Just . encodeBase58Check . runPut $ base58put net a
|
||||
Just . encodeBase58Check . runPutS $ base58put net a
|
||||
| otherwise =
|
||||
cashAddrEncode net 1 (S.encode h)
|
||||
cashAddrEncode net 1 (runPutS $ serialize h)
|
||||
addrToText net WitnessPubKeyAddress {getAddrHash160 = h} = do
|
||||
hrp <- getBech32Prefix net
|
||||
segwitEncode hrp 0 (B.unpack (S.encode h))
|
||||
segwitEncode hrp 0 (B.unpack (runPutS $ serialize h))
|
||||
addrToText net WitnessScriptAddress {getAddrHash256 = h} = do
|
||||
hrp <- getBech32Prefix net
|
||||
segwitEncode hrp 0 (B.unpack (S.encode h))
|
||||
segwitEncode hrp 0 (B.unpack (runPutS $ serialize h))
|
||||
addrToText net WitnessAddress {getAddrVersion = v, getAddrData = d} = do
|
||||
hrp <- getBech32Prefix net
|
||||
segwitEncode hrp v (B.unpack d)
|
||||
@ -174,8 +219,8 @@ cashToAddr :: Network -> Text -> Maybe Address
|
||||
cashToAddr net txt = do
|
||||
(ver, bs) <- cashAddrDecode net txt
|
||||
case ver of
|
||||
0 -> PubKeyAddress <$> eitherToMaybe (S.decode bs)
|
||||
1 -> ScriptAddress <$> eitherToMaybe (S.decode bs)
|
||||
0 -> PubKeyAddress <$> eitherToMaybe (runGetS deserialize bs)
|
||||
1 -> ScriptAddress <$> eitherToMaybe (runGetS deserialize bs)
|
||||
_ -> Nothing
|
||||
|
||||
bech32ToAddr :: Network -> Text -> Maybe Address
|
||||
@ -184,19 +229,19 @@ bech32ToAddr net txt = do
|
||||
(ver, bs) <- second B.pack <$> segwitDecode hrp txt
|
||||
case ver of
|
||||
0 -> case B.length bs of
|
||||
20 -> WitnessPubKeyAddress <$> eitherToMaybe (S.decode bs)
|
||||
32 -> WitnessScriptAddress <$> eitherToMaybe (S.decode bs)
|
||||
20 -> WitnessPubKeyAddress <$> eitherToMaybe (runGetS deserialize bs)
|
||||
32 -> WitnessScriptAddress <$> eitherToMaybe (runGetS deserialize bs)
|
||||
_ -> Nothing
|
||||
_ -> Just $ WitnessAddress ver bs
|
||||
|
||||
base58ToAddr :: Network -> Text -> Maybe Address
|
||||
base58ToAddr net txt =
|
||||
eitherToMaybe . runGet (base58get net) =<< decodeBase58Check txt
|
||||
eitherToMaybe . runGetS (base58get net) =<< decodeBase58Check txt
|
||||
|
||||
base58get :: Network -> Get Address
|
||||
base58get :: MonadGet m => Network -> m Address
|
||||
base58get net = do
|
||||
pfx <- getWord8
|
||||
addr <- S.get
|
||||
addr <- deserialize
|
||||
f pfx addr
|
||||
where
|
||||
f x a
|
||||
@ -204,18 +249,18 @@ base58get net = do
|
||||
| x == getScriptPrefix net = return $ ScriptAddress a
|
||||
| otherwise = fail "Does not recognize address prefix"
|
||||
|
||||
base58put :: Network -> Putter Address
|
||||
base58put :: MonadPut m => Network -> Address -> m ()
|
||||
base58put net (PubKeyAddress h) = do
|
||||
putWord8 (getAddrPrefix net)
|
||||
put h
|
||||
serialize h
|
||||
base58put net (ScriptAddress h) = do
|
||||
putWord8 (getScriptPrefix net)
|
||||
put h
|
||||
serialize h
|
||||
base58put _ _ = error "Cannot serialize this address as Base58"
|
||||
|
||||
-- | Obtain a standard pay-to-public-key-hash address from a public key.
|
||||
pubKeyAddr :: PubKeyI -> Address
|
||||
pubKeyAddr = PubKeyAddress . addressHash . S.encode
|
||||
pubKeyAddr = PubKeyAddress . addressHash . runPutS . serialize
|
||||
|
||||
-- | Obtain a standard pay-to-public-key-hash (P2PKH) address from a 'Hash160'.
|
||||
p2pkhAddr :: Hash160 -> Address
|
||||
@ -224,13 +269,18 @@ p2pkhAddr = PubKeyAddress
|
||||
-- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a
|
||||
-- public key.
|
||||
pubKeyWitnessAddr :: PubKeyI -> Address
|
||||
pubKeyWitnessAddr = WitnessPubKeyAddress . addressHash . S.encode
|
||||
pubKeyWitnessAddr = WitnessPubKeyAddress . addressHash . runPutS . serialize
|
||||
|
||||
-- | Obtain a backwards-compatible SegWit P2SH-P2WPKH address from a public key.
|
||||
pubKeyCompatWitnessAddr :: PubKeyI -> Address
|
||||
pubKeyCompatWitnessAddr =
|
||||
p2shAddr .
|
||||
addressHash . encodeOutputBS . PayWitnessPKHash . addressHash . S.encode
|
||||
addressHash .
|
||||
encodeOutputBS .
|
||||
PayWitnessPKHash .
|
||||
addressHash .
|
||||
runPutS .
|
||||
serialize
|
||||
|
||||
-- | Obtain a SegWit pay-to-witness-public-key-hash (P2WPKH) address from a
|
||||
-- 'Hash160'.
|
||||
@ -264,11 +314,11 @@ payToNestedScriptAddress =
|
||||
addressToOutput :: Address -> ScriptOutput
|
||||
addressToOutput =
|
||||
\case
|
||||
PubKeyAddress h -> PayPKHash h
|
||||
ScriptAddress h -> PayScriptHash h
|
||||
PubKeyAddress h -> PayPKHash h
|
||||
ScriptAddress h -> PayScriptHash h
|
||||
WitnessPubKeyAddress h -> PayWitnessPKHash h
|
||||
WitnessScriptAddress h -> PayWitnessScriptHash h
|
||||
WitnessAddress v d -> PayWitness v d
|
||||
WitnessAddress v d -> PayWitness v d
|
||||
|
||||
-- | Get output script AST for an 'Address'.
|
||||
addressToScript :: Address -> Script
|
||||
@ -276,7 +326,7 @@ addressToScript = encodeOutput . addressToOutput
|
||||
|
||||
-- | Encode address as output script in 'ByteString' form.
|
||||
addressToScriptBS :: Address -> ByteString
|
||||
addressToScriptBS = S.encode . addressToScript
|
||||
addressToScriptBS = runPutS . serialize . addressToScript
|
||||
|
||||
-- | Decode an output script into an 'Address' if it has such representation.
|
||||
scriptToAddress :: Script -> Either String Address
|
||||
@ -292,18 +342,18 @@ scriptToAddressBS =
|
||||
outputAddress :: ScriptOutput -> Maybe Address
|
||||
outputAddress =
|
||||
\case
|
||||
PayPKHash h -> Just $ PubKeyAddress h
|
||||
PayScriptHash h -> Just $ ScriptAddress h
|
||||
PayPK k -> Just $ pubKeyAddr k
|
||||
PayWitnessPKHash h -> Just $ WitnessPubKeyAddress h
|
||||
PayPKHash h -> Just $ PubKeyAddress h
|
||||
PayScriptHash h -> Just $ ScriptAddress h
|
||||
PayPK k -> Just $ pubKeyAddr k
|
||||
PayWitnessPKHash h -> Just $ WitnessPubKeyAddress h
|
||||
PayWitnessScriptHash h -> Just $ WitnessScriptAddress h
|
||||
PayWitness v d -> Just $ WitnessAddress v d
|
||||
_ -> Nothing
|
||||
PayWitness v d -> Just $ WitnessAddress v d
|
||||
_ -> Nothing
|
||||
|
||||
-- | Infer the 'Address' of a 'ScriptInput'.
|
||||
inputAddress :: ScriptInput -> Maybe Address
|
||||
inputAddress =
|
||||
\case
|
||||
(RegularInput (SpendPKHash _ key)) -> Just $ pubKeyAddr key
|
||||
(ScriptHashInput _ rdm) -> Just $ payToScriptAddress rdm
|
||||
_ -> Nothing
|
||||
(ScriptHashInput _ rdm) -> Just $ payToScriptAddress rdm
|
||||
_ -> Nothing
|
||||
|
@ -23,8 +23,10 @@ import Control.Monad
|
||||
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.Maybe (fromMaybe, isJust, listToMaybe)
|
||||
import Data.Serialize as S
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
@ -90,7 +92,7 @@ decodeBase58 t =
|
||||
-- the checksum as 'Base58'.
|
||||
encodeBase58Check :: ByteString -> Base58
|
||||
encodeBase58Check bs =
|
||||
encodeBase58 $ BS.append bs $ encode $ checkSum32 bs
|
||||
encodeBase58 $ BS.append bs $ runPutS $ serialize $ checkSum32 bs
|
||||
|
||||
-- | Decode a 'Base58'-encoded string that contains a checksum. This function
|
||||
-- returns 'Nothing' if the input string contains invalid 'Base58' characters or
|
||||
@ -99,5 +101,5 @@ decodeBase58Check :: Base58 -> Maybe ByteString
|
||||
decodeBase58Check bs = do
|
||||
rs <- decodeBase58 bs
|
||||
let (res, chk) = BS.splitAt (BS.length rs - 4) rs
|
||||
guard $ chk == encode (checkSum32 res)
|
||||
guard $ chk == runPutS (serialize (checkSum32 res))
|
||||
return res
|
||||
|
@ -36,15 +36,19 @@ import Data.Aeson (FromJSON (..), ToJSON (..),
|
||||
Value (..), object, toJSON,
|
||||
withObject, withText, (.:), (.=))
|
||||
import Data.Aeson.Encoding (pairs, unsafeToEncoding)
|
||||
import Data.Binary (Binary (..))
|
||||
import Data.Bits (shiftL, shiftR, (.&.), (.|.))
|
||||
import qualified Data.ByteString as B
|
||||
import Data.ByteString.Builder (char7)
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Bytes.Get (MonadGet, getWord32le, runGetL,
|
||||
runGetS)
|
||||
import Data.Bytes.Put (MonadPut, putWord32le, runPutL,
|
||||
runPutS)
|
||||
import Data.Bytes.Serial (Serial (..))
|
||||
import Data.Hashable (Hashable)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Serialize (Serialize, decode, encode, get,
|
||||
put)
|
||||
import Data.Serialize.Get (getWord32le)
|
||||
import Data.Serialize.Put (Put, putWord32le)
|
||||
import Data.Serialize (Serialize (..))
|
||||
import Data.String (IsString, fromString)
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Text (Text)
|
||||
@ -69,16 +73,24 @@ data Block = Block
|
||||
}
|
||||
deriving (Eq, Show, Read, Generic, Hashable, NFData)
|
||||
|
||||
instance Serialize Block where
|
||||
get = do
|
||||
header <- get
|
||||
(VarInt c) <- get
|
||||
txs <- replicateM (fromIntegral c) get
|
||||
instance Serial Block where
|
||||
deserialize = do
|
||||
header <- deserialize
|
||||
(VarInt c) <- deserialize
|
||||
txs <- replicateM (fromIntegral c) deserialize
|
||||
return $ Block header txs
|
||||
put (Block h txs) = do
|
||||
put h
|
||||
serialize (Block h txs) = do
|
||||
serialize h
|
||||
putVarInt $ length txs
|
||||
forM_ txs put
|
||||
forM_ txs serialize
|
||||
|
||||
instance Serialize Block where
|
||||
get = deserialize
|
||||
put = serialize
|
||||
|
||||
instance Binary Block where
|
||||
get = deserialize
|
||||
put = serialize
|
||||
|
||||
instance ToJSON Block where
|
||||
toJSON (Block h t) = object ["header" .= h, "transactions" .= t]
|
||||
@ -92,7 +104,15 @@ instance FromJSON Block where
|
||||
-- | Block header hash. To be serialized reversed for display purposes.
|
||||
newtype BlockHash = BlockHash
|
||||
{ getBlockHash :: Hash256
|
||||
} deriving (Eq, Ord, Generic, Hashable, Serialize, NFData)
|
||||
} deriving (Eq, Ord, Generic, Hashable, Serial, NFData)
|
||||
|
||||
instance Serialize BlockHash where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Binary BlockHash where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Show BlockHash where
|
||||
showsPrec _ = shows . blockHashToHex
|
||||
@ -115,19 +135,21 @@ instance ToJSON BlockHash where
|
||||
toJSON = String . blockHashToHex
|
||||
toEncoding h =
|
||||
unsafeToEncoding $
|
||||
char7 '"' <> hexBuilder (B.reverse (encode h)) <> char7 '"'
|
||||
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
|
||||
blockHashToHex (BlockHash h) = encodeHex (B.reverse (encode h))
|
||||
blockHashToHex (BlockHash h) = encodeHex (B.reverse (runPutS (serialize h)))
|
||||
|
||||
-- | Convert a human-readable hex block hash into a 'BlockHash'. Bytes are
|
||||
-- reversed as normal.
|
||||
hexToBlockHash :: Text -> Maybe BlockHash
|
||||
hexToBlockHash hex = do
|
||||
bs <- B.reverse <$> decodeHex hex
|
||||
h <- eitherToMaybe (decode bs)
|
||||
h <- eitherToMaybe (runGetS deserialize bs)
|
||||
return $ BlockHash h
|
||||
|
||||
-- | Data type recording information of a 'Block'. The hash of a block is
|
||||
@ -157,7 +179,7 @@ instance ToJSON BlockHeader where
|
||||
object
|
||||
[ "version" .= v
|
||||
, "prevblock" .= p
|
||||
, "merkleroot" .= encodeHex (encode m)
|
||||
, "merkleroot" .= encodeHex (runPutS (serialize m))
|
||||
, "timestamp" .= t
|
||||
, "bits" .= b
|
||||
, "nonce" .= n
|
||||
@ -166,7 +188,7 @@ instance ToJSON BlockHeader where
|
||||
pairs
|
||||
( "version" .= v
|
||||
<> "prevblock" .= p
|
||||
<> "merkleroot" .= encodeHex (encode m)
|
||||
<> "merkleroot" .= encodeHex (runPutS (serialize m))
|
||||
<> "timestamp" .= t
|
||||
<> "bits" .= b
|
||||
<> "nonce" .= n
|
||||
@ -182,13 +204,17 @@ instance FromJSON BlockHeader where
|
||||
<*> o .: "bits"
|
||||
<*> o .: "nonce"
|
||||
where
|
||||
f = maybe mzero return . (eitherToMaybe . decode =<<) . decodeHex
|
||||
f = maybe
|
||||
mzero
|
||||
return .
|
||||
(eitherToMaybe . runGetS deserialize =<<) .
|
||||
decodeHex
|
||||
|
||||
instance Serialize BlockHeader where
|
||||
get = do
|
||||
instance Serial BlockHeader where
|
||||
deserialize = do
|
||||
v <- getWord32le
|
||||
p <- get
|
||||
m <- get
|
||||
p <- deserialize
|
||||
m <- deserialize
|
||||
t <- getWord32le
|
||||
b <- getWord32le
|
||||
n <- getWord32le
|
||||
@ -201,17 +227,25 @@ instance Serialize BlockHeader where
|
||||
, blockBits = b
|
||||
, bhNonce = n
|
||||
}
|
||||
put (BlockHeader v p m bt bb n) = do
|
||||
serialize (BlockHeader v p m bt bb n) = do
|
||||
putWord32le v
|
||||
put p
|
||||
put m
|
||||
serialize p
|
||||
serialize 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 . encode
|
||||
headerHash = BlockHash . doubleSHA256 . runPutS . serialize
|
||||
|
||||
-- | A block locator is a set of block headers, denser towards the best block
|
||||
-- and sparser towards the genesis block. It starts at the highest block known.
|
||||
@ -236,18 +270,26 @@ data GetBlocks = GetBlocks
|
||||
}
|
||||
deriving (Eq, Show, Read, Generic, NFData)
|
||||
|
||||
instance Serialize GetBlocks where
|
||||
get = GetBlocks <$> getWord32le <*> (repList =<< get) <*> get
|
||||
instance Serial GetBlocks where
|
||||
deserialize =
|
||||
GetBlocks
|
||||
<$> getWord32le
|
||||
<*> (repList =<< deserialize)
|
||||
<*> deserialize
|
||||
where
|
||||
repList (VarInt c) = replicateM (fromIntegral c) get
|
||||
put (GetBlocks v xs h) = putGetBlockMsg v xs h
|
||||
repList (VarInt c) = replicateM (fromIntegral c) deserialize
|
||||
serialize (GetBlocks v xs h) = putGetBlockMsg v xs h
|
||||
|
||||
putGetBlockMsg :: Word32 -> BlockLocator -> BlockHash -> Put
|
||||
instance Serialize GetBlocks where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
putGetBlockMsg :: MonadPut m => Word32 -> BlockLocator -> BlockHash -> m ()
|
||||
putGetBlockMsg v xs h = do
|
||||
putWord32le v
|
||||
putVarInt $ length xs
|
||||
forM_ xs put
|
||||
put h
|
||||
forM_ xs serialize
|
||||
serialize h
|
||||
|
||||
-- | Similar to the 'GetBlocks' message type but for retrieving block headers
|
||||
-- only. The response to a 'GetHeaders' request is a 'Headers' message
|
||||
@ -263,11 +305,23 @@ data GetHeaders = GetHeaders
|
||||
}
|
||||
deriving (Eq, Show, Read, Generic, NFData)
|
||||
|
||||
instance Serialize GetHeaders where
|
||||
get = GetHeaders <$> getWord32le <*> (repList =<< get) <*> get
|
||||
instance Serial GetHeaders where
|
||||
deserialize =
|
||||
GetHeaders
|
||||
<$> getWord32le
|
||||
<*> (repList =<< deserialize)
|
||||
<*> deserialize
|
||||
where
|
||||
repList (VarInt c) = replicateM (fromIntegral c) get
|
||||
put (GetHeaders v xs h) = putGetBlockMsg v xs h
|
||||
repList (VarInt c) = replicateM (fromIntegral c) deserialize
|
||||
serialize (GetHeaders v xs h) = putGetBlockMsg v xs h
|
||||
|
||||
instance Serialize GetHeaders where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Binary GetHeaders where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
-- | 'BlockHeader' type with a transaction count as 'VarInt'
|
||||
type BlockHeaderCount = (BlockHeader, VarInt)
|
||||
@ -279,14 +333,22 @@ newtype Headers = Headers
|
||||
headersList :: [BlockHeaderCount]
|
||||
} deriving (Eq, Show, Read, Generic, NFData)
|
||||
|
||||
instance Serialize Headers where
|
||||
get = Headers <$> (repList =<< get)
|
||||
instance Serial Headers where
|
||||
deserialize = Headers <$> (repList =<< deserialize)
|
||||
where
|
||||
repList (VarInt c) = replicateM (fromIntegral c) action
|
||||
action = liftM2 (,) get get
|
||||
put (Headers xs) = do
|
||||
action = liftM2 (,) deserialize deserialize
|
||||
serialize (Headers xs) = do
|
||||
putVarInt $ length xs
|
||||
forM_ xs $ \(a, b) -> put a >> put b
|
||||
forM_ xs $ \(a, b) -> serialize a >> serialize b
|
||||
|
||||
instance Serialize Headers where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Binary Headers where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
-- | Decode the compact number used in the difficulty target of a block.
|
||||
--
|
||||
|
@ -75,20 +75,21 @@ import Control.Monad.Except (ExceptT (..), runExceptT,
|
||||
import Control.Monad.State.Strict as State (StateT, get, gets, lift,
|
||||
modify)
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.Binary (Binary (..))
|
||||
import Data.Bits (shiftL, shiftR, (.&.))
|
||||
import qualified Data.ByteString as B
|
||||
import Data.ByteString.Short (ShortByteString, fromShort,
|
||||
toShort)
|
||||
import Data.Bytes.Get
|
||||
import Data.Bytes.Put
|
||||
import Data.Bytes.Serial
|
||||
import Data.Function (on)
|
||||
import Data.Hashable
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Hashable
|
||||
import Data.List (sort, sortBy)
|
||||
import Data.Maybe (fromMaybe, listToMaybe)
|
||||
import Data.Serialize as S (Serialize (..), decode,
|
||||
encode, get, put)
|
||||
import Data.Serialize.Get as S
|
||||
import Data.Serialize.Put as S
|
||||
import Data.Serialize (Serialize (..))
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.Word (Word32, Word64)
|
||||
import GHC.Generics (Generic)
|
||||
@ -123,25 +124,33 @@ data BlockNode
|
||||
}
|
||||
deriving (Show, Read, Generic, Hashable, NFData)
|
||||
|
||||
instance Serialize BlockNode where
|
||||
get = do
|
||||
nodeHeader <- S.get
|
||||
instance Serial BlockNode where
|
||||
deserialize = do
|
||||
nodeHeader <- deserialize
|
||||
nodeHeight <- getWord32le
|
||||
nodeWork <- S.get
|
||||
nodeWork <- getInteger
|
||||
if nodeHeight == 0
|
||||
then do
|
||||
let nodeSkip = headerHash nodeHeader
|
||||
return BlockNode {..}
|
||||
else do
|
||||
nodeSkip <- S.get
|
||||
nodeSkip <- deserialize
|
||||
return BlockNode {..}
|
||||
put bn = do
|
||||
put $ nodeHeader bn
|
||||
serialize bn = do
|
||||
serialize $ nodeHeader bn
|
||||
putWord32le $ nodeHeight bn
|
||||
put $ nodeWork bn
|
||||
putInteger $ nodeWork bn
|
||||
case nodeHeight bn of
|
||||
0 -> return ()
|
||||
_ -> put $ nodeSkip bn
|
||||
_ -> serialize $ nodeSkip bn
|
||||
|
||||
instance Serialize BlockNode where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Binary BlockNode where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Eq BlockNode where
|
||||
(==) = (==) `on` nodeHeader
|
||||
@ -187,7 +196,7 @@ genesisMap :: Network -> BlockMap
|
||||
genesisMap net =
|
||||
HashMap.singleton
|
||||
(shortBlockHash (headerHash (getGenesisHeader net)))
|
||||
(toShort (encode (genesisNode net)))
|
||||
(toShort (runPutS (serialize (genesisNode net))))
|
||||
|
||||
-- | Add block header to memory block map.
|
||||
addBlockHeaderMemory :: BlockNode -> HeaderMemory -> HeaderMemory
|
||||
@ -199,20 +208,21 @@ addBlockHeaderMemory bn s@HeaderMemory{..} =
|
||||
getBlockHeaderMemory :: BlockHash -> HeaderMemory -> Maybe BlockNode
|
||||
getBlockHeaderMemory bh HeaderMemory {..} = do
|
||||
bs <- shortBlockHash bh `HashMap.lookup` memoryHeaderMap
|
||||
eitherToMaybe . decode $ fromShort bs
|
||||
eitherToMaybe . runGetS deserialize $ fromShort bs
|
||||
|
||||
-- | Calculate short block hash taking eight non-zero bytes from the 16-byte
|
||||
-- hash. This function will take the bytes that are not on the zero-side of the
|
||||
-- hash, making colissions between short block hashes difficult.
|
||||
shortBlockHash :: BlockHash -> ShortBlockHash
|
||||
shortBlockHash = either error id . decode . B.take 8 . encode
|
||||
shortBlockHash =
|
||||
either error id . runGetS deserialize . B.take 8 . runPutS . serialize
|
||||
|
||||
-- | Add a block to memory-based block map.
|
||||
addBlockToMap :: BlockNode -> BlockMap -> BlockMap
|
||||
addBlockToMap node =
|
||||
HashMap.insert
|
||||
(shortBlockHash $ headerHash $ nodeHeader node)
|
||||
(toShort $ encode node)
|
||||
(toShort $ runPutS $ serialize node)
|
||||
|
||||
-- | Get the ancestor of the provided 'BlockNode' at the specified
|
||||
-- 'BlockHeight'.
|
||||
@ -635,7 +645,7 @@ middleBlock :: BlockHeaders m => BlockNode -> BlockNode -> m BlockNode
|
||||
middleBlock a b =
|
||||
getAncestor h b >>= \case
|
||||
Nothing -> error "You fell into a pit full of mud and snakes"
|
||||
Just x -> return x
|
||||
Just x -> return x
|
||||
where
|
||||
h = middleOf (nodeHeight a) (nodeHeight b)
|
||||
|
||||
@ -797,7 +807,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 . encode
|
||||
blockPOW = bsToInteger . B.reverse . runPutS . serialize
|
||||
|
||||
-- | Returns the work represented by this block. Work is defined as the number
|
||||
-- of tries needed to solve a block in the average case with respect to the
|
||||
@ -867,7 +877,7 @@ appendBlocks net seed bh i =
|
||||
bh' = mineBlock net seed bh
|
||||
{ prevBlock = headerHash bh
|
||||
-- Just to make it different in every header
|
||||
, merkleRoot = sha256 $ encode seed
|
||||
, merkleRoot = sha256 $ runPutS $ serialize seed
|
||||
}
|
||||
|
||||
-- | Find the last common block ancestor between provided block headers.
|
||||
|
@ -35,14 +35,16 @@ module Haskoin.Block.Merkle
|
||||
|
||||
import Control.DeepSeq
|
||||
import Control.Monad (forM_, replicateM, when)
|
||||
import Data.Binary (Binary (..))
|
||||
import Data.Bits
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Bytes.Get
|
||||
import Data.Bytes.Put
|
||||
import Data.Bytes.Serial
|
||||
import Data.Either (isRight)
|
||||
import Data.Hashable
|
||||
import Data.Maybe
|
||||
import Data.Serialize (Serialize, encode, get, put)
|
||||
import Data.Serialize.Get (getWord32le, getWord8)
|
||||
import Data.Serialize.Put (putWord32le, putWord8)
|
||||
import Data.Serialize (Serialize (..))
|
||||
import Data.Word (Word32, Word8)
|
||||
import GHC.Generics
|
||||
import Haskoin.Block.Common
|
||||
@ -74,26 +76,33 @@ data MerkleBlock =
|
||||
, mFlags :: !FlagBits
|
||||
} deriving (Eq, Show, Read, Generic, Hashable, NFData)
|
||||
|
||||
instance Serialize MerkleBlock where
|
||||
|
||||
get = do
|
||||
header <- get
|
||||
instance Serial MerkleBlock where
|
||||
deserialize = do
|
||||
header <- deserialize
|
||||
ntx <- getWord32le
|
||||
(VarInt matchLen) <- get
|
||||
hashes <- replicateM (fromIntegral matchLen) get
|
||||
(VarInt flagLen) <- get
|
||||
(VarInt matchLen) <- deserialize
|
||||
hashes <- replicateM (fromIntegral matchLen) deserialize
|
||||
(VarInt flagLen) <- deserialize
|
||||
ws <- replicateM (fromIntegral flagLen) getWord8
|
||||
return $ MerkleBlock header ntx hashes (decodeMerkleFlags ws)
|
||||
|
||||
put (MerkleBlock h ntx hashes flags) = do
|
||||
put h
|
||||
serialize (MerkleBlock h ntx hashes flags) = do
|
||||
serialize h
|
||||
putWord32le ntx
|
||||
putVarInt $ length hashes
|
||||
forM_ hashes put
|
||||
forM_ hashes serialize
|
||||
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
|
||||
|
||||
-- | Unpack Merkle flags into 'FlagBits' structure.
|
||||
decodeMerkleFlags :: [Word8] -> FlagBits
|
||||
decodeMerkleFlags ws =
|
||||
@ -126,7 +135,7 @@ buildMerkleRoot txs = calcHash (calcTreeHeight $ length txs) 0 txs
|
||||
|
||||
-- | Concatenate and compute double SHA256.
|
||||
hash2 :: Hash256 -> Hash256 -> Hash256
|
||||
hash2 a b = doubleSHA256 $ encode a `BS.append` encode b
|
||||
hash2 a b = doubleSHA256 $ runPutS (serialize a) <> runPutS (serialize b)
|
||||
|
||||
-- | Computes the hash of a specific node in a Merkle tree.
|
||||
calcHash :: Int -- ^ height of the node
|
||||
|
@ -28,10 +28,14 @@ module Haskoin.Constants
|
||||
) where
|
||||
|
||||
import Control.DeepSeq
|
||||
import Data.Binary (Binary (..))
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Bytes.Get
|
||||
import Data.Bytes.Put
|
||||
import Data.Bytes.Serial
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Serialize
|
||||
import Data.Serialize (Serialize (..))
|
||||
import Data.String
|
||||
import Data.Text (Text)
|
||||
import Data.Word (Word32, Word64, Word8)
|
||||
@ -120,15 +124,23 @@ data Network = Network
|
||||
, getHalvingInterval :: !Word32
|
||||
} deriving (Eq, Generic, NFData)
|
||||
|
||||
instance Serialize Network where
|
||||
put net =
|
||||
instance Serial Network where
|
||||
serialize net =
|
||||
putWord32be $ getNetworkMagic net
|
||||
get = do
|
||||
deserialize = do
|
||||
magic <- getWord32be
|
||||
case find ((== magic) . getNetworkMagic) allNets of
|
||||
Nothing -> fail $ "Network magic unknown: " <> show magic
|
||||
Just net -> return net
|
||||
|
||||
instance Binary Network where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Serialize Network where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Show Network where
|
||||
show = getNetworkIdent
|
||||
|
||||
|
@ -34,17 +34,19 @@ import Control.DeepSeq
|
||||
import Crypto.Hash (RIPEMD160 (..), SHA1 (..),
|
||||
SHA256 (..), SHA512 (..), hashWith)
|
||||
import Crypto.MAC.HMAC (HMAC, hmac)
|
||||
import Data.Binary (Binary (..))
|
||||
import Data.ByteArray (ByteArrayAccess)
|
||||
import qualified Data.ByteArray as BA
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
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 (..), decode)
|
||||
import qualified Data.Serialize.Get as Get
|
||||
import qualified Data.Serialize.Put as Put
|
||||
import Data.Serialize (Serialize (..))
|
||||
import Data.String (IsString, fromString)
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Word (Word32)
|
||||
@ -55,7 +57,15 @@ import Text.Read as R
|
||||
-- | 'Word32' wrapped for type-safe 32-bit checksums.
|
||||
newtype CheckSum32 = CheckSum32
|
||||
{ getCheckSum32 :: Word32
|
||||
} deriving (Eq, Ord, Serialize, Show, Read, Hashable, Generic, NFData)
|
||||
} deriving (Eq, Ord, Serial, Show, Read, Hashable, Generic, NFData)
|
||||
|
||||
instance Serialize CheckSum32 where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Binary CheckSum32 where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
-- | Type for 512-bit hashes.
|
||||
newtype Hash512 = Hash512 { getHash512 :: ShortByteString }
|
||||
@ -104,9 +114,17 @@ instance IsString Hash512 where
|
||||
where
|
||||
e = error "Could not decode hash from hex string"
|
||||
|
||||
instance Serial Hash512 where
|
||||
deserialize = Hash512 . BSS.toShort <$> Get.getByteString 64
|
||||
serialize = Put.putByteString . BSS.fromShort . getHash512
|
||||
|
||||
instance Serialize Hash512 where
|
||||
get = Hash512 <$> Get.getShortByteString 64
|
||||
put = Put.putShortByteString . getHash512
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Binary Hash512 where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance IsString Hash256 where
|
||||
fromString str =
|
||||
@ -119,9 +137,17 @@ instance IsString Hash256 where
|
||||
where
|
||||
e = error "Could not decode hash from hex string"
|
||||
|
||||
instance Serial Hash256 where
|
||||
deserialize = Hash256 . BSS.toShort <$> Get.getByteString 32
|
||||
serialize = Put.putByteString . BSS.fromShort . getHash256
|
||||
|
||||
instance Serialize Hash256 where
|
||||
get = Hash256 <$> Get.getShortByteString 32
|
||||
put = Put.putShortByteString . getHash256
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Binary Hash256 where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance IsString Hash160 where
|
||||
fromString str =
|
||||
@ -134,9 +160,17 @@ instance IsString Hash160 where
|
||||
where
|
||||
e = error "Could not decode hash from hex string"
|
||||
|
||||
instance Serial Hash160 where
|
||||
deserialize = Hash160 . BSS.toShort <$> Get.getByteString 20
|
||||
serialize = Put.putByteString . BSS.fromShort . getHash160
|
||||
|
||||
instance Serialize Hash160 where
|
||||
get = Hash160 <$> Get.getShortByteString 20
|
||||
put = Put.putShortByteString . getHash160
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Binary Hash160 where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
-- | Calculate SHA512 hash.
|
||||
sha512 :: ByteArrayAccess b => b -> Hash512
|
||||
@ -169,7 +203,7 @@ addressHash =
|
||||
-- | Computes a 32 bit checksum.
|
||||
checkSum32 :: ByteArrayAccess b => b -> CheckSum32
|
||||
checkSum32 = fromRight (error "Could not decode bytes as CheckSum32")
|
||||
. decode
|
||||
. Get.runGetS deserialize
|
||||
. BS.take 4
|
||||
. BA.convert
|
||||
. hashWith SHA256
|
||||
|
@ -23,17 +23,21 @@ module Haskoin.Crypto.Signature
|
||||
|
||||
import Control.Monad (guard, unless, when)
|
||||
import Crypto.Secp256k1
|
||||
import Data.Binary (Binary (..))
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Bytes.Get
|
||||
import Data.Bytes.Put
|
||||
import Data.Bytes.Serial
|
||||
import Data.Maybe (fromMaybe, isNothing)
|
||||
import Data.Serialize as S
|
||||
import Data.Serialize (Serialize (..))
|
||||
import Haskoin.Crypto.Hash
|
||||
import Numeric (showHex)
|
||||
|
||||
-- | Convert 256-bit hash into a 'Msg' for signing or verification.
|
||||
hashToMsg :: Hash256 -> Msg
|
||||
hashToMsg =
|
||||
fromMaybe e . msg . encode
|
||||
fromMaybe e . msg . runPutS . serialize
|
||||
where
|
||||
e = error "Could not convert 32-byte hash to secp256k1 message"
|
||||
|
||||
@ -48,7 +52,7 @@ verifyHashSig h s p = verifySig p norm (hashToMsg h)
|
||||
norm = fromMaybe s (normalizeSig s)
|
||||
|
||||
-- | Deserialize an ECDSA signature as commonly encoded in Bitcoin.
|
||||
getSig :: Get Sig
|
||||
getSig :: MonadGet m => m Sig
|
||||
getSig = do
|
||||
l <-
|
||||
lookAhead $ do
|
||||
@ -67,7 +71,7 @@ getSig = do
|
||||
Nothing -> fail "Invalid signature"
|
||||
|
||||
-- | Serialize an ECDSA signature for Bitcoin use.
|
||||
putSig :: Putter Sig
|
||||
putSig :: MonadPut m => Sig -> m ()
|
||||
putSig s = putByteString $ exportSig s
|
||||
|
||||
-- | Is canonical half order.
|
||||
|
@ -2,6 +2,7 @@
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-|
|
||||
@ -40,14 +41,16 @@ import Crypto.Secp256k1
|
||||
import Data.Aeson (FromJSON, ToJSON (..), Value (String),
|
||||
parseJSON, withText)
|
||||
import Data.Aeson.Encoding (unsafeToEncoding)
|
||||
import Data.Binary (Binary (..))
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.ByteString.Builder (char7)
|
||||
import Data.Bytes.Get
|
||||
import Data.Bytes.Put
|
||||
import Data.Bytes.Serial
|
||||
import Data.Hashable
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Serialize (Serialize, decode, encode, get, put)
|
||||
import Data.Serialize.Get (getByteString)
|
||||
import Data.Serialize.Put (putByteString)
|
||||
import Data.Serialize (Serialize (..))
|
||||
import Data.String (IsString, fromString)
|
||||
import Data.String.Conversions (cs)
|
||||
import GHC.Generics (Generic)
|
||||
@ -64,31 +67,49 @@ data PubKeyI = PubKeyI
|
||||
|
||||
instance IsString PubKeyI where
|
||||
fromString str =
|
||||
fromMaybe e $ eitherToMaybe . decode <=< decodeHex $ cs str
|
||||
fromMaybe e $ eitherToMaybe . runGetS deserialize <=< decodeHex $ cs str
|
||||
where
|
||||
e = error "Could not decode public key"
|
||||
|
||||
instance ToJSON PubKeyI where
|
||||
toJSON = String . encodeHex . encode
|
||||
toEncoding s = unsafeToEncoding $ char7 '"' <> hexBuilder (encode s) <> char7 '"'
|
||||
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 . decode =<<) . decodeHex
|
||||
maybe mzero return . (eitherToMaybe . runGetS deserialize =<<) . decodeHex
|
||||
|
||||
instance Serialize PubKeyI where
|
||||
get = c <|> u
|
||||
instance Serial PubKeyI where
|
||||
deserialize = s >>= \case
|
||||
True -> c
|
||||
False -> u
|
||||
where
|
||||
s = lookAhead $ getWord8 >>= \case
|
||||
0x02 -> return True
|
||||
0x03 -> return True
|
||||
0x04 -> return False
|
||||
_ -> fail "Not a public key"
|
||||
c = do
|
||||
bs <- getByteString 33
|
||||
guard $ BS.head bs `BS.elem` BS.pack [0x02, 0x03]
|
||||
maybe mzero return $ PubKeyI <$> importPubKey bs <*> pure True
|
||||
maybe (fail "Could not decode public key") return $
|
||||
PubKeyI <$> importPubKey bs <*> pure True
|
||||
u = do
|
||||
bs <- getByteString 65
|
||||
guard $ BS.head bs == 0x04
|
||||
maybe mzero return $ PubKeyI <$> importPubKey bs <*> pure False
|
||||
maybe (fail "Could not decode public key") return $
|
||||
PubKeyI <$> importPubKey bs <*> pure False
|
||||
|
||||
put pk = putByteString $ exportPubKey (pubKeyCompressed pk) (pubKeyPoint pk)
|
||||
serialize pk = putByteString $ exportPubKey (pubKeyCompressed pk) (pubKeyPoint pk)
|
||||
|
||||
instance Serialize PubKeyI where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Binary PubKeyI where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
-- | Wrap a public key from secp256k1 library adding information about compression.
|
||||
wrapPubKey :: Bool -> PubKey -> PubKeyI
|
||||
@ -101,7 +122,7 @@ derivePubKeyI (SecKeyI d c) = PubKeyI (derivePubKey d) c
|
||||
|
||||
-- | Tweak a public key.
|
||||
tweakPubKey :: PubKey -> Hash256 -> Maybe PubKey
|
||||
tweakPubKey p h = tweakAddPubKey p =<< tweak (encode h)
|
||||
tweakPubKey p h = tweakAddPubKey p =<< tweak (runPutS (serialize h))
|
||||
|
||||
-- | Elliptic curve private key type with expected public key compression
|
||||
-- information. Compression information is stored in private key WIF formats and
|
||||
@ -118,15 +139,15 @@ wrapSecKey c d = SecKeyI d c
|
||||
|
||||
-- | Tweak a private key.
|
||||
tweakSecKey :: SecKey -> Hash256 -> Maybe SecKey
|
||||
tweakSecKey key h = tweakAddSecKey key =<< tweak (encode h)
|
||||
tweakSecKey key h = tweakAddSecKey key =<< tweak (runPutS (serialize h))
|
||||
|
||||
-- | Decode Casascius mini private keys (22 or 30 characters).
|
||||
fromMiniKey :: ByteString -> Maybe SecKeyI
|
||||
fromMiniKey bs = do
|
||||
guard checkShortKey
|
||||
wrapSecKey False <$> secKey (encode (sha256 bs))
|
||||
wrapSecKey False <$> secKey (runPutS (serialize (sha256 bs)))
|
||||
where
|
||||
checkHash = encode $ sha256 $ bs `BS.append` "?"
|
||||
checkHash = runPutS $ serialize $ sha256 $ bs `BS.append` "?"
|
||||
checkShortKey = BS.length bs `elem` [22, 30] && BS.head checkHash == 0x00
|
||||
|
||||
-- | Decode private key from WIF (wallet import format) string.
|
||||
|
@ -111,18 +111,20 @@ import Data.Aeson as A (FromJSON, ToJSON (..),
|
||||
toJSON, withText)
|
||||
import Data.Aeson.Encoding (Encoding, text)
|
||||
import Data.Aeson.Types (Parser)
|
||||
import Data.Binary (Binary (get, put))
|
||||
import Data.Bits (clearBit, setBit, testBit)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as B
|
||||
import Data.Bytes.Get
|
||||
import Data.Bytes.Put
|
||||
import Data.Bytes.Serial
|
||||
import Data.Either (fromRight)
|
||||
import Data.Hashable
|
||||
import Data.List (foldl')
|
||||
import Data.List.Split (splitOn)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Serialize as S (Serialize, decode, encode, get,
|
||||
put)
|
||||
import Data.Serialize.Get (Get, getWord32be, getWord8, runGet)
|
||||
import Data.Serialize.Put (Putter, putWord32be, putWord8, runPut)
|
||||
import Data.Serialize (Serialize (..))
|
||||
import qualified Data.Serialize as S
|
||||
import Data.String (IsString, fromString)
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Typeable (Typeable)
|
||||
@ -165,20 +167,28 @@ data XPrvKey = XPrvKey
|
||||
, xPrvKey :: !SecKey -- ^ private key of this node
|
||||
} deriving (Generic, Eq, Show, Read, NFData, Hashable)
|
||||
|
||||
instance Serialize XPrvKey where
|
||||
put k = do
|
||||
instance Serial XPrvKey where
|
||||
serialize k = do
|
||||
putWord8 $ xPrvDepth k
|
||||
putWord32be $ xPrvParent k
|
||||
putWord32be $ xPrvIndex k
|
||||
put $ xPrvChain k
|
||||
serialize $ xPrvChain k
|
||||
putPadPrvKey $ xPrvKey k
|
||||
get =
|
||||
deserialize =
|
||||
XPrvKey <$> getWord8
|
||||
<*> getWord32be
|
||||
<*> getWord32be
|
||||
<*> S.get
|
||||
<*> deserialize
|
||||
<*> getPadPrvKey
|
||||
|
||||
instance Binary XPrvKey where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Serialize XPrvKey where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
xPrvToJSON :: Network -> XPrvKey -> Value
|
||||
xPrvToJSON net = A.String . xPrvExport net
|
||||
|
||||
@ -202,19 +212,27 @@ data XPubKey = XPubKey
|
||||
, xPubKey :: !PubKey -- ^ public key of this node
|
||||
} deriving (Generic, Eq, Show, Read, NFData, Hashable)
|
||||
|
||||
instance Serialize XPubKey where
|
||||
put k = do
|
||||
instance Serial XPubKey where
|
||||
serialize k = do
|
||||
putWord8 $ xPubDepth k
|
||||
putWord32be $ xPubParent k
|
||||
putWord32be $ xPubIndex k
|
||||
put $ xPubChain k
|
||||
put $ wrapPubKey True (xPubKey k)
|
||||
get =
|
||||
serialize $ xPubChain k
|
||||
serialize $ wrapPubKey True (xPubKey k)
|
||||
deserialize =
|
||||
XPubKey <$> getWord8
|
||||
<*> getWord32be
|
||||
<*> getWord32be
|
||||
<*> S.get
|
||||
<*> (pubKeyPoint <$> S.get)
|
||||
<*> deserialize
|
||||
<*> (pubKeyPoint <$> deserialize)
|
||||
|
||||
instance Serialize XPubKey where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Binary XPubKey where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
-- | Decode an extended public key from a JSON string
|
||||
xPubFromJSON :: Network -> Value -> Parser XPubKey
|
||||
@ -238,7 +256,7 @@ makeXPrvKey bs =
|
||||
XPrvKey 0 0 0 c k
|
||||
where
|
||||
(p, c) = split512 $ hmac512 "Bitcoin seed" bs
|
||||
k = fromMaybe err (secKey (encode p))
|
||||
k = fromMaybe err (secKey (runPutS (serialize p)))
|
||||
err = throw $ DerivationException "Invalid seed"
|
||||
|
||||
-- | Derive an extended public key from an extended private key. This function
|
||||
@ -265,8 +283,8 @@ prvSubKey xkey child
|
||||
| otherwise = error "Invalid child derivation index"
|
||||
where
|
||||
pK = xPubKey $ deriveXPubKey xkey
|
||||
m = B.append (exportPubKey True pK) (encode child)
|
||||
(a, c) = split512 $ hmac512 (encode $ xPrvChain xkey) m
|
||||
m = B.append (exportPubKey True pK) (runPutS (serialize child))
|
||||
(a, c) = split512 $ hmac512 (runPutS $ serialize $ xPrvChain xkey) m
|
||||
k = fromMaybe err $ tweakSecKey (xPrvKey xkey) a
|
||||
err = throw $ DerivationException "Invalid prvSubKey derivation"
|
||||
|
||||
@ -280,8 +298,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)) (encode child)
|
||||
(a, c) = split512 $ hmac512 (encode $ xPubChain xKey) m
|
||||
m = B.append (exportPubKey True (xPubKey xKey)) (runPutS $ serialize child)
|
||||
(a, c) = split512 $ hmac512 (runPutS $ serialize $ xPubChain xKey) m
|
||||
pK = fromMaybe err $ tweakPubKey (xPubKey xKey) a
|
||||
err = throw $ DerivationException "Invalid pubSubKey derivation"
|
||||
|
||||
@ -300,8 +318,8 @@ hardSubKey xkey child
|
||||
| otherwise = error "Invalid child derivation index"
|
||||
where
|
||||
i = setBit child 31
|
||||
m = B.append (bsPadPrvKey $ xPrvKey xkey) (encode i)
|
||||
(a, c) = split512 $ hmac512 (encode $ xPrvChain xkey) m
|
||||
m = B.append (bsPadPrvKey $ xPrvKey xkey) (runPutS $ serialize i)
|
||||
(a, c) = split512 $ hmac512 (runPutS $ serialize $ xPrvChain xkey) m
|
||||
k = fromMaybe err $ tweakSecKey (xPrvKey xkey) a
|
||||
err = throw $ DerivationException "Invalid hardSubKey derivation"
|
||||
|
||||
@ -331,19 +349,19 @@ xPrvID = xPubID . deriveXPubKey
|
||||
|
||||
-- | Computes the key identifier of an extended public key.
|
||||
xPubID :: XPubKey -> Hash160
|
||||
xPubID = ripemd160 . encode . sha256 . exportPubKey True . xPubKey
|
||||
xPubID = ripemd160 . runPutS . serialize . sha256 . exportPubKey True . xPubKey
|
||||
|
||||
-- | Computes the key fingerprint of an extended private key.
|
||||
xPrvFP :: XPrvKey -> Fingerprint
|
||||
xPrvFP =
|
||||
fromRight err . decode . B.take 4 . encode . xPrvID
|
||||
fromRight err . runGetS deserialize . B.take 4 . runPutS . serialize . xPrvID
|
||||
where
|
||||
err = error "Could not decode xPrvFP"
|
||||
|
||||
-- | Computes the key fingerprint of an extended public key.
|
||||
xPubFP :: XPubKey -> Fingerprint
|
||||
xPubFP =
|
||||
fromRight err . decode . B.take 4 . encode . xPubID
|
||||
fromRight err . runGetS deserialize . B.take 4 . runPutS . serialize . xPubID
|
||||
where
|
||||
err = error "Could not decode xPubFP"
|
||||
|
||||
@ -363,53 +381,53 @@ xPubCompatWitnessAddr xkey =
|
||||
|
||||
-- | Exports an extended private key to the BIP32 key export format ('Base58').
|
||||
xPrvExport :: Network -> XPrvKey -> Base58
|
||||
xPrvExport net = encodeBase58Check . runPut . putXPrvKey net
|
||||
xPrvExport net = encodeBase58Check . runPutS . putXPrvKey net
|
||||
|
||||
-- | Exports an extended public key to the BIP32 key export format ('Base58').
|
||||
xPubExport :: Network -> XPubKey -> Base58
|
||||
xPubExport net = encodeBase58Check . runPut . putXPubKey net
|
||||
xPubExport net = encodeBase58Check . runPutS . putXPubKey net
|
||||
|
||||
-- | Decodes a BIP32 encoded extended private key. This function will fail if
|
||||
-- invalid base 58 characters are detected or if the checksum fails.
|
||||
xPrvImport :: Network -> Base58 -> Maybe XPrvKey
|
||||
xPrvImport net = eitherToMaybe . runGet (getXPrvKey net) <=< decodeBase58Check
|
||||
xPrvImport net = eitherToMaybe . runGetS (getXPrvKey net) <=< decodeBase58Check
|
||||
|
||||
-- | Decodes a BIP32 encoded extended public key. This function will fail if
|
||||
-- invalid base 58 characters are detected or if the checksum fails.
|
||||
xPubImport :: Network -> Base58 -> Maybe XPubKey
|
||||
xPubImport net = eitherToMaybe . runGet (getXPubKey net) <=< decodeBase58Check
|
||||
xPubImport net = eitherToMaybe . runGetS (getXPubKey net) <=< decodeBase58Check
|
||||
|
||||
-- | Export an extended private key to WIF (Wallet Import Format).
|
||||
xPrvWif :: Network -> XPrvKey -> Base58
|
||||
xPrvWif net xkey = toWif net (wrapSecKey True (xPrvKey xkey))
|
||||
|
||||
-- | Parse a binary extended private key.
|
||||
getXPrvKey :: Network -> Get XPrvKey
|
||||
getXPrvKey :: MonadGet m => Network -> m XPrvKey
|
||||
getXPrvKey net = do
|
||||
ver <- getWord32be
|
||||
unless (ver == getExtSecretPrefix net) $ fail
|
||||
"Get: Invalid version for extended private key"
|
||||
S.get
|
||||
deserialize
|
||||
|
||||
-- | Serialize an extended private key.
|
||||
putXPrvKey :: Network -> Putter XPrvKey
|
||||
putXPrvKey :: MonadPut m => Network -> XPrvKey -> m ()
|
||||
putXPrvKey net k = do
|
||||
putWord32be $ getExtSecretPrefix net
|
||||
put k
|
||||
serialize k
|
||||
|
||||
-- | Parse a binary extended public key.
|
||||
getXPubKey :: Network -> Get XPubKey
|
||||
getXPubKey :: MonadGet m => Network -> m XPubKey
|
||||
getXPubKey net = do
|
||||
ver <- getWord32be
|
||||
unless (ver == getExtPubKeyPrefix net) $ fail
|
||||
"Get: Invalid version for extended public key"
|
||||
S.get
|
||||
deserialize
|
||||
|
||||
-- | Serialize an extended public key.
|
||||
putXPubKey :: Network -> Putter XPubKey
|
||||
putXPubKey :: MonadPut m => Network -> XPubKey -> m ()
|
||||
putXPubKey net k = do
|
||||
putWord32be $ getExtPubKeyPrefix net
|
||||
put k
|
||||
serialize k
|
||||
|
||||
{- Derivation helpers -}
|
||||
|
||||
@ -580,17 +598,53 @@ instance Ord (DerivPathI t) where
|
||||
Deriv `compare` _ = LT
|
||||
_ `compare` Deriv = GT
|
||||
|
||||
instance Serial DerivPath where
|
||||
deserialize = listToPath <$> getList getWord32be
|
||||
serialize = putList putWord32be . pathToList
|
||||
|
||||
instance Serialize DerivPath where
|
||||
get = listToPath <$> S.get
|
||||
put = put . pathToList
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Binary DerivPath where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Serial HardPath where
|
||||
deserialize =
|
||||
maybe
|
||||
(fail "Could not decode hard path")
|
||||
return .
|
||||
toHard .
|
||||
listToPath =<<
|
||||
getList getWord32be
|
||||
serialize = putList putWord32be . pathToList
|
||||
|
||||
instance Serialize HardPath where
|
||||
get = maybe mzero return . toHard . listToPath =<< S.get
|
||||
put = put . pathToList
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Binary HardPath where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Serial SoftPath where
|
||||
deserialize =
|
||||
maybe
|
||||
(fail "Could not decode soft path")
|
||||
return .
|
||||
toSoft .
|
||||
listToPath =<<
|
||||
getList getWord32be
|
||||
serialize = putList putWord32be . pathToList
|
||||
|
||||
instance Serialize SoftPath where
|
||||
get = maybe mzero return . toSoft . listToPath =<< S.get
|
||||
put = put . pathToList
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Binary SoftPath where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
-- | Get a list of derivation indices from a derivation path.
|
||||
pathToList :: DerivPathI t -> [KeyIndex]
|
||||
@ -927,15 +981,18 @@ derivePathMSAddrs keys path =
|
||||
{- Utilities for extended keys -}
|
||||
|
||||
-- | De-serialize HDW-specific private key.
|
||||
getPadPrvKey :: Get SecKey
|
||||
getPadPrvKey :: MonadGet m => m SecKey
|
||||
getPadPrvKey = do
|
||||
pad <- getWord8
|
||||
unless (pad == 0x00) $ fail "Private key must be padded with 0x00"
|
||||
S.get
|
||||
bs <- getByteString 32
|
||||
case runGetS S.get bs of
|
||||
Left e -> fail e
|
||||
Right x -> return x
|
||||
|
||||
-- | Serialize HDW-specific private key.
|
||||
putPadPrvKey :: Putter SecKey
|
||||
putPadPrvKey p = putWord8 0x00 >> S.put p
|
||||
putPadPrvKey :: MonadPut m => SecKey -> m ()
|
||||
putPadPrvKey p = putWord8 0x00 >> putByteString (runPutS (S.put p))
|
||||
|
||||
bsPadPrvKey :: SecKey -> ByteString
|
||||
bsPadPrvKey = runPut . putPadPrvKey
|
||||
bsPadPrvKey = runPutS . putPadPrvKey
|
||||
|
@ -31,18 +31,18 @@ module Haskoin.Network.Bloom
|
||||
|
||||
import Control.DeepSeq
|
||||
import Control.Monad (forM_, replicateM)
|
||||
import Data.Binary (Binary (..))
|
||||
import Data.Bits
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
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, encode, get, put)
|
||||
import Data.Serialize.Get (getByteString, getWord32le,
|
||||
getWord8)
|
||||
import Data.Serialize.Put (putByteString, putWord32le,
|
||||
putWord8)
|
||||
import Data.Serialize (Serialize (..))
|
||||
import Data.Word
|
||||
import GHC.Generics (Generic)
|
||||
import Haskoin.Network.Common
|
||||
@ -74,19 +74,27 @@ data BloomFlags
|
||||
-- ^ auto-update on pay-to-pubkey or pay-to-multisig (default)
|
||||
deriving (Eq, Show, Read, Generic, NFData)
|
||||
|
||||
instance Serialize BloomFlags where
|
||||
get = go =<< getWord8
|
||||
instance Serial BloomFlags where
|
||||
deserialize = go =<< getWord8
|
||||
where
|
||||
go 0 = return BloomUpdateNone
|
||||
go 1 = return BloomUpdateAll
|
||||
go 2 = return BloomUpdateP2PubKeyOnly
|
||||
go _ = fail "BloomFlags get: Invalid bloom flag"
|
||||
|
||||
put f = putWord8 $ case f of
|
||||
serialize f = putWord8 $ case f of
|
||||
BloomUpdateNone -> 0
|
||||
BloomUpdateAll -> 1
|
||||
BloomUpdateP2PubKeyOnly -> 2
|
||||
|
||||
instance Binary BloomFlags where
|
||||
get = deserialize
|
||||
put = serialize
|
||||
|
||||
instance Serialize BloomFlags where
|
||||
get = deserialize
|
||||
put = serialize
|
||||
|
||||
-- | A bloom filter is a probabilistic data structure that SPV clients send to
|
||||
-- other peers to filter the set of transactions received from them. Bloom
|
||||
-- filters can have false positives but not false negatives. Some transactions
|
||||
@ -105,44 +113,71 @@ data BloomFilter = BloomFilter
|
||||
}
|
||||
deriving (Eq, Show, Read, Generic, NFData)
|
||||
|
||||
instance Serialize BloomFilter where
|
||||
instance Serial BloomFilter where
|
||||
|
||||
get = BloomFilter <$> (S.fromList <$> (readDat =<< get))
|
||||
<*> getWord32le <*> getWord32le
|
||||
<*> get
|
||||
deserialize =
|
||||
BloomFilter
|
||||
<$> (S.fromList <$> (readDat =<< deserialize))
|
||||
<*> getWord32le
|
||||
<*> getWord32le
|
||||
<*> deserialize
|
||||
where
|
||||
readDat (VarInt len) = replicateM (fromIntegral len) getWord8
|
||||
|
||||
put (BloomFilter dat hashFuncs tweak flags) = do
|
||||
serialize (BloomFilter dat hashFuncs tweak flags) = do
|
||||
putVarInt $ S.length dat
|
||||
forM_ (F.toList dat) putWord8
|
||||
putWord32le hashFuncs
|
||||
putWord32le tweak
|
||||
put flags
|
||||
serialize flags
|
||||
|
||||
instance Binary BloomFilter where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Serialize BloomFilter where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
-- | Set a new bloom filter on the peer connection.
|
||||
newtype FilterLoad = FilterLoad { filterLoadBloomFilter :: BloomFilter }
|
||||
deriving (Eq, Show, Read, Generic, NFData)
|
||||
|
||||
instance Serial FilterLoad where
|
||||
deserialize = FilterLoad <$> deserialize
|
||||
serialize (FilterLoad f) = serialize f
|
||||
|
||||
instance Binary FilterLoad where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Serialize FilterLoad where
|
||||
get = FilterLoad <$> get
|
||||
put (FilterLoad f) = put f
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
-- | Add the given data element to the connections current filter without
|
||||
-- requiring a completely new one to be set.
|
||||
newtype FilterAdd = FilterAdd { getFilterData :: ByteString }
|
||||
deriving (Eq, Show, Read, Generic, NFData)
|
||||
|
||||
instance Serialize FilterAdd where
|
||||
get = do
|
||||
(VarInt len) <- get
|
||||
instance Serial FilterAdd where
|
||||
deserialize = do
|
||||
(VarInt len) <- deserialize
|
||||
dat <- getByteString $ fromIntegral len
|
||||
return $ FilterAdd dat
|
||||
|
||||
put (FilterAdd bs) = do
|
||||
serialize (FilterAdd bs) = do
|
||||
putVarInt $ BS.length bs
|
||||
putByteString bs
|
||||
|
||||
instance Binary FilterAdd where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Serialize FilterAdd where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
|
||||
-- | Build a bloom filter that will provide the given false positive rate when
|
||||
-- the given number of elements have been inserted.
|
||||
@ -235,14 +270,14 @@ bloomRelevantUpdate bfilter tx
|
||||
(BloomUpdateAll, _) -> bloomInsert bf outpoint
|
||||
_ -> error "Error Updating Bloom Filter with relevant outpoint"
|
||||
where
|
||||
outpoint = encode $ OutPoint {outPointHash = h, outPointIndex = id'}
|
||||
outpoint = runPutS $ serialize $ OutPoint {outPointHash = h, outPointIndex = id'}
|
||||
scriptType = (\s -> isPayPK s || isPayMulSig s) scriptOut
|
||||
-- Encodes a scriptOutput so it can be checked agains the Bloom Filter
|
||||
encodeScriptOut :: ScriptOutput -> ByteString
|
||||
encodeScriptOut (PayMulSig outputMuSig _) = encode outputMuSig
|
||||
encodeScriptOut (PayWitnessScriptHash scriptHash) = encode scriptHash
|
||||
encodeScriptOut (DataCarrier getOutputDat) = encode getOutputDat
|
||||
encodeScriptOut outputHash = (encode . getOutputHash) outputHash
|
||||
encodeScriptOut (PayMulSig outputMuSig _) = runPutS $ serialize outputMuSig
|
||||
encodeScriptOut (PayWitnessScriptHash scriptHash) = runPutS $ serialize scriptHash
|
||||
encodeScriptOut (DataCarrier getOutputDat) = runPutS $ serialize getOutputDat
|
||||
encodeScriptOut outputHash = (runPutS . serialize . getOutputHash) outputHash
|
||||
|
||||
-- | Returns True if the filter is empty (all bytes set to 0x00)
|
||||
isBloomEmpty :: BloomFilter -> Bool
|
||||
|
@ -47,11 +47,15 @@ module Haskoin.Network.Common
|
||||
|
||||
import Control.DeepSeq
|
||||
import Control.Monad (forM_, liftM2, replicateM, unless)
|
||||
import Data.Binary (Binary (..))
|
||||
import Data.Bits (shiftL)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as B
|
||||
import Data.ByteString.Char8 as C (replicate)
|
||||
import Data.Serialize as S
|
||||
import Data.Bytes.Get
|
||||
import Data.Bytes.Put
|
||||
import Data.Bytes.Serial
|
||||
import Data.Serialize (Serialize (..))
|
||||
import Data.String
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Word (Word32, Word64)
|
||||
@ -71,16 +75,24 @@ newtype Addr =
|
||||
}
|
||||
deriving (Eq, Show, Generic, NFData)
|
||||
|
||||
instance Serialize Addr where
|
||||
instance Serial Addr where
|
||||
|
||||
get = Addr <$> (repList =<< S.get)
|
||||
deserialize = Addr <$> (repList =<< deserialize)
|
||||
where
|
||||
repList (VarInt c) = replicateM (fromIntegral c) action
|
||||
action = liftM2 (,) getWord32le S.get
|
||||
action = liftM2 (,) getWord32le deserialize
|
||||
|
||||
put (Addr xs) = do
|
||||
serialize (Addr xs) = do
|
||||
putVarInt $ length xs
|
||||
forM_ xs $ \(a,b) -> putWord32le a >> put b
|
||||
forM_ xs $ \(a,b) -> putWord32le a >> serialize b
|
||||
|
||||
instance Binary Addr where
|
||||
get = deserialize
|
||||
put = serialize
|
||||
|
||||
instance Serialize Addr where
|
||||
get = deserialize
|
||||
put = serialize
|
||||
|
||||
-- | Data type describing signed messages that can be sent between bitcoin
|
||||
-- nodes to display important notifications to end users about the health of
|
||||
@ -93,9 +105,17 @@ data Alert =
|
||||
, alertSignature :: !VarString
|
||||
} 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
|
||||
get = Alert <$> S.get <*> S.get
|
||||
put (Alert p s) = put p >> put s
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
-- | The 'GetData' type is used to retrieve information on a specific object
|
||||
-- ('Block' or 'Tx') identified by the objects hash. The payload of a 'GetData'
|
||||
@ -109,15 +129,23 @@ newtype GetData =
|
||||
getDataList :: [InvVector]
|
||||
} deriving (Eq, Show, Generic, NFData)
|
||||
|
||||
instance Serialize GetData where
|
||||
instance Serial GetData where
|
||||
|
||||
get = GetData <$> (repList =<< S.get)
|
||||
deserialize = GetData <$> (repList =<< deserialize)
|
||||
where
|
||||
repList (VarInt c) = replicateM (fromIntegral c) S.get
|
||||
repList (VarInt c) = replicateM (fromIntegral c) deserialize
|
||||
|
||||
put (GetData xs) = do
|
||||
serialize (GetData xs) = do
|
||||
putVarInt $ length xs
|
||||
forM_ xs put
|
||||
forM_ xs serialize
|
||||
|
||||
instance Binary GetData where
|
||||
get = deserialize
|
||||
put = serialize
|
||||
|
||||
instance Serialize GetData where
|
||||
get = deserialize
|
||||
put = serialize
|
||||
|
||||
-- | 'Inv' messages are used by nodes to advertise their knowledge of new
|
||||
-- objects by publishing a list of hashes to a peer. 'Inv' messages can be sent
|
||||
@ -128,15 +156,23 @@ newtype Inv =
|
||||
invList :: [InvVector]
|
||||
} deriving (Eq, Show, Generic, NFData)
|
||||
|
||||
instance Serialize Inv where
|
||||
instance Serial Inv where
|
||||
|
||||
get = Inv <$> (repList =<< S.get)
|
||||
deserialize = Inv <$> (repList =<< deserialize)
|
||||
where
|
||||
repList (VarInt c) = replicateM (fromIntegral c) S.get
|
||||
repList (VarInt c) = replicateM (fromIntegral c) deserialize
|
||||
|
||||
put (Inv xs) = do
|
||||
serialize (Inv xs) = do
|
||||
putVarInt $ length xs
|
||||
forM_ xs put
|
||||
forM_ xs serialize
|
||||
|
||||
instance Binary Inv where
|
||||
get = deserialize
|
||||
put = serialize
|
||||
|
||||
instance Serialize Inv where
|
||||
get = deserialize
|
||||
put = serialize
|
||||
|
||||
-- | Data type identifying the type of an inventory vector. SegWit types are
|
||||
-- only used in 'GetData' messages, not 'Inv'.
|
||||
@ -150,8 +186,8 @@ data InvType
|
||||
| InvWitnessMerkleBlock -- ^ segwit filtere block
|
||||
deriving (Eq, Show, Read, Generic, NFData)
|
||||
|
||||
instance Serialize InvType where
|
||||
get = go =<< getWord32le
|
||||
instance Serial InvType where
|
||||
deserialize = go =<< getWord32le
|
||||
where
|
||||
go x =
|
||||
case x of
|
||||
@ -164,7 +200,7 @@ instance Serialize InvType where
|
||||
| x == 1 `shiftL` 30 + 2 -> return InvWitnessBlock
|
||||
| x == 1 `shiftL` 30 + 3 -> return InvWitnessMerkleBlock
|
||||
| otherwise -> fail "bitcoinGet InvType: Invalid Type"
|
||||
put x =
|
||||
serialize x =
|
||||
putWord32le $
|
||||
case x of
|
||||
InvError -> 0
|
||||
@ -175,6 +211,14 @@ instance Serialize InvType where
|
||||
InvWitnessBlock -> 1 `shiftL` 30 + 2
|
||||
InvWitnessMerkleBlock -> 1 `shiftL` 30 + 3
|
||||
|
||||
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.
|
||||
@ -186,17 +230,33 @@ data InvVector =
|
||||
, invHash :: !Hash256
|
||||
} 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 = InvVector <$> S.get <*> S.get
|
||||
put (InvVector t h) = put t >> put h
|
||||
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
|
||||
put (HostAddress bs) = putByteString bs
|
||||
get = HostAddress <$> getByteString 18
|
||||
get = deserialize
|
||||
put = serialize
|
||||
|
||||
-- | Data type describing a bitcoin network address. Addresses are stored in
|
||||
-- IPv6 format. IPv4 addresses are mapped to IPv6 using IPv4 mapped IPv6
|
||||
@ -210,14 +270,14 @@ data NetworkAddress =
|
||||
|
||||
hostToSockAddr :: HostAddress -> SockAddr
|
||||
hostToSockAddr (HostAddress bs) =
|
||||
case runGet getSockAddr bs of
|
||||
case runGetS getSockAddr bs of
|
||||
Left e -> error e
|
||||
Right x -> x
|
||||
|
||||
sockToHostAddress :: SockAddr -> HostAddress
|
||||
sockToHostAddress = HostAddress . runPut . putSockAddr
|
||||
sockToHostAddress = HostAddress . runPutS . putSockAddr
|
||||
|
||||
putSockAddr :: SockAddr -> Put
|
||||
putSockAddr :: MonadPut m => SockAddr -> m ()
|
||||
putSockAddr (SockAddrInet6 p _ (a, b, c, d) _) = do
|
||||
putWord32be a
|
||||
putWord32be b
|
||||
@ -234,7 +294,7 @@ putSockAddr (SockAddrInet p a) = do
|
||||
|
||||
putSockAddr _ = error "Invalid address type"
|
||||
|
||||
getSockAddr :: Get SockAddr
|
||||
getSockAddr :: MonadGet m => m SockAddr
|
||||
getSockAddr = do
|
||||
a <- getWord32be
|
||||
b <- getWord32be
|
||||
@ -249,9 +309,17 @@ getSockAddr = do
|
||||
p <- getWord16be
|
||||
return $ SockAddrInet6 (fromIntegral p) 0 (a, b, c, d) 0
|
||||
|
||||
instance Serial NetworkAddress where
|
||||
deserialize = NetworkAddress <$> getWord64le <*> deserialize
|
||||
serialize (NetworkAddress s a) = putWord64le s >> serialize a
|
||||
|
||||
instance Binary NetworkAddress where
|
||||
get = deserialize
|
||||
put = serialize
|
||||
|
||||
instance Serialize NetworkAddress where
|
||||
get = NetworkAddress <$> getWord64le <*> S.get
|
||||
put (NetworkAddress s a) = putWord64le s >> put a
|
||||
get = deserialize
|
||||
put = serialize
|
||||
|
||||
-- | A 'NotFound' message is returned as a response to a 'GetData' message
|
||||
-- whe one of the requested objects could not be retrieved. This could happen,
|
||||
@ -262,15 +330,23 @@ newtype NotFound =
|
||||
notFoundList :: [InvVector]
|
||||
} deriving (Eq, Show, Generic, NFData)
|
||||
|
||||
instance Serialize NotFound where
|
||||
instance Serial NotFound where
|
||||
|
||||
get = NotFound <$> (repList =<< S.get)
|
||||
deserialize = NotFound <$> (repList =<< deserialize)
|
||||
where
|
||||
repList (VarInt c) = replicateM (fromIntegral c) S.get
|
||||
repList (VarInt c) = replicateM (fromIntegral c) deserialize
|
||||
|
||||
put (NotFound xs) = do
|
||||
serialize (NotFound xs) = do
|
||||
putVarInt $ length xs
|
||||
forM_ xs put
|
||||
forM_ xs serialize
|
||||
|
||||
instance Binary NotFound where
|
||||
get = deserialize
|
||||
put = serialize
|
||||
|
||||
instance Serialize NotFound where
|
||||
get = deserialize
|
||||
put = serialize
|
||||
|
||||
-- | A 'Ping' message is sent to bitcoin peers to check if a connection is still
|
||||
-- open.
|
||||
@ -287,13 +363,29 @@ newtype Pong =
|
||||
pongNonce :: Word64
|
||||
} deriving (Eq, Show, Read, Generic, NFData)
|
||||
|
||||
instance Serial Ping where
|
||||
deserialize = Ping <$> getWord64le
|
||||
serialize (Ping n) = putWord64le n
|
||||
|
||||
instance Serial Pong where
|
||||
deserialize = Pong <$> getWord64le
|
||||
serialize (Pong n) = putWord64le n
|
||||
|
||||
instance Binary Ping where
|
||||
get = deserialize
|
||||
put = serialize
|
||||
|
||||
instance Binary Pong where
|
||||
get = deserialize
|
||||
put = serialize
|
||||
|
||||
instance Serialize Ping where
|
||||
get = Ping <$> getWord64le
|
||||
put (Ping n) = putWord64le n
|
||||
get = deserialize
|
||||
put = serialize
|
||||
|
||||
instance Serialize Pong where
|
||||
get = Pong <$> getWord64le
|
||||
put (Pong n) = putWord64le n
|
||||
get = deserialize
|
||||
put = serialize
|
||||
|
||||
-- | The 'Reject' message is sent when messages are rejected by a peer.
|
||||
data Reject =
|
||||
@ -320,9 +412,10 @@ data RejectCode
|
||||
| RejectCheckpoint
|
||||
deriving (Eq, Show, Read, Generic, NFData)
|
||||
|
||||
instance Serialize RejectCode where
|
||||
instance Serial RejectCode where
|
||||
|
||||
get = getWord8 >>= \code -> case code of
|
||||
deserialize =
|
||||
getWord8 >>= \code -> case code of
|
||||
0x01 -> return RejectMalformed
|
||||
0x10 -> return RejectInvalid
|
||||
0x11 -> return RejectObsolete
|
||||
@ -332,11 +425,11 @@ instance Serialize RejectCode where
|
||||
0x42 -> return RejectInsufficientFee
|
||||
0x43 -> return RejectCheckpoint
|
||||
_ -> fail $ unwords
|
||||
[ "Reject get: Invalid code"
|
||||
, show code
|
||||
]
|
||||
[ "Reject get: Invalid code"
|
||||
, show code
|
||||
]
|
||||
|
||||
put code = putWord8 $ case code of
|
||||
serialize code = putWord8 $ case code of
|
||||
RejectMalformed -> 0x01
|
||||
RejectInvalid -> 0x10
|
||||
RejectObsolete -> 0x11
|
||||
@ -346,42 +439,61 @@ instance Serialize RejectCode where
|
||||
RejectInsufficientFee -> 0x42
|
||||
RejectCheckpoint -> 0x43
|
||||
|
||||
instance Binary RejectCode where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Serialize RejectCode where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
-- | Convenience function to build a 'Reject' message.
|
||||
reject :: MessageCommand -> RejectCode -> ByteString -> Reject
|
||||
reject cmd code reason =
|
||||
Reject cmd code (VarString reason) B.empty
|
||||
|
||||
instance Serialize Reject where
|
||||
get =
|
||||
S.get >>= \(VarString bs) ->
|
||||
Reject (stringToCommand bs) <$> S.get <*> S.get <*> maybeData
|
||||
instance Serial Reject where
|
||||
deserialize =
|
||||
deserialize >>= \(VarString bs) ->
|
||||
Reject (stringToCommand bs)
|
||||
<$> deserialize
|
||||
<*> deserialize
|
||||
<*> maybeData
|
||||
where
|
||||
maybeData =
|
||||
isEmpty >>= \done ->
|
||||
if done
|
||||
then return B.empty
|
||||
else getByteString 32
|
||||
put (Reject cmd code reason dat) = do
|
||||
put $ VarString $ commandToString cmd
|
||||
put code
|
||||
put reason
|
||||
serialize (Reject cmd code reason dat) = do
|
||||
serialize $ VarString $ commandToString cmd
|
||||
serialize code
|
||||
serialize reason
|
||||
unless (B.null dat) $ putByteString dat
|
||||
|
||||
instance Binary Reject where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Serialize Reject where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
-- | Data type representing a variable-length integer. The 'VarInt' type
|
||||
-- usually precedes an array or a string that can vary in length.
|
||||
newtype VarInt = VarInt { getVarInt :: Word64 }
|
||||
deriving (Eq, Show, Read, Generic, NFData)
|
||||
|
||||
instance Serialize VarInt where
|
||||
instance Serial VarInt where
|
||||
|
||||
get = VarInt <$> ( getWord8 >>= go )
|
||||
deserialize = VarInt <$> ( getWord8 >>= go )
|
||||
where
|
||||
go 0xff = getWord64le
|
||||
go 0xfe = fromIntegral <$> getWord32le
|
||||
go 0xfd = fromIntegral <$> getWord16le
|
||||
go x = fromIntegral <$> return x
|
||||
|
||||
put (VarInt x)
|
||||
serialize (VarInt x)
|
||||
| x < 0xfd =
|
||||
putWord8 $ fromIntegral x
|
||||
| x <= 0xffff = do
|
||||
@ -394,23 +506,39 @@ instance Serialize VarInt where
|
||||
putWord8 0xff
|
||||
putWord64le x
|
||||
|
||||
putVarInt :: Integral a => a -> Put
|
||||
putVarInt = put . VarInt . fromIntegral
|
||||
instance Binary VarInt where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Serialize VarInt where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
putVarInt :: (MonadPut m, Integral a) => a -> m ()
|
||||
putVarInt = serialize . VarInt . fromIntegral
|
||||
|
||||
-- | Data type for serialization of variable-length strings.
|
||||
newtype VarString = VarString { getVarString :: ByteString }
|
||||
deriving (Eq, Show, Read, Generic, NFData)
|
||||
|
||||
instance Serialize VarString where
|
||||
instance Serial VarString where
|
||||
|
||||
get = VarString <$> (readBS =<< S.get)
|
||||
deserialize = VarString <$> (readBS =<< deserialize)
|
||||
where
|
||||
readBS (VarInt len) = getByteString (fromIntegral len)
|
||||
|
||||
put (VarString bs) = do
|
||||
serialize (VarString bs) = do
|
||||
putVarInt $ B.length bs
|
||||
putByteString bs
|
||||
|
||||
instance Binary VarString where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Serialize VarString where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
-- | When a bitcoin node creates an outgoing connection to another node,
|
||||
-- the first message it will send is a 'Version' message. The other node
|
||||
-- will similarly respond with it's own 'Version' message.
|
||||
@ -436,40 +564,48 @@ data Version =
|
||||
, relay :: !Bool
|
||||
} deriving (Eq, Show, Generic, NFData)
|
||||
|
||||
instance Serialize Version where
|
||||
instance Serial Version where
|
||||
|
||||
get = Version <$> getWord32le
|
||||
<*> getWord64le
|
||||
<*> getWord64le
|
||||
<*> S.get
|
||||
<*> S.get
|
||||
<*> getWord64le
|
||||
<*> S.get
|
||||
<*> getWord32le
|
||||
<*> (go =<< isEmpty)
|
||||
deserialize = Version <$> getWord32le
|
||||
<*> getWord64le
|
||||
<*> getWord64le
|
||||
<*> deserialize
|
||||
<*> deserialize
|
||||
<*> getWord64le
|
||||
<*> deserialize
|
||||
<*> getWord32le
|
||||
<*> (go =<< isEmpty)
|
||||
where
|
||||
go True = return True
|
||||
go False = getBool
|
||||
|
||||
put (Version v s t ar as n ua sh r) = do
|
||||
serialize (Version v s t ar as n ua sh r) = do
|
||||
putWord32le v
|
||||
putWord64le s
|
||||
putWord64le t
|
||||
put ar
|
||||
put as
|
||||
serialize ar
|
||||
serialize as
|
||||
putWord64le n
|
||||
put ua
|
||||
serialize ua
|
||||
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 :: Get Bool
|
||||
getBool :: MonadGet m => m Bool
|
||||
getBool = go =<< getWord8
|
||||
where
|
||||
go 0 = return False
|
||||
go _ = return True
|
||||
|
||||
putBool :: Bool -> Put
|
||||
putBool :: MonadPut m => Bool -> m ()
|
||||
putBool True = putWord8 1
|
||||
putBool False = putWord8 0
|
||||
|
||||
@ -512,13 +648,21 @@ instance Read MessageCommand where
|
||||
String str <- lexP
|
||||
return (stringToCommand (cs str))
|
||||
|
||||
instance Serialize MessageCommand where
|
||||
get = go <$> getByteString 12
|
||||
instance Serial MessageCommand where
|
||||
deserialize = go <$> getByteString 12
|
||||
where
|
||||
go bs =
|
||||
let str = unpackCommand bs
|
||||
in stringToCommand str
|
||||
put mc = putByteString $ packCommand $ commandToString mc
|
||||
serialize mc = putByteString $ packCommand $ commandToString mc
|
||||
|
||||
instance Binary MessageCommand where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Serialize MessageCommand where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance IsString MessageCommand where
|
||||
fromString str = stringToCommand (cs str)
|
||||
|
@ -21,13 +21,13 @@ module Haskoin.Network.Message
|
||||
|
||||
import Control.DeepSeq
|
||||
import Control.Monad (unless)
|
||||
import Data.Binary (Binary (..))
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Serialize (Serialize, encode, get, put)
|
||||
import Data.Serialize.Get (Get, getByteString, getWord32be,
|
||||
getWord32le, isolate, lookAhead)
|
||||
import Data.Serialize.Put (Putter, putByteString, putWord32be,
|
||||
putWord32le)
|
||||
import Data.Bytes.Get
|
||||
import Data.Bytes.Put
|
||||
import Data.Bytes.Serial
|
||||
import Data.Serialize (Serialize (..))
|
||||
import Data.Word (Word32)
|
||||
import GHC.Generics (Generic)
|
||||
import Haskoin.Block.Common
|
||||
@ -51,18 +51,28 @@ data MessageHeader = MessageHeader
|
||||
, headChecksum :: !CheckSum32
|
||||
} deriving (Eq, Show, Generic, NFData)
|
||||
|
||||
instance Serialize MessageHeader where
|
||||
instance Serial MessageHeader where
|
||||
|
||||
get = MessageHeader <$> getWord32be
|
||||
<*> get
|
||||
<*> getWord32le
|
||||
<*> get
|
||||
deserialize =
|
||||
MessageHeader
|
||||
<$> getWord32be
|
||||
<*> deserialize
|
||||
<*> getWord32le
|
||||
<*> deserialize
|
||||
|
||||
put (MessageHeader m c l chk) = do
|
||||
serialize (MessageHeader m c l chk) = do
|
||||
putWord32be m
|
||||
put c
|
||||
serialize c
|
||||
putWord32le l
|
||||
put chk
|
||||
serialize chk
|
||||
|
||||
instance Binary MessageHeader where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Serialize MessageHeader where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
-- | The 'Message' type is used to identify all the valid messages that can be
|
||||
-- sent between bitcoin peers. Only values of type 'Message' will be accepted
|
||||
@ -124,9 +134,9 @@ msgType MGetAddr = MCGetAddr
|
||||
msgType (MOther c _) = MCOther c
|
||||
|
||||
-- | Deserializer for network messages.
|
||||
getMessage :: Network -> Get Message
|
||||
getMessage :: MonadGet m => Network -> m Message
|
||||
getMessage net = do
|
||||
(MessageHeader mgc cmd len chk) <- get
|
||||
(MessageHeader mgc cmd len chk) <- deserialize
|
||||
bs <- lookAhead $ getByteString $ fromIntegral len
|
||||
unless
|
||||
(mgc == getNetworkMagic net)
|
||||
@ -135,28 +145,30 @@ getMessage net = do
|
||||
(checkSum32 bs == chk)
|
||||
(fail $ "get: Invalid message checksum: " ++ show chk)
|
||||
if len > 0
|
||||
then isolate (fromIntegral len) $
|
||||
case cmd of
|
||||
MCVersion -> MVersion <$> get
|
||||
MCAddr -> MAddr <$> get
|
||||
MCInv -> MInv <$> get
|
||||
MCGetData -> MGetData <$> get
|
||||
MCNotFound -> MNotFound <$> get
|
||||
MCGetBlocks -> MGetBlocks <$> get
|
||||
MCGetHeaders -> MGetHeaders <$> get
|
||||
MCTx -> MTx <$> get
|
||||
MCBlock -> MBlock <$> get
|
||||
MCMerkleBlock -> MMerkleBlock <$> get
|
||||
MCHeaders -> MHeaders <$> get
|
||||
MCFilterLoad -> MFilterLoad <$> get
|
||||
MCFilterAdd -> MFilterAdd <$> get
|
||||
MCPing -> MPing <$> get
|
||||
MCPong -> MPong <$> get
|
||||
MCAlert -> MAlert <$> get
|
||||
MCReject -> MReject <$> get
|
||||
MCOther c -> MOther c <$> getByteString (fromIntegral len)
|
||||
_ -> fail $ "get: command " ++ show cmd ++
|
||||
" should not carry a payload"
|
||||
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
|
||||
MCOther c -> MOther c <$> getByteString (fromIntegral len)
|
||||
_ -> fail $ "get: command " ++ show cmd ++
|
||||
" should not carry a payload"
|
||||
either fail return (runGetS f bs)
|
||||
else case cmd of
|
||||
MCGetAddr -> return MGetAddr
|
||||
MCVerAck -> return MVerAck
|
||||
@ -167,35 +179,35 @@ getMessage net = do
|
||||
" is expected to carry a payload"
|
||||
|
||||
-- | Serializer for network messages.
|
||||
putMessage :: Network -> Putter Message
|
||||
putMessage :: MonadPut m => Network -> Message -> m ()
|
||||
putMessage net msg = do
|
||||
let (cmd, payload) =
|
||||
case msg of
|
||||
MVersion m -> (MCVersion, encode m)
|
||||
MVerAck -> (MCVerAck, BS.empty)
|
||||
MAddr m -> (MCAddr, encode m)
|
||||
MInv m -> (MCInv, encode m)
|
||||
MGetData m -> (MCGetData, encode m)
|
||||
MNotFound m -> (MCNotFound, encode m)
|
||||
MGetBlocks m -> (MCGetBlocks, encode m)
|
||||
MGetHeaders m -> (MCGetHeaders, encode m)
|
||||
MTx m -> (MCTx, encode m)
|
||||
MBlock m -> (MCBlock, encode m)
|
||||
MMerkleBlock m -> (MCMerkleBlock, encode m)
|
||||
MHeaders m -> (MCHeaders, encode m)
|
||||
MGetAddr -> (MCGetAddr, BS.empty)
|
||||
MFilterLoad m -> (MCFilterLoad, encode m)
|
||||
MFilterAdd m -> (MCFilterAdd, encode m)
|
||||
MFilterClear -> (MCFilterClear, BS.empty)
|
||||
MPing m -> (MCPing, encode m)
|
||||
MPong m -> (MCPong, encode m)
|
||||
MAlert m -> (MCAlert, encode m)
|
||||
MMempool -> (MCMempool, BS.empty)
|
||||
MReject m -> (MCReject, encode m)
|
||||
MSendHeaders -> (MCSendHeaders, BS.empty)
|
||||
MOther c p -> (MCOther c, p)
|
||||
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)
|
||||
chk = checkSum32 payload
|
||||
len = fromIntegral $ BS.length payload
|
||||
header = MessageHeader (getNetworkMagic net) cmd len chk
|
||||
put header
|
||||
serialize header
|
||||
putByteString payload
|
||||
|
@ -24,12 +24,16 @@ module Haskoin.Script.Common
|
||||
|
||||
import Control.DeepSeq
|
||||
import Control.Monad
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as B
|
||||
import Data.Binary (Binary (..))
|
||||
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.Serialize as S
|
||||
import Data.Word (Word8)
|
||||
import GHC.Generics (Generic)
|
||||
import Data.Serialize (Serialize (..))
|
||||
import Data.Word (Word8)
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
-- | Data type representing a transaction script. Scripts are defined as lists
|
||||
-- of script operators 'ScriptOp'. Scripts are used to:
|
||||
@ -47,17 +51,25 @@ newtype Script =
|
||||
}
|
||||
deriving (Eq, Show, Read, Generic, Hashable, NFData)
|
||||
|
||||
instance Serialize Script where
|
||||
get =
|
||||
instance Serial Script where
|
||||
deserialize =
|
||||
Script <$> getScriptOps
|
||||
where
|
||||
getScriptOps = do
|
||||
empty <- isEmpty
|
||||
if empty
|
||||
then return []
|
||||
else (:) <$> get <*> getScriptOps
|
||||
else (:) <$> deserialize <*> getScriptOps
|
||||
|
||||
put (Script ops) = forM_ ops put
|
||||
serialize (Script ops) = forM_ ops serialize
|
||||
|
||||
instance Binary Script where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Serialize Script where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
-- | Data type representing the type of an OP_PUSHDATA opcode.
|
||||
data PushDataType
|
||||
@ -203,8 +215,8 @@ data ScriptOp
|
||||
| OP_INVALIDOPCODE !Word8
|
||||
deriving (Show, Read, Eq, Generic, Hashable, NFData)
|
||||
|
||||
instance Serialize ScriptOp where
|
||||
get = go =<< (fromIntegral <$> getWord8)
|
||||
instance Serial ScriptOp where
|
||||
deserialize = go =<< (fromIntegral <$> getWord8)
|
||||
where
|
||||
go op
|
||||
| op == 0x00 = return OP_0
|
||||
@ -359,7 +371,7 @@ instance Serialize ScriptOp where
|
||||
|
||||
| otherwise = return $ OP_INVALIDOPCODE op
|
||||
|
||||
put op = case op of
|
||||
serialize op = case op of
|
||||
|
||||
(OP_PUSHDATA payload optype)-> do
|
||||
let len = B.length payload
|
||||
@ -523,6 +535,13 @@ instance Serialize ScriptOp where
|
||||
-- Bitcoin Cash May 2020 hard fork
|
||||
OP_REVERSEBYTES -> putWord8 0xbc
|
||||
|
||||
instance Binary ScriptOp where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Serialize ScriptOp where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
-- | Check whether opcode is only data.
|
||||
isPushOp :: ScriptOp -> Bool
|
||||
@ -565,7 +584,13 @@ intToScriptOp i
|
||||
| i `elem` [1 .. 16] = op
|
||||
| otherwise = err
|
||||
where
|
||||
op = either (const err) id . S.decode . B.singleton . fromIntegral $ i + 0x50
|
||||
op = either
|
||||
(const err)
|
||||
id .
|
||||
runGetS deserialize .
|
||||
B.singleton .
|
||||
fromIntegral $
|
||||
i + 0x50
|
||||
err = error $ "intToScriptOp: Invalid integer " ++ show i
|
||||
|
||||
-- | Decode 'ScriptOp' @[OP_1 .. OP_16]@ to integers @[1 .. 16]@. This functions
|
||||
@ -575,4 +600,4 @@ scriptOpToInt s
|
||||
| res `elem` [1..16] = return res
|
||||
| otherwise = Left $ "scriptOpToInt: invalid opcode " ++ show s
|
||||
where
|
||||
res = fromIntegral (B.head $ S.encode s) - 0x50
|
||||
res = fromIntegral (B.head $ runPutS $ serialize s) - 0x50
|
||||
|
@ -41,16 +41,18 @@ import Control.Monad
|
||||
import qualified Data.Aeson as J
|
||||
import Data.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.Serialize
|
||||
import Data.Word
|
||||
import GHC.Generics (Generic)
|
||||
import Haskoin.Constants
|
||||
import Haskoin.Crypto
|
||||
import Haskoin.Crypto.Hash
|
||||
import Haskoin.Network.Common
|
||||
import Haskoin.Crypto
|
||||
import Haskoin.Script.Common
|
||||
import Haskoin.Transaction.Common
|
||||
import Haskoin.Util
|
||||
@ -207,8 +209,8 @@ txSigHash net tx out v i sh
|
||||
let newTx = Tx (txVersion tx) newIn newOut [] (txLockTime tx)
|
||||
return $
|
||||
doubleSHA256 $
|
||||
runPut $ do
|
||||
put newTx
|
||||
runPutS $ do
|
||||
serialize newTx
|
||||
putWord32le $ fromIntegral sh
|
||||
where
|
||||
fout = Script $ filter (/= OP_CODESEPARATOR) $ scriptOps out
|
||||
@ -218,13 +220,13 @@ txSigHash net tx out v i sh
|
||||
buildInputs :: [TxIn] -> Script -> Int -> SigHash -> [TxIn]
|
||||
buildInputs txins out i sh
|
||||
| hasAnyoneCanPayFlag sh =
|
||||
[ (txins !! i) { scriptInput = encode out } ]
|
||||
[ (txins !! i) { scriptInput = runPutS $ serialize out } ]
|
||||
| isSigHashAll sh || isSigHashUnknown sh = single
|
||||
| otherwise = zipWith noSeq single [0 ..]
|
||||
where
|
||||
emptyIn = map (\ti -> ti { scriptInput = BS.empty }) txins
|
||||
single =
|
||||
updateIndex i emptyIn $ \ti -> ti { scriptInput = encode out }
|
||||
updateIndex i emptyIn $ \ti -> ti { scriptInput = runPutS $ serialize out }
|
||||
noSeq ti j =
|
||||
if i == j
|
||||
then ti
|
||||
@ -251,35 +253,35 @@ txSigHashForkId
|
||||
-> SigHash -- ^ what to sign
|
||||
-> Hash256 -- ^ hash to be signed
|
||||
txSigHashForkId net tx out v i sh =
|
||||
doubleSHA256 . runPut $ do
|
||||
doubleSHA256 . runPutS $ do
|
||||
putWord32le $ txVersion tx
|
||||
put hashPrevouts
|
||||
put hashSequence
|
||||
put $ prevOutput $ txIn tx !! i
|
||||
serialize hashPrevouts
|
||||
serialize hashSequence
|
||||
serialize $ prevOutput $ txIn tx !! i
|
||||
putScript out
|
||||
putWord64le v
|
||||
putWord32le $ txInSequence $ txIn tx !! i
|
||||
put hashOutputs
|
||||
serialize hashOutputs
|
||||
putWord32le $ txLockTime tx
|
||||
putWord32le $ fromIntegral $ sigHashAddNetworkId net sh
|
||||
where
|
||||
hashPrevouts
|
||||
| not $ hasAnyoneCanPayFlag sh =
|
||||
doubleSHA256 $ runPut $ mapM_ (put . prevOutput) $ txIn tx
|
||||
doubleSHA256 $ runPutS $ mapM_ (serialize . prevOutput) $ txIn tx
|
||||
| otherwise = zeros
|
||||
hashSequence
|
||||
| not (hasAnyoneCanPayFlag sh) &&
|
||||
not (isSigHashSingle sh) && not (isSigHashNone sh) =
|
||||
doubleSHA256 $ runPut $ mapM_ (putWord32le . txInSequence) $ txIn tx
|
||||
doubleSHA256 $ runPutS $ mapM_ (putWord32le . txInSequence) $ txIn tx
|
||||
| otherwise = zeros
|
||||
hashOutputs
|
||||
| not (isSigHashSingle sh) && not (isSigHashNone sh) =
|
||||
doubleSHA256 $ runPut $ mapM_ put $ txOut tx
|
||||
doubleSHA256 $ runPutS $ mapM_ serialize $ txOut tx
|
||||
| isSigHashSingle sh && i < length (txOut tx) =
|
||||
doubleSHA256 $ encode $ txOut tx !! i
|
||||
doubleSHA256 $ runPutS $ serialize $ txOut tx !! i
|
||||
| otherwise = zeros
|
||||
putScript s = do
|
||||
let encodedScript = encode s
|
||||
let encodedScript = runPutS $ serialize s
|
||||
putVarInt $ BS.length encodedScript
|
||||
putByteString encodedScript
|
||||
zeros :: Hash256
|
||||
@ -302,7 +304,7 @@ instance NFData TxSignature
|
||||
encodeTxSig :: TxSignature -> BS.ByteString
|
||||
encodeTxSig TxSignatureEmpty = error "Can not encode an empty signature"
|
||||
encodeTxSig (TxSignature sig (SigHash n)) =
|
||||
runPut $ putSig sig >> putWord8 (fromIntegral n)
|
||||
runPutS $ putSig sig >> putWord8 (fromIntegral n)
|
||||
|
||||
-- | Deserialize a 'TxSignature'.
|
||||
decodeTxSig :: Network -> BS.ByteString -> Either String TxSignature
|
||||
|
@ -50,11 +50,13 @@ 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
|
||||
import Data.Bytes.Put
|
||||
import Data.Bytes.Serial
|
||||
import Data.Function (on)
|
||||
import Data.Hashable
|
||||
import Data.List (sortBy)
|
||||
import Data.Maybe (fromJust, isJust)
|
||||
import Data.Serialize as S
|
||||
import Data.Maybe (fromJust, isJust, isNothing)
|
||||
import Data.Word (Word8)
|
||||
import GHC.Generics (Generic)
|
||||
import Haskoin.Constants
|
||||
@ -145,17 +147,19 @@ isDataCarrier _ = False
|
||||
decodeOutput :: Script -> Either String ScriptOutput
|
||||
decodeOutput s = case scriptOps s of
|
||||
-- Pay to PubKey
|
||||
[OP_PUSHDATA bs _, OP_CHECKSIG] -> PayPK <$> S.decode bs
|
||||
[OP_PUSHDATA bs _, OP_CHECKSIG] -> PayPK <$> runGetS deserialize bs
|
||||
-- Pay to PubKey Hash
|
||||
[OP_DUP, OP_HASH160, OP_PUSHDATA bs _, OP_EQUALVERIFY, OP_CHECKSIG] ->
|
||||
PayPKHash <$> S.decode bs
|
||||
PayPKHash <$> runGetS deserialize bs
|
||||
-- Pay to Script Hash
|
||||
[OP_HASH160, OP_PUSHDATA bs _, OP_EQUAL] ->
|
||||
PayScriptHash <$> S.decode bs
|
||||
PayScriptHash <$> runGetS deserialize bs
|
||||
-- Pay to Witness
|
||||
[OP_0, OP_PUSHDATA bs OPCODE]
|
||||
| BS.length bs == 20 -> PayWitnessPKHash <$> S.decode bs
|
||||
| BS.length bs == 32 -> PayWitnessScriptHash <$> S.decode bs
|
||||
| BS.length bs == 20 -> PayWitnessPKHash <$> runGetS deserialize bs
|
||||
| BS.length bs == 32 -> PayWitnessScriptHash <$> runGetS deserialize bs
|
||||
| BS.length bs /= 20 && BS.length bs /= 32 ->
|
||||
Left "Version 0 segwit program must be 20 or 32 bytes long"
|
||||
-- Other Witness
|
||||
[ver, OP_PUSHDATA bs _]
|
||||
| isJust (opWitnessVersion ver)
|
||||
@ -204,23 +208,23 @@ opWitnessVersion OP_13 = Just 13
|
||||
opWitnessVersion OP_14 = Just 14
|
||||
opWitnessVersion OP_15 = Just 15
|
||||
opWitnessVersion OP_16 = Just 16
|
||||
opWitnessVersion _ = Nothing
|
||||
opWitnessVersion _ = Nothing
|
||||
|
||||
|
||||
-- | Similar to 'decodeOutput' but decodes from a 'ByteString'.
|
||||
decodeOutputBS :: ByteString -> Either String ScriptOutput
|
||||
decodeOutputBS = decodeOutput <=< S.decode
|
||||
decodeOutputBS = decodeOutput <=< runGetS deserialize
|
||||
|
||||
-- | Computes a 'Script' from a standard 'ScriptOutput'.
|
||||
encodeOutput :: ScriptOutput -> Script
|
||||
encodeOutput s = Script $ case s of
|
||||
-- Pay to PubKey
|
||||
(PayPK k) -> [opPushData $ S.encode k, OP_CHECKSIG]
|
||||
(PayPK k) -> [opPushData $ runPutS $ serialize k, OP_CHECKSIG]
|
||||
-- Pay to PubKey Hash Address
|
||||
(PayPKHash h) ->
|
||||
[ OP_DUP
|
||||
, OP_HASH160
|
||||
, opPushData $ S.encode h
|
||||
, opPushData $ runPutS $ serialize h
|
||||
, OP_EQUALVERIFY, OP_CHECKSIG
|
||||
]
|
||||
-- Pay to MultiSig Keys
|
||||
@ -228,17 +232,17 @@ encodeOutput s = Script $ case s of
|
||||
| r <= length ps ->
|
||||
let opM = intToScriptOp r
|
||||
opN = intToScriptOp $ length ps
|
||||
keys = map (opPushData . S.encode) ps
|
||||
keys = map (opPushData . runPutS . serialize) ps
|
||||
in opM : keys ++ [opN, OP_CHECKMULTISIG]
|
||||
| otherwise -> error "encodeOutput: PayMulSig r must be <= than pkeys"
|
||||
-- Pay to Script Hash Address
|
||||
(PayScriptHash h) ->
|
||||
[ OP_HASH160, opPushData $ S.encode h, OP_EQUAL]
|
||||
[ OP_HASH160, opPushData $ runPutS $ serialize h, OP_EQUAL]
|
||||
-- Pay to Witness PubKey Hash Address
|
||||
(PayWitnessPKHash h) ->
|
||||
[ OP_0, opPushData $ S.encode h ]
|
||||
[ OP_0, opPushData $ runPutS $ serialize h ]
|
||||
(PayWitnessScriptHash h) ->
|
||||
[ OP_0, opPushData $ S.encode h ]
|
||||
[ OP_0, opPushData $ runPutS $ serialize h ]
|
||||
(PayWitness v h) ->
|
||||
[ case witnessVersionOp v of
|
||||
Nothing -> error "encodeOutput: invalid witness version"
|
||||
@ -249,15 +253,15 @@ encodeOutput s = Script $ case s of
|
||||
|
||||
-- | Similar to 'encodeOutput' but encodes to a ByteString
|
||||
encodeOutputBS :: ScriptOutput -> ByteString
|
||||
encodeOutputBS = S.encode . encodeOutput
|
||||
encodeOutputBS = runPutS . serialize . encodeOutput
|
||||
|
||||
-- | Encode script as pay-to-script-hash script
|
||||
toP2SH :: Script -> ScriptOutput
|
||||
toP2SH = PayScriptHash . addressHash . S.encode
|
||||
toP2SH = PayScriptHash . addressHash . runPutS . serialize
|
||||
|
||||
-- | Encode script as a pay-to-witness-script-hash script
|
||||
toP2WSH :: Script -> ScriptOutput
|
||||
toP2WSH = PayWitnessScriptHash . sha256 . S.encode
|
||||
toP2WSH = PayWitnessScriptHash . sha256 . runPutS . serialize
|
||||
|
||||
-- | Match @[OP_N, PubKey1, ..., PubKeyM, OP_M, OP_CHECKMULTISIG]@
|
||||
matchPayMulSig :: Script -> Either String ScriptOutput
|
||||
@ -269,7 +273,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 (:) (S.decode bs) (go xs)
|
||||
go (OP_PUSHDATA bs _:xs) = liftM2 (:) (runGetS deserialize bs) (go xs)
|
||||
go [] = return []
|
||||
go _ = Left "matchPayMulSig: invalid multisig opcode"
|
||||
|
||||
@ -277,8 +281,8 @@ 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` encode) keys) r
|
||||
_ -> error "Can only call orderMulSig on PayMulSig scripts"
|
||||
PayMulSig keys r -> PayMulSig (sortBy (compare `on` (runPutS . serialize)) keys) r
|
||||
_ -> error "Can only call orderMulSig on PayMulSig scripts"
|
||||
|
||||
-- | Data type describing standard transaction input scripts. Input scripts
|
||||
-- provide the signing data required to unlock the coins of the output they are
|
||||
@ -347,7 +351,7 @@ decodeSimpleInput net (Script ops) =
|
||||
matchPK [op] = SpendPK <$> f op
|
||||
matchPK _ = Nothing
|
||||
matchPKHash [op, OP_PUSHDATA pub _] =
|
||||
SpendPKHash <$> f op <*> eitherToMaybe (decode pub)
|
||||
SpendPKHash <$> f op <*> eitherToMaybe (runGetS deserialize pub)
|
||||
matchPKHash _ = Nothing
|
||||
matchMulSig (x:xs) = do
|
||||
guard $ x == OP_0
|
||||
@ -379,7 +383,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 <=< decode
|
||||
decodeInputBS net = decodeInput net <=< runGetS deserialize
|
||||
|
||||
-- | Encode a standard input into a script.
|
||||
encodeInput :: ScriptInput -> Script
|
||||
@ -391,7 +395,7 @@ encodeInput s = case s of
|
||||
-- | Similar to 'encodeInput' but encodes directly to a serialized script
|
||||
-- 'ByteString'.
|
||||
encodeInputBS :: ScriptInput -> ByteString
|
||||
encodeInputBS = encode . encodeInput
|
||||
encodeInputBS = runPutS . serialize . encodeInput
|
||||
|
||||
-- | Encode a standard 'SimpleInput' into opcodes as an input 'Script'.
|
||||
encodeSimpleInput :: SimpleInput -> Script
|
||||
@ -399,7 +403,7 @@ encodeSimpleInput s =
|
||||
Script $
|
||||
case s of
|
||||
SpendPK ts -> [f ts]
|
||||
SpendPKHash ts p -> [f ts, opPushData $ encode p]
|
||||
SpendPKHash ts p -> [f ts, opPushData $ runPutS $ serialize p]
|
||||
SpendMulSig xs -> OP_0 : map f xs
|
||||
where
|
||||
f TxSignatureEmpty = OP_0
|
||||
|
@ -49,13 +49,15 @@ import Control.Monad (foldM, unless)
|
||||
import Control.Monad.Identity (runIdentity)
|
||||
import Crypto.Secp256k1
|
||||
import qualified Data.ByteString as B
|
||||
import Data.Bytes.Get
|
||||
import Data.Bytes.Put
|
||||
import Data.Bytes.Serial
|
||||
import Data.Conduit (ConduitT, Void, await,
|
||||
runConduit, (.|))
|
||||
import Data.Conduit.List (sourceList)
|
||||
import Data.Either (fromRight)
|
||||
import Data.List (nub)
|
||||
import Data.Maybe (catMaybes, fromJust, isJust)
|
||||
import Data.Serialize (decode, encode)
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Text (Text)
|
||||
import Data.Word (Word64)
|
||||
@ -219,8 +221,20 @@ guessTxSize :: Int -- ^ number of regular transaction inputs
|
||||
guessTxSize pki msi pkout msout =
|
||||
8 + inpLen + inp + outLen + out
|
||||
where
|
||||
inpLen = B.length $ encode $ VarInt $ fromIntegral $ length msi + pki
|
||||
outLen = B.length $ encode $ VarInt $ fromIntegral $ pkout + msout
|
||||
inpLen =
|
||||
B.length .
|
||||
runPutS .
|
||||
serialize .
|
||||
VarInt .
|
||||
fromIntegral $
|
||||
length msi + pki
|
||||
outLen =
|
||||
B.length .
|
||||
runPutS .
|
||||
serialize .
|
||||
VarInt .
|
||||
fromIntegral $
|
||||
pkout + msout
|
||||
inp = pki * 148 + sum (map guessMSSize msi)
|
||||
-- (20: hash160) + (5: opcodes) +
|
||||
-- (1: script len) + (8: Word64)
|
||||
@ -234,12 +248,14 @@ guessTxSize pki msi pkout msout =
|
||||
guessMSSize :: (Int,Int) -> Int
|
||||
guessMSSize (m, n)
|
||||
-- OutPoint (36) + Sequence (4) + Script
|
||||
= 40 + fromIntegral (B.length $ encode $ VarInt $ fromIntegral scp) + scp
|
||||
= 40 +
|
||||
fromIntegral (B.length $ runPutS . serialize $ VarInt $ fromIntegral scp) +
|
||||
scp
|
||||
-- OP_M + n*PubKey + OP_N + OP_CHECKMULTISIG
|
||||
where
|
||||
rdm =
|
||||
fromIntegral $
|
||||
B.length $ encode $ opPushData $ B.replicate (n * 34 + 3) 0
|
||||
B.length $ runPutS $ serialize $ opPushData $ B.replicate (n * 34 + 3) 0
|
||||
-- Redeem + m*sig + OP_0
|
||||
scp = rdm + m * 73 + 1
|
||||
|
||||
@ -414,9 +430,9 @@ verifyStdInput net tx i so0 val
|
||||
wp so = decodeWitnessInput net =<< viewWitnessProgram net so ws
|
||||
|
||||
nestedScriptOutput :: Either String ScriptOutput
|
||||
nestedScriptOutput = scriptOps <$> decode inp >>= \case
|
||||
nestedScriptOutput = scriptOps <$> runGetS deserialize inp >>= \case
|
||||
[OP_PUSHDATA bs _] -> decodeOutputBS bs
|
||||
_ -> Left "nestedScriptOutput: not a nested output"
|
||||
_ -> Left "nestedScriptOutput: not a nested output"
|
||||
|
||||
verifyLegacyInput :: ScriptOutput -> ScriptInput -> Bool
|
||||
verifyLegacyInput so si = case (so, si) of
|
||||
@ -443,7 +459,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 (encode pub) == kh &&
|
||||
addressHash (runPutS (serialize pub)) == kh &&
|
||||
verifyHashSig (theTxSigHash so sh $ Just rdm') sig (pubKeyPoint pub)
|
||||
(PayWitnessScriptHash h, Just rdm'@(PayMulSig pubs r), SpendMulSig sigs) ->
|
||||
payToWitnessScriptAddress rdm' == p2wshAddr h &&
|
||||
|
@ -28,12 +28,14 @@ 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
|
||||
import Data.Either (rights)
|
||||
import Data.Hashable (Hashable)
|
||||
import Data.List (find, nub)
|
||||
import Data.Maybe (catMaybes, fromMaybe, mapMaybe,
|
||||
maybeToList)
|
||||
import qualified Data.Serialize as S
|
||||
import Data.Word (Word64)
|
||||
import GHC.Generics (Generic)
|
||||
import Haskoin.Address (getAddrHash160, pubKeyAddr)
|
||||
@ -125,7 +127,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 = S.encode . opPushData $ encodeOutputBS so'}
|
||||
g so' x = x {scriptInput = runPutS . serialize . opPushData $ encodeOutputBS so'}
|
||||
txis = txIn tx
|
||||
nextTxIn so' si
|
||||
| isSegwit so' && nest = updateIndex i txis (g so')
|
||||
|
@ -31,15 +31,20 @@ module Haskoin.Transaction.Common
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.DeepSeq
|
||||
import Control.Monad (forM_, guard, liftM2, mzero,
|
||||
replicateM, (<=<))
|
||||
replicateM, unless, when, (<=<))
|
||||
import Data.Aeson as A
|
||||
import Data.Aeson.Encoding (unsafeToEncoding)
|
||||
import Data.Binary (Binary (..))
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as B
|
||||
import Data.ByteString.Builder (char7)
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Bytes.Get
|
||||
import Data.Bytes.Put
|
||||
import Data.Bytes.Serial
|
||||
import Data.Hashable (Hashable)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Serialize as S
|
||||
import Data.Serialize (Serialize (..))
|
||||
import Data.String (IsString, fromString)
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Text (Text)
|
||||
@ -52,7 +57,15 @@ import Text.Read as R
|
||||
|
||||
-- | Transaction id: hash of transaction excluding witness data.
|
||||
newtype TxHash = TxHash { getTxHash :: Hash256 }
|
||||
deriving (Eq, Ord, Generic, Hashable, Serialize, NFData)
|
||||
deriving (Eq, Ord, Generic, Hashable, Serial, NFData)
|
||||
|
||||
instance Serialize TxHash where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Binary TxHash where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Show TxHash where
|
||||
showsPrec _ = shows . txHashToHex
|
||||
@ -74,24 +87,28 @@ instance FromJSON TxHash where
|
||||
instance ToJSON TxHash where
|
||||
toJSON = A.String . txHashToHex
|
||||
toEncoding h =
|
||||
unsafeToEncoding $ char7 '"' <> hexBuilder (B.reverse (S.encode h)) <> char7 '"'
|
||||
unsafeToEncoding $
|
||||
char7 '"' <>
|
||||
hexBuilder (BL.reverse (runPutL (serialize h))) <>
|
||||
char7 '"'
|
||||
|
||||
-- | Transaction hash excluding signatures.
|
||||
nosigTxHash :: Tx -> TxHash
|
||||
nosigTxHash tx =
|
||||
TxHash $ doubleSHA256 $ S.encode tx { txIn = map clearInput $ txIn tx }
|
||||
TxHash $ doubleSHA256 $ runPutS $
|
||||
serialize tx { txIn = map clearInput $ txIn tx }
|
||||
where
|
||||
clearInput ti = ti { scriptInput = B.empty }
|
||||
|
||||
-- | Convert transaction hash to hex form, reversing bytes.
|
||||
txHashToHex :: TxHash -> Text
|
||||
txHashToHex (TxHash h) = encodeHex (B.reverse (S.encode h))
|
||||
txHashToHex (TxHash h) = encodeHex (B.reverse (runPutS (serialize h)))
|
||||
|
||||
-- | Convert transaction hash from hex, reversing bytes.
|
||||
hexToTxHash :: Text -> Maybe TxHash
|
||||
hexToTxHash hex = do
|
||||
bs <- B.reverse <$> decodeHex hex
|
||||
h <- either (const Nothing) Just (S.decode bs)
|
||||
h <- either (const Nothing) Just (runGetS deserialize bs)
|
||||
return $ TxHash h
|
||||
|
||||
-- | Witness stack for SegWit transactions.
|
||||
@ -117,36 +134,45 @@ data Tx = Tx
|
||||
|
||||
-- | Compute transaction hash.
|
||||
txHash :: Tx -> TxHash
|
||||
txHash tx = TxHash (doubleSHA256 (S.encode tx {txWitness = []}))
|
||||
txHash tx = TxHash . doubleSHA256 . runPutS $ serialize tx {txWitness = []}
|
||||
|
||||
instance IsString Tx where
|
||||
fromString =
|
||||
fromMaybe e . (eitherToMaybe . S.decode <=< decodeHex) . cs
|
||||
fromMaybe e . (eitherToMaybe . runGetS deserialize <=< decodeHex) . cs
|
||||
where
|
||||
e = error "Could not read transaction from hex string"
|
||||
|
||||
instance Serialize Tx where
|
||||
get = parseWitnessTx <|> parseLegacyTx
|
||||
put tx
|
||||
instance Serial Tx where
|
||||
deserialize =
|
||||
isWitnessTx >>= \w -> if w then parseWitnessTx else parseLegacyTx
|
||||
serialize tx
|
||||
| null (txWitness tx) = putLegacyTx tx
|
||||
| otherwise = putWitnessTx tx
|
||||
|
||||
putInOut :: Tx -> Put
|
||||
instance Binary Tx where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Serialize Tx where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
putInOut :: MonadPut m => Tx -> m ()
|
||||
putInOut tx = do
|
||||
putVarInt $ length (txIn tx)
|
||||
forM_ (txIn tx) put
|
||||
forM_ (txIn tx) serialize
|
||||
putVarInt $ length (txOut tx)
|
||||
forM_ (txOut tx) put
|
||||
forM_ (txOut tx) serialize
|
||||
|
||||
-- | Non-SegWit transaction serializer.
|
||||
putLegacyTx :: Tx -> Put
|
||||
putLegacyTx :: MonadPut m => Tx -> m ()
|
||||
putLegacyTx tx = do
|
||||
putWord32le (txVersion tx)
|
||||
putInOut tx
|
||||
putWord32le (txLockTime tx)
|
||||
|
||||
-- | Witness transaciton serializer.
|
||||
putWitnessTx :: Tx -> Put
|
||||
putWitnessTx :: MonadPut m => Tx -> m ()
|
||||
putWitnessTx tx = do
|
||||
putWord32le (txVersion tx)
|
||||
putWord8 0x00
|
||||
@ -155,49 +181,61 @@ putWitnessTx tx = do
|
||||
putWitnessData (txWitness tx)
|
||||
putWord32le (txLockTime tx)
|
||||
|
||||
isWitnessTx :: MonadGet m => m Bool
|
||||
isWitnessTx = lookAhead $ do
|
||||
_ <- getWord32le
|
||||
m <- getWord8
|
||||
f <- getWord8
|
||||
return (m == 0x00 && f == 0x01)
|
||||
|
||||
-- | Non-SegWit transaction deseralizer.
|
||||
parseLegacyTx :: Get Tx
|
||||
parseLegacyTx :: MonadGet m => m Tx
|
||||
parseLegacyTx = do
|
||||
v <- getWord32le
|
||||
is <- replicateList =<< S.get
|
||||
os <- replicateList =<< S.get
|
||||
is <- replicateList =<< deserialize
|
||||
os <- replicateList =<< deserialize
|
||||
when (length is == 0x00 && length os == 0x01) $ fail "Witness transaction"
|
||||
l <- getWord32le
|
||||
return
|
||||
Tx
|
||||
{txVersion = v, txIn = is, txOut = os, txWitness = [], txLockTime = l}
|
||||
{ txVersion = v
|
||||
, txIn = is
|
||||
, txOut = os
|
||||
, txWitness = []
|
||||
, txLockTime = l
|
||||
}
|
||||
where
|
||||
replicateList (VarInt c) = replicateM (fromIntegral c) S.get
|
||||
replicateList (VarInt c) = replicateM (fromIntegral c) deserialize
|
||||
|
||||
-- | Witness transaction deserializer.
|
||||
parseWitnessTx :: Get Tx
|
||||
parseWitnessTx :: MonadGet m => m Tx
|
||||
parseWitnessTx = do
|
||||
v <- getWord32le
|
||||
m <- getWord8
|
||||
f <- getWord8
|
||||
guard $ m == 0x00
|
||||
guard $ f == 0x01
|
||||
is <- replicateList =<< S.get
|
||||
os <- replicateList =<< S.get
|
||||
unless (m == 0x00 && f == 0x01) $ fail "Not a witness transaction"
|
||||
is <- replicateList =<< deserialize
|
||||
os <- replicateList =<< deserialize
|
||||
w <- parseWitnessData $ length is
|
||||
l <- getWord32le
|
||||
return
|
||||
Tx {txVersion = v, txIn = is, txOut = os, txWitness = w, txLockTime = l}
|
||||
where
|
||||
replicateList (VarInt c) = replicateM (fromIntegral c) S.get
|
||||
replicateList (VarInt c) = replicateM (fromIntegral c) deserialize
|
||||
|
||||
-- | Witness data deserializer. Requires count of inputs.
|
||||
parseWitnessData :: Int -> Get WitnessData
|
||||
parseWitnessData :: MonadGet m => Int -> m WitnessData
|
||||
parseWitnessData n = replicateM n parseWitnessStack
|
||||
where
|
||||
parseWitnessStack = do
|
||||
VarInt i <- S.get
|
||||
VarInt i <- deserialize
|
||||
replicateM (fromIntegral i) parseWitnessStackItem
|
||||
parseWitnessStackItem = do
|
||||
VarInt i <- S.get
|
||||
VarInt i <- deserialize
|
||||
getByteString $ fromIntegral i
|
||||
|
||||
-- | Witness data serializer.
|
||||
putWitnessData :: WitnessData -> Put
|
||||
putWitnessData :: MonadPut m => WitnessData -> m ()
|
||||
putWitnessData = mapM_ putWitnessStack
|
||||
where
|
||||
putWitnessStack ws = do
|
||||
@ -246,18 +284,26 @@ data TxIn =
|
||||
, txInSequence :: !Word32
|
||||
} deriving (Eq, Show, Read, Ord, Generic, Hashable, NFData)
|
||||
|
||||
instance Serialize TxIn where
|
||||
get =
|
||||
TxIn <$> S.get <*> (readBS =<< S.get) <*> getWord32le
|
||||
instance Serial TxIn where
|
||||
deserialize =
|
||||
TxIn <$> deserialize <*> (readBS =<< deserialize) <*> getWord32le
|
||||
where
|
||||
readBS (VarInt len) = getByteString $ fromIntegral len
|
||||
|
||||
put (TxIn o s q) = do
|
||||
put o
|
||||
serialize (TxIn o s q) = do
|
||||
serialize o
|
||||
putVarInt $ B.length s
|
||||
putByteString s
|
||||
putWord32le q
|
||||
|
||||
instance Binary TxIn where
|
||||
get = deserialize
|
||||
put = serialize
|
||||
|
||||
instance Serialize TxIn where
|
||||
get = deserialize
|
||||
put = serialize
|
||||
|
||||
instance FromJSON TxIn where
|
||||
parseJSON =
|
||||
withObject "TxIn" $ \o ->
|
||||
@ -288,17 +334,25 @@ data TxOut =
|
||||
, scriptOutput :: !ByteString
|
||||
} deriving (Eq, Show, Read, Ord, Generic, Hashable, NFData)
|
||||
|
||||
instance Serialize TxOut where
|
||||
get = do
|
||||
instance Serial TxOut where
|
||||
deserialize = do
|
||||
val <- getWord64le
|
||||
(VarInt len) <- S.get
|
||||
VarInt len <- deserialize
|
||||
TxOut val <$> getByteString (fromIntegral len)
|
||||
|
||||
put (TxOut o s) = do
|
||||
serialize (TxOut o s) = do
|
||||
putWord64le o
|
||||
putVarInt $ B.length s
|
||||
putByteString s
|
||||
|
||||
instance Binary TxOut where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Serialize TxOut where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance FromJSON TxOut where
|
||||
parseJSON =
|
||||
withObject "TxOut" $ \o ->
|
||||
@ -319,11 +373,19 @@ data OutPoint = OutPoint
|
||||
, outPointIndex :: !Word32
|
||||
} deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData)
|
||||
|
||||
instance Serialize OutPoint where
|
||||
get = do
|
||||
(h,i) <- liftM2 (,) S.get getWord32le
|
||||
instance Serial OutPoint where
|
||||
deserialize = do
|
||||
(h,i) <- liftM2 (,) deserialize getWord32le
|
||||
return $ OutPoint h i
|
||||
put (OutPoint h i) = put h >> putWord32le i
|
||||
serialize (OutPoint h i) = serialize h >> putWord32le i
|
||||
|
||||
instance Binary OutPoint where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance Serialize OutPoint where
|
||||
put = serialize
|
||||
get = deserialize
|
||||
|
||||
instance FromJSON OutPoint where
|
||||
parseJSON =
|
||||
|
@ -35,12 +35,16 @@ import Control.DeepSeq
|
||||
import Control.Monad (guard, replicateM, void)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as B
|
||||
import Data.Hashable (Hashable)
|
||||
import Data.Bytes.Get (runGetS)
|
||||
import Data.Bytes.Put (runPutS)
|
||||
import Data.Bytes.Serial (Serial (..))
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Hashable (Hashable)
|
||||
import Data.List (foldl')
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
import Data.Serialize as S
|
||||
import Data.Serialize (Get, Put, Serialize)
|
||||
import qualified Data.Serialize as S
|
||||
import GHC.Generics (Generic)
|
||||
import GHC.Word (Word32, Word8)
|
||||
import Haskoin.Address (Address (..), pubKeyAddr)
|
||||
@ -64,7 +68,8 @@ import Haskoin.Util (eitherToMaybe)
|
||||
-- output per output in the unsigned transaction. The inputs and outputs in the
|
||||
-- 'PartiallySignedTransaction' line up by index with the inputs and outputs in
|
||||
-- the unsigned transaction.
|
||||
data PartiallySignedTransaction = PartiallySignedTransaction
|
||||
data PartiallySignedTransaction =
|
||||
PartiallySignedTransaction
|
||||
{ unsignedTransaction :: Tx
|
||||
, globalUnknown :: UnknownMap
|
||||
, inputs :: [Input]
|
||||
@ -100,8 +105,9 @@ data Output = Output
|
||||
|
||||
instance NFData Output
|
||||
|
||||
-- | A map of raw PSBT keys to byte strings for extra data. The 'keyType' field cannot overlap with any of the reserved
|
||||
-- 'keyType' fields specified in the PSBT specification.
|
||||
-- | A map of raw PSBT keys to byte strings for extra data. The 'keyType' field
|
||||
-- cannot overlap with any of the reserved 'keyType' fields specified in the
|
||||
-- PSBT specification.
|
||||
newtype UnknownMap = UnknownMap { unknownMap :: HashMap Key ByteString }
|
||||
deriving (Show, Eq, Semigroup, Monoid, Generic)
|
||||
|
||||
@ -117,8 +123,11 @@ instance NFData Key
|
||||
|
||||
instance Hashable Key
|
||||
|
||||
-- | Take two 'PartiallySignedTransaction's and merge them. The 'unsignedTransaction' field in both must be the same.
|
||||
merge :: PartiallySignedTransaction -> PartiallySignedTransaction -> Maybe PartiallySignedTransaction
|
||||
-- | Take two 'PartiallySignedTransaction's and merge them. The
|
||||
-- 'unsignedTransaction' field in both must be the same.
|
||||
merge :: PartiallySignedTransaction
|
||||
-> PartiallySignedTransaction
|
||||
-> Maybe PartiallySignedTransaction
|
||||
merge psbt1 psbt2
|
||||
| unsignedTransaction psbt1 == unsignedTransaction psbt2
|
||||
= Just $ psbt1
|
||||
@ -130,38 +139,68 @@ merge _ _ = Nothing
|
||||
|
||||
mergeInput :: Input -> Input -> Input
|
||||
mergeInput a b = Input
|
||||
{ nonWitnessUtxo = if isJust witUtx then Nothing else nonWitnessUtxo a <|> nonWitnessUtxo b
|
||||
, witnessUtxo = witUtx
|
||||
, sigHashType = sigHashType a <|> sigHashType b
|
||||
, partialSigs = partialSigs a <> partialSigs b
|
||||
, inputHDKeypaths = inputHDKeypaths a <> inputHDKeypaths b
|
||||
, inputUnknown = inputUnknown a <> inputUnknown b
|
||||
, inputRedeemScript = inputRedeemScript a <|> inputRedeemScript b
|
||||
, inputWitnessScript = inputWitnessScript a <|> inputWitnessScript b
|
||||
, finalScriptSig = finalScriptSig a <|> finalScriptSig b
|
||||
, finalScriptWitness = finalScriptWitness a <|> finalScriptWitness b
|
||||
{ nonWitnessUtxo =
|
||||
if isJust witUtx
|
||||
then Nothing
|
||||
else nonWitnessUtxo a <|> nonWitnessUtxo b
|
||||
, witnessUtxo =
|
||||
witUtx
|
||||
, sigHashType =
|
||||
sigHashType a <|> sigHashType b
|
||||
, partialSigs =
|
||||
partialSigs a <> partialSigs b
|
||||
, inputHDKeypaths =
|
||||
inputHDKeypaths a <> inputHDKeypaths b
|
||||
, inputUnknown =
|
||||
inputUnknown a <> inputUnknown b
|
||||
, inputRedeemScript =
|
||||
inputRedeemScript a <|> inputRedeemScript b
|
||||
, inputWitnessScript =
|
||||
inputWitnessScript a <|> inputWitnessScript b
|
||||
, finalScriptSig =
|
||||
finalScriptSig a <|> finalScriptSig b
|
||||
, finalScriptWitness =
|
||||
finalScriptWitness a <|> finalScriptWitness b
|
||||
}
|
||||
where
|
||||
witUtx = witnessUtxo a <|> witnessUtxo b
|
||||
|
||||
mergeOutput :: Output -> Output -> Output
|
||||
mergeOutput a b = Output
|
||||
{ outputRedeemScript = outputRedeemScript a <|> outputRedeemScript b
|
||||
, outputWitnessScript = outputWitnessScript a <|> outputWitnessScript b
|
||||
, outputHDKeypaths = outputHDKeypaths a <> outputHDKeypaths b
|
||||
, outputUnknown = outputUnknown a <> outputUnknown b
|
||||
{ outputRedeemScript =
|
||||
outputRedeemScript a <|> outputRedeemScript b
|
||||
, outputWitnessScript =
|
||||
outputWitnessScript a <|> outputWitnessScript b
|
||||
, outputHDKeypaths =
|
||||
outputHDKeypaths a <> outputHDKeypaths b
|
||||
, outputUnknown =
|
||||
outputUnknown a <> outputUnknown b
|
||||
}
|
||||
|
||||
-- | Take partial signatures from all of the 'Input's and finalize the signature.
|
||||
complete :: PartiallySignedTransaction -> PartiallySignedTransaction
|
||||
complete psbt = psbt { inputs = map (completeInput . analyzeInputs) (indexed $ inputs psbt) }
|
||||
complete :: PartiallySignedTransaction
|
||||
-> PartiallySignedTransaction
|
||||
complete psbt =
|
||||
psbt
|
||||
{
|
||||
inputs = map
|
||||
(completeInput . analyzeInputs)
|
||||
(indexed $ inputs psbt)
|
||||
}
|
||||
where
|
||||
analyzeInputs (i, input) = (outputScript =<< witnessUtxo input <|> nonWitScript, input)
|
||||
analyzeInputs (i, input) =
|
||||
(,)
|
||||
(outputScript =<< witnessUtxo input <|> nonWitScript)
|
||||
input
|
||||
where
|
||||
nonWitScript = getPrevOut i =<< nonWitnessUtxo input
|
||||
|
||||
getPrevOut i tx =
|
||||
(txOut tx !!?) . fromIntegral . outPointIndex . prevOutput =<< txIn (unsignedTransaction psbt) !!? i
|
||||
(txOut tx !!?) .
|
||||
fromIntegral .
|
||||
outPointIndex .
|
||||
prevOutput =<<
|
||||
txIn (unsignedTransaction psbt) !!? i
|
||||
xs !!? i = lookup i $ indexed xs
|
||||
|
||||
outputScript = eitherToMaybe . decodeOutputBS . scriptOutput
|
||||
@ -173,65 +212,127 @@ complete psbt = psbt { inputs = map (completeInput . analyzeInputs) (indexed $ i
|
||||
indexed = zip [0..]
|
||||
|
||||
completeSig :: Input -> ScriptOutput -> Input
|
||||
|
||||
completeSig input (PayPK k) =
|
||||
input { finalScriptSig = eitherToMaybe . S.decode =<< HashMap.lookup k (partialSigs input) }
|
||||
input
|
||||
{ finalScriptSig =
|
||||
eitherToMaybe . runGetS deserialize =<<
|
||||
HashMap.lookup k (partialSigs input)
|
||||
}
|
||||
|
||||
completeSig input (PayPKHash h)
|
||||
| [(k, sig)] <- HashMap.toList $ partialSigs input
|
||||
, PubKeyAddress h == pubKeyAddr k
|
||||
= input { finalScriptSig = Just $ Script [opPushData sig, opPushData (S.encode k)] }
|
||||
completeSig input (PayMulSig pubKeys m) | length sigs >= m = input { finalScriptSig = finalSig }
|
||||
| [(k, sig)] <- HashMap.toList (partialSigs input)
|
||||
, PubKeyAddress h == pubKeyAddr k =
|
||||
input
|
||||
{
|
||||
finalScriptSig =
|
||||
Just $
|
||||
Script
|
||||
[
|
||||
opPushData sig,
|
||||
opPushData (runPutS (serialize k))
|
||||
]
|
||||
}
|
||||
|
||||
completeSig input (PayMulSig pubKeys m)
|
||||
| length sigs >= m =
|
||||
input { finalScriptSig = finalSig }
|
||||
where
|
||||
sigs = collectSigs m pubKeys input
|
||||
finalSig = Script . (OP_0 :) . (map opPushData sigs <>) . pure . opPushData . S.encode <$> inputRedeemScript input
|
||||
finalSig =
|
||||
Script .
|
||||
(OP_0 :) .
|
||||
(map opPushData sigs <>) .
|
||||
pure . opPushData . runPutS . serialize <$>
|
||||
inputRedeemScript input
|
||||
|
||||
completeSig input (PayScriptHash h)
|
||||
| Just rdmScript <- inputRedeemScript input
|
||||
, PayScriptHash h == toP2SH rdmScript
|
||||
, Right decodedScript <- decodeOutput rdmScript
|
||||
, not (isPayScriptHash decodedScript)
|
||||
= completeSig input decodedScript
|
||||
, not (isPayScriptHash decodedScript) =
|
||||
completeSig input decodedScript
|
||||
|
||||
completeSig input (PayWitnessPKHash h)
|
||||
| [(k, sig)] <- HashMap.toList $ partialSigs input
|
||||
, PubKeyAddress h == pubKeyAddr k
|
||||
= input { finalScriptWitness = Just [sig, S.encode k]
|
||||
, finalScriptSig = Script . pure . opPushData . S.encode <$> inputRedeemScript input
|
||||
| [(k, sig)] <- HashMap.toList (partialSigs input)
|
||||
, PubKeyAddress h == pubKeyAddr k =
|
||||
input
|
||||
{
|
||||
finalScriptWitness =
|
||||
Just [sig, runPutS $ serialize k],
|
||||
finalScriptSig =
|
||||
Script . pure . opPushData . runPutS . serialize <$>
|
||||
inputRedeemScript input
|
||||
}
|
||||
completeSig input (PayWitnessScriptHash h)
|
||||
| Just witScript <- inputWitnessScript input
|
||||
, PayWitnessScriptHash h == toP2WSH witScript
|
||||
, Right decodedScript <- decodeOutput witScript
|
||||
= completeWitnessSig input decodedScript
|
||||
, Right decodedScript <- decodeOutput witScript =
|
||||
completeWitnessSig input decodedScript
|
||||
|
||||
completeSig input _ = input
|
||||
|
||||
completeWitnessSig :: Input -> ScriptOutput -> Input
|
||||
completeWitnessSig input script@(PayMulSig pubKeys m) | length sigs >= m = input
|
||||
{ finalScriptWitness = Just finalWit
|
||||
, finalScriptSig = finalSig
|
||||
}
|
||||
completeWitnessSig input script@(PayMulSig pubKeys m)
|
||||
| length sigs >= m =
|
||||
input
|
||||
{
|
||||
finalScriptWitness = Just finalWit,
|
||||
finalScriptSig = finalSig
|
||||
}
|
||||
where
|
||||
sigs = collectSigs m pubKeys input
|
||||
finalSig = Script . pure . opPushData . S.encode <$> inputRedeemScript input
|
||||
finalSig = Script . pure . opPushData . runPutS . serialize <$>
|
||||
inputRedeemScript input
|
||||
finalWit = mempty : sigs <> [encodeOutputBS script]
|
||||
|
||||
completeWitnessSig input _ = input
|
||||
|
||||
collectSigs :: Int -> [PubKeyI] -> Input -> [ByteString]
|
||||
collectSigs m pubKeys input = take m . reverse $ foldl' lookupKey [] pubKeys
|
||||
collectSigs m pubKeys input =
|
||||
take m . reverse $ foldl' lookupKey [] pubKeys
|
||||
where
|
||||
lookupKey sigs key = maybe sigs (:sigs) $ HashMap.lookup key (partialSigs input)
|
||||
lookupKey sigs key =
|
||||
maybe sigs (: sigs) $
|
||||
HashMap.lookup key (partialSigs input)
|
||||
|
||||
-- | Take a finalized 'PartiallySignedTransaction' and produce the signed final transaction. You may need to call
|
||||
-- 'complete' on the 'PartiallySignedTransaction' before producing the final transaction.
|
||||
-- | Take a finalized 'PartiallySignedTransaction' and produce the signed final
|
||||
-- transaction. You may need to call 'complete' on the
|
||||
-- 'PartiallySignedTransaction' before producing the final transaction.
|
||||
finalTransaction :: PartiallySignedTransaction -> Tx
|
||||
finalTransaction psbt = setInputs . foldl' finalizeInput ([], []) $ zip (txIn tx) (inputs psbt)
|
||||
finalTransaction psbt =
|
||||
setInputs .
|
||||
foldl' finalizeInput ([], []) $
|
||||
zip (txIn tx) (inputs psbt)
|
||||
where
|
||||
tx = unsignedTransaction psbt
|
||||
hasWitness = any (isJust . finalScriptWitness) (inputs psbt)
|
||||
setInputs (ins, witData) = tx { txIn = reverse ins, txWitness = if hasWitness then reverse witData else [] }
|
||||
finalizeInput (ins, witData) (txInput, psbtInput) = maybe finalWitness finalScript $ finalScriptSig psbtInput
|
||||
hasWitness =
|
||||
any
|
||||
(isJust . finalScriptWitness)
|
||||
(inputs psbt)
|
||||
setInputs (ins, witData) =
|
||||
tx
|
||||
{
|
||||
txIn = reverse ins,
|
||||
txWitness = if hasWitness then reverse witData else []
|
||||
}
|
||||
finalizeInput (ins, witData) (txInput, psbtInput) =
|
||||
maybe finalWitness finalScript $
|
||||
finalScriptSig psbtInput
|
||||
where
|
||||
finalScript script = (txInput { scriptInput = encode script }:ins, []:witData)
|
||||
finalWitness = (ins, fromMaybe [] (finalScriptWitness psbtInput):witData)
|
||||
finalScript script =
|
||||
(
|
||||
txInput { scriptInput = runPutS $ serialize script } : ins,
|
||||
[] : witData
|
||||
)
|
||||
finalWitness =
|
||||
(
|
||||
ins,
|
||||
fromMaybe [] (finalScriptWitness psbtInput) : witData
|
||||
)
|
||||
|
||||
-- | Take an unsigned transaction and produce an empty 'PartiallySignedTransaction'
|
||||
-- | Take an unsigned transaction and produce an empty
|
||||
-- 'PartiallySignedTransaction'
|
||||
emptyPSBT :: Tx -> PartiallySignedTransaction
|
||||
emptyPSBT tx = PartiallySignedTransaction
|
||||
{ unsignedTransaction = tx
|
||||
@ -251,120 +352,190 @@ emptyOutput = Output Nothing Nothing HashMap.empty (UnknownMap HashMap.empty)
|
||||
|
||||
instance Serialize PartiallySignedTransaction where
|
||||
get = do
|
||||
magic <- getBytes 4
|
||||
magic <- S.getBytes 4
|
||||
guard $ magic == "psbt"
|
||||
headerSep <- getWord8
|
||||
headerSep <- S.getWord8
|
||||
guard $ headerSep == 0xff
|
||||
|
||||
keySize <- getWord8
|
||||
keySize <- S.getWord8
|
||||
guard $ keySize == 1
|
||||
globalUnsignedTxType <- getWord8
|
||||
globalUnsignedTxType <- S.getWord8
|
||||
guard $ globalUnsignedTxType == 0x00
|
||||
unsignedTransaction <- getSizedBytes
|
||||
unsignedTransaction <- getSizedBytes deserialize
|
||||
guard $ all (B.null . scriptInput) (txIn unsignedTransaction)
|
||||
guard $ null (txWitness unsignedTransaction)
|
||||
|
||||
globalUnknown <- get
|
||||
globalEnd <- getWord8
|
||||
globalUnknown <- S.get
|
||||
globalEnd <- S.getWord8
|
||||
guard $ globalEnd == 0x00
|
||||
|
||||
inputs <- replicateM (length $ txIn unsignedTransaction) get
|
||||
outputs <- replicateM (length $ txOut unsignedTransaction) get
|
||||
inputs <-
|
||||
replicateM
|
||||
(length (txIn unsignedTransaction))
|
||||
S.get
|
||||
outputs <-
|
||||
replicateM
|
||||
(length (txOut unsignedTransaction))
|
||||
S.get
|
||||
|
||||
return PartiallySignedTransaction { unsignedTransaction, globalUnknown, inputs, outputs }
|
||||
return
|
||||
PartiallySignedTransaction
|
||||
{
|
||||
unsignedTransaction,
|
||||
globalUnknown,
|
||||
inputs,
|
||||
outputs
|
||||
}
|
||||
|
||||
put PartiallySignedTransaction{ unsignedTransaction, globalUnknown, inputs, outputs } = do
|
||||
putByteString "psbt"
|
||||
putWord8 0xff -- Header separator
|
||||
put PartiallySignedTransaction
|
||||
{
|
||||
unsignedTransaction,
|
||||
globalUnknown,
|
||||
inputs,
|
||||
outputs
|
||||
} = do
|
||||
S.putByteString "psbt"
|
||||
S.putWord8 0xff -- Header separator
|
||||
|
||||
putWord8 0x01 -- Key size
|
||||
putWord8 0x00 -- Unsigned Transaction type
|
||||
putSizedBytes unsignedTransaction
|
||||
put globalUnknown
|
||||
putWord8 0x00 -- Global end
|
||||
S.putWord8 0x01 -- Key size
|
||||
S.putWord8 0x00 -- Unsigned Transaction type
|
||||
putSizedBytes $ serialize unsignedTransaction
|
||||
S.put globalUnknown
|
||||
S.putWord8 0x00 -- Global end
|
||||
|
||||
mapM_ put inputs
|
||||
mapM_ put outputs
|
||||
mapM_ S.put inputs
|
||||
mapM_ S.put outputs
|
||||
|
||||
instance Serialize Key where
|
||||
get = do
|
||||
VarInt keySize <- get
|
||||
VarInt keySize <- deserialize
|
||||
guard $ keySize > 0
|
||||
t <- getWord8
|
||||
k <- getBytes (fromIntegral keySize - 1)
|
||||
t <- S.getWord8
|
||||
k <- S.getBytes (fromIntegral keySize - 1)
|
||||
return (Key t k)
|
||||
|
||||
put (Key t k) = do
|
||||
putVarInt $ 1 + B.length k
|
||||
putWord8 t
|
||||
putByteString k
|
||||
S.putWord8 t
|
||||
S.putByteString k
|
||||
|
||||
instance Serialize UnknownMap where
|
||||
get = go HashMap.empty
|
||||
where
|
||||
getItem m = do
|
||||
k <- get
|
||||
VarString v <- get
|
||||
k <- S.get
|
||||
VarString v <- deserialize
|
||||
go $ HashMap.insert k v m
|
||||
go m = do
|
||||
isEnd <- lookAhead getWord8
|
||||
isEnd <- S.lookAhead S.getWord8
|
||||
if isEnd == 0x00
|
||||
then return (UnknownMap m)
|
||||
else getItem m
|
||||
|
||||
put (UnknownMap m) = void $ HashMap.traverseWithKey (\k v -> put k >> put (VarString v)) m
|
||||
put (UnknownMap m) =
|
||||
void $
|
||||
HashMap.traverseWithKey
|
||||
(\k v -> S.put k >> serialize (VarString v))
|
||||
m
|
||||
|
||||
instance Serialize Input where
|
||||
get = getMap getInputItem setInputUnknown emptyInput
|
||||
get =
|
||||
getMap getInputItem setInputUnknown emptyInput
|
||||
where
|
||||
setInputUnknown f input = input { inputUnknown = UnknownMap $ f (unknownMap $ inputUnknown input) }
|
||||
setInputUnknown f input =
|
||||
input
|
||||
{
|
||||
inputUnknown =
|
||||
UnknownMap (f (unknownMap (inputUnknown input)))
|
||||
}
|
||||
|
||||
put Input { nonWitnessUtxo, witnessUtxo, partialSigs, sigHashType
|
||||
, inputRedeemScript, inputWitnessScript, inputHDKeypaths
|
||||
, finalScriptSig, finalScriptWitness, inputUnknown
|
||||
} = do
|
||||
whenJust (putKeyValue InNonWitnessUtxo) nonWitnessUtxo
|
||||
whenJust (putKeyValue InWitnessUtxo) witnessUtxo
|
||||
put Input
|
||||
{
|
||||
nonWitnessUtxo,
|
||||
witnessUtxo,
|
||||
partialSigs,
|
||||
sigHashType,
|
||||
inputRedeemScript,
|
||||
inputWitnessScript,
|
||||
inputHDKeypaths,
|
||||
finalScriptSig,
|
||||
finalScriptWitness,
|
||||
inputUnknown
|
||||
} = do
|
||||
whenJust (putKeyValue InNonWitnessUtxo . serialize)
|
||||
nonWitnessUtxo
|
||||
whenJust (putKeyValue InWitnessUtxo . serialize)
|
||||
witnessUtxo
|
||||
putPartialSig partialSigs
|
||||
whenJust putSigHash sigHashType
|
||||
whenJust (putKeyValue InRedeemScript) inputRedeemScript
|
||||
whenJust (putKeyValue InWitnessScript) inputWitnessScript
|
||||
whenJust putSigHash
|
||||
sigHashType
|
||||
whenJust (putKeyValue InRedeemScript . serialize)
|
||||
inputRedeemScript
|
||||
whenJust (putKeyValue InWitnessScript . serialize)
|
||||
inputWitnessScript
|
||||
putHDPath InBIP32Derivation inputHDKeypaths
|
||||
whenJust (putKeyValue InFinalScriptSig) finalScriptSig
|
||||
whenJust (putKeyValue InFinalScriptWitness) finalScriptWitness
|
||||
put inputUnknown
|
||||
putWord8 0x00
|
||||
whenJust (putKeyValue InFinalScriptSig . serialize)
|
||||
finalScriptSig
|
||||
whenJust (putKeyValue InFinalScriptWitness . serialize)
|
||||
finalScriptWitness
|
||||
S.put inputUnknown
|
||||
S.putWord8 0x00
|
||||
where
|
||||
putPartialSig = putPubKeyMap InPartialSig . fmap VarString
|
||||
putPartialSig =
|
||||
putPubKeyMap serialize InPartialSig . fmap VarString
|
||||
putSigHash sigHash = do
|
||||
putKey InSigHashType
|
||||
putWord8 0x04
|
||||
putWord32le (fromIntegral sigHash)
|
||||
S.putWord8 0x04
|
||||
S.putWord32le (fromIntegral sigHash)
|
||||
|
||||
instance Serialize Output where
|
||||
get = getMap getOutputItem setOutputUnknown emptyOutput
|
||||
where
|
||||
setOutputUnknown f output = output { outputUnknown = UnknownMap $ f (unknownMap $ outputUnknown output) }
|
||||
setOutputUnknown f output =
|
||||
output
|
||||
{
|
||||
outputUnknown =
|
||||
UnknownMap (f (unknownMap (outputUnknown output)))
|
||||
}
|
||||
|
||||
put Output{ outputRedeemScript, outputWitnessScript, outputHDKeypaths, outputUnknown } = do
|
||||
whenJust (putKeyValue OutRedeemScript) outputRedeemScript
|
||||
whenJust (putKeyValue OutWitnessScript) outputWitnessScript
|
||||
putHDPath OutBIP32Derivation outputHDKeypaths
|
||||
put outputUnknown
|
||||
putWord8 0x00
|
||||
put Output
|
||||
{
|
||||
outputRedeemScript,
|
||||
outputWitnessScript,
|
||||
outputHDKeypaths,
|
||||
outputUnknown
|
||||
} = do
|
||||
whenJust (putKeyValue OutRedeemScript . serialize)
|
||||
outputRedeemScript
|
||||
whenJust (putKeyValue OutWitnessScript . serialize)
|
||||
outputWitnessScript
|
||||
putHDPath OutBIP32Derivation
|
||||
outputHDKeypaths
|
||||
S.put outputUnknown
|
||||
S.putWord8 0x00
|
||||
|
||||
putSizedBytes :: Serialize a => a -> Put
|
||||
putSizedBytes a = putVarInt (B.length bs) >> putByteString bs
|
||||
where bs = encode a
|
||||
putSizedBytes :: Put -> Put
|
||||
putSizedBytes f = do
|
||||
putVarInt (B.length bs)
|
||||
S.putByteString bs
|
||||
where
|
||||
bs = S.runPut f
|
||||
|
||||
getSizedBytes :: Serialize a => Get a
|
||||
getSizedBytes = getNested (fromIntegral . getVarInt <$> get) get
|
||||
getSizedBytes :: Get a -> Get a
|
||||
getSizedBytes f =
|
||||
S.getNested
|
||||
(fromIntegral . getVarInt <$> deserialize)
|
||||
f
|
||||
|
||||
putKeyValue :: (Enum t, Serialize v) => t -> v -> Put
|
||||
putKeyValue t v = putKey t >> putSizedBytes v
|
||||
putKeyValue :: Enum t => t -> Put -> Put
|
||||
putKeyValue t v = do
|
||||
putKey t
|
||||
putSizedBytes v
|
||||
|
||||
putKey :: Enum t => t -> Put
|
||||
putKey t = putVarInt (1 :: Word8) >> putWord8 (enumWord8 t)
|
||||
putKey t = do
|
||||
putVarInt (1 :: Word8)
|
||||
S.putWord8 (enumWord8 t)
|
||||
|
||||
getMap :: (Bounded t, Enum t)
|
||||
=> (Int -> a -> t -> Get a)
|
||||
@ -372,16 +543,17 @@ getMap :: (Bounded t, Enum t)
|
||||
-> a -> Get a
|
||||
getMap getMapItem setUnknown = go
|
||||
where
|
||||
getItem keySize m (Right t) = getMapItem (fromIntegral keySize - 1) m t >>= go
|
||||
getItem keySize m (Right t) =
|
||||
getMapItem (fromIntegral keySize - 1) m t >>= go
|
||||
getItem keySize m (Left t) = do
|
||||
k <- getBytes (fromIntegral keySize - 1)
|
||||
VarString v <- get
|
||||
k <- S.getBytes (fromIntegral keySize - 1)
|
||||
VarString v <- deserialize
|
||||
go $ setUnknown (HashMap.insert (Key t k) v) m
|
||||
go m = do
|
||||
keySize <- getVarInt <$> get
|
||||
keySize <- getVarInt <$> deserialize
|
||||
if keySize == 0
|
||||
then return m
|
||||
else getItem keySize m =<< (word8Enum <$> getWord8)
|
||||
else getItem keySize m =<< (word8Enum <$> S.getWord8)
|
||||
|
||||
data InputType
|
||||
= InNonWitnessUtxo
|
||||
@ -406,89 +578,124 @@ data OutputType
|
||||
instance NFData OutputType
|
||||
|
||||
getInputItem :: Int -> Input -> InputType -> Get Input
|
||||
|
||||
getInputItem 0 input@Input{nonWitnessUtxo = Nothing} InNonWitnessUtxo = do
|
||||
utxo <- getSizedBytes
|
||||
return $ input { nonWitnessUtxo = Just utxo }
|
||||
utxo <- getSizedBytes deserialize
|
||||
return input { nonWitnessUtxo = Just utxo }
|
||||
|
||||
getInputItem 0 input@Input{witnessUtxo = Nothing} InWitnessUtxo = do
|
||||
utxo <- getSizedBytes
|
||||
return $ input { witnessUtxo = Just utxo }
|
||||
utxo <- getSizedBytes deserialize
|
||||
return input { witnessUtxo = Just utxo }
|
||||
|
||||
getInputItem keySize input InPartialSig = do
|
||||
(k, v) <- getPartialSig
|
||||
return $ input { partialSigs = HashMap.insert k v (partialSigs input) }
|
||||
return
|
||||
input
|
||||
{
|
||||
partialSigs = HashMap.insert k v (partialSigs input)
|
||||
}
|
||||
where
|
||||
getPartialSig = (,) <$> isolate keySize get <*> (getVarString <$> get)
|
||||
getPartialSig =
|
||||
(,)
|
||||
<$> S.isolate keySize deserialize
|
||||
<*> (getVarString <$> deserialize)
|
||||
|
||||
getInputItem 0 input@Input{sigHashType = Nothing} InSigHashType = do
|
||||
VarInt size <- get
|
||||
VarInt size <- deserialize
|
||||
guard $ size == 0x04
|
||||
sigHash <- fromIntegral <$> getWord32le
|
||||
sigHash <- fromIntegral <$> S.getWord32le
|
||||
return $ input { sigHashType = Just sigHash }
|
||||
|
||||
getInputItem 0 input@Input{inputRedeemScript = Nothing} InRedeemScript = do
|
||||
script <- getSizedBytes
|
||||
script <- getSizedBytes deserialize
|
||||
return $ input { inputRedeemScript = Just script }
|
||||
|
||||
getInputItem 0 input@Input{inputWitnessScript = Nothing} InWitnessScript = do
|
||||
script <- getSizedBytes
|
||||
script <- getSizedBytes deserialize
|
||||
return $ input { inputWitnessScript = Just script }
|
||||
|
||||
getInputItem keySize input InBIP32Derivation = do
|
||||
(k, v) <- getHDPath keySize
|
||||
return $ input { inputHDKeypaths = HashMap.insert k v (inputHDKeypaths input) }
|
||||
return
|
||||
input
|
||||
{
|
||||
inputHDKeypaths = HashMap.insert k v (inputHDKeypaths input)
|
||||
}
|
||||
|
||||
getInputItem 0 input@Input{finalScriptSig = Nothing} InFinalScriptSig = do
|
||||
script <- getSizedBytes
|
||||
script <- getSizedBytes deserialize
|
||||
return $ input { finalScriptSig = Just script }
|
||||
|
||||
getInputItem 0 input@Input{finalScriptWitness = Nothing} InFinalScriptWitness = do
|
||||
scripts <- map getVarString <$> getVarIntList
|
||||
return $ input { finalScriptWitness = Just scripts }
|
||||
where
|
||||
getVarIntList = do
|
||||
VarInt n <- get
|
||||
replicateM (fromIntegral n) get
|
||||
VarInt n <- deserialize
|
||||
replicateM (fromIntegral n) deserialize
|
||||
|
||||
getInputItem keySize input inputType = fail $
|
||||
"Incorrect key size for input item or item already existed: " <>
|
||||
show (keySize, input, inputType)
|
||||
|
||||
getOutputItem :: Int -> Output -> OutputType -> Get Output
|
||||
|
||||
getOutputItem 0 output@Output{outputRedeemScript = Nothing} OutRedeemScript = do
|
||||
script <- getSizedBytes
|
||||
script <- getSizedBytes deserialize
|
||||
return $ output { outputRedeemScript = Just script }
|
||||
|
||||
getOutputItem 0 output@Output{outputWitnessScript = Nothing} OutWitnessScript = do
|
||||
script <- getSizedBytes
|
||||
script <- getSizedBytes deserialize
|
||||
return $ output { outputWitnessScript = Just script }
|
||||
|
||||
getOutputItem keySize output OutBIP32Derivation = do
|
||||
(k, v) <- getHDPath keySize
|
||||
return $ output { outputHDKeypaths = HashMap.insert k v (outputHDKeypaths output) }
|
||||
|
||||
getOutputItem keySize output outputType = fail $
|
||||
"Incorrect key size for output item or item already existed: " <>
|
||||
show (keySize, output, outputType)
|
||||
|
||||
getHDPath :: Int -> Get (PubKeyI, (Fingerprint, [KeyIndex]))
|
||||
getHDPath keySize = (,) <$> isolate keySize get <*> (unPSBTHDPath <$> get)
|
||||
getHDPath keySize =
|
||||
(,)
|
||||
<$> S.isolate keySize deserialize
|
||||
<*> (unPSBTHDPath <$> S.get)
|
||||
|
||||
putHDPath :: Enum t => t -> HashMap PubKeyI (Fingerprint, [KeyIndex]) -> Put
|
||||
putHDPath t = putPubKeyMap t . fmap PSBTHDPath
|
||||
putHDPath t = putPubKeyMap S.put t . fmap PSBTHDPath
|
||||
|
||||
newtype PSBTHDPath = PSBTHDPath { unPSBTHDPath :: (Fingerprint, [KeyIndex]) }
|
||||
newtype PSBTHDPath =
|
||||
PSBTHDPath { unPSBTHDPath :: (Fingerprint, [KeyIndex]) }
|
||||
deriving (Show, Eq, Generic)
|
||||
|
||||
instance NFData PSBTHDPath
|
||||
|
||||
instance Serialize PSBTHDPath where
|
||||
get = do
|
||||
VarInt valueSize <- get
|
||||
VarInt valueSize <- deserialize
|
||||
guard $ valueSize `mod` 4 == 0
|
||||
let numIndices = (fromIntegral valueSize - 4) `div` 4
|
||||
PSBTHDPath <$>
|
||||
isolate
|
||||
S.isolate
|
||||
(fromIntegral valueSize)
|
||||
((,) <$> getWord32le <*> getKeyIndexList numIndices)
|
||||
((,) <$> S.getWord32le <*> getKeyIndexList numIndices)
|
||||
where
|
||||
getKeyIndexList n = replicateM n getWord32le
|
||||
put (PSBTHDPath (fp, kis)) = putVarInt (B.length bs) >> putByteString bs
|
||||
where
|
||||
bs = runPut $ putWord32le fp >> mapM_ putWord32le kis
|
||||
getKeyIndexList n = replicateM n S.getWord32le
|
||||
|
||||
putPubKeyMap :: (Serialize a, Enum t) => t -> HashMap PubKeyI a -> Put
|
||||
putPubKeyMap t = void . HashMap.traverseWithKey putItem
|
||||
put (PSBTHDPath (fp, kis)) = do
|
||||
putVarInt (B.length bs)
|
||||
S.putByteString bs
|
||||
where
|
||||
bs = S.runPut $ S.putWord32le fp >> mapM_ S.putWord32le kis
|
||||
|
||||
putPubKeyMap :: Enum t => (a -> Put) -> t -> HashMap PubKeyI a -> Put
|
||||
putPubKeyMap f t =
|
||||
void . HashMap.traverseWithKey putItem
|
||||
where
|
||||
putItem k v = put (Key (enumWord8 t) (encode k)) >> put v
|
||||
putItem k v = do
|
||||
S.put $ Key (enumWord8 t) (runPutS (serialize k))
|
||||
f v
|
||||
|
||||
enumWord8 :: Enum a => a -> Word8
|
||||
enumWord8 = fromIntegral . fromEnum
|
||||
|
@ -30,7 +30,9 @@ module Haskoin.Transaction.Segwit
|
||||
) where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.Serialize as S
|
||||
import Data.Bytes.Get
|
||||
import Data.Bytes.Put
|
||||
import Data.Bytes.Serial
|
||||
import Haskoin.Constants
|
||||
import Haskoin.Keys.Common
|
||||
import Haskoin.Script
|
||||
@ -59,8 +61,8 @@ data WitnessProgram
|
||||
-- @since 0.11.0.0
|
||||
toWitnessStack :: WitnessProgram -> WitnessStack
|
||||
toWitnessStack = \case
|
||||
P2WPKH (WitnessProgramPKH sig key) -> [encodeTxSig sig, S.encode key]
|
||||
P2WSH (WitnessProgramSH stack scr) -> stack <> [S.encode scr]
|
||||
P2WPKH (WitnessProgramPKH sig key) -> [encodeTxSig sig, runPutS (serialize key)]
|
||||
P2WSH (WitnessProgramSH stack scr) -> stack <> [runPutS (serialize scr)]
|
||||
EmptyWitnessProgram -> mempty
|
||||
|
||||
-- | High level representation of a P2WPKH witness
|
||||
@ -89,10 +91,10 @@ viewWitnessProgram ::
|
||||
viewWitnessProgram net so witness = case so of
|
||||
PayWitnessPKHash _ | length witness == 2 -> do
|
||||
sig <- decodeTxSig net $ head witness
|
||||
pubkey <- S.decode $ witness !! 1
|
||||
pubkey <- runGetS deserialize $ witness !! 1
|
||||
return . P2WPKH $ WitnessProgramPKH sig pubkey
|
||||
PayWitnessScriptHash _ | not (null witness) -> do
|
||||
redeemScript <- S.decode $ last witness
|
||||
redeemScript <- runGetS deserialize $ last witness
|
||||
return . P2WSH $ WitnessProgramSH (init witness) redeemScript
|
||||
_ | null witness -> return EmptyWitnessProgram
|
||||
| otherwise -> Left "viewWitnessProgram: Invalid witness program"
|
||||
@ -112,7 +114,7 @@ decodeWitnessInput net = \case
|
||||
(PayPK _, [sigBS]) ->
|
||||
SpendPK <$> decodeTxSig net sigBS
|
||||
(PayPKHash _, [sigBS, keyBS]) ->
|
||||
SpendPKHash <$> decodeTxSig net sigBS <*> S.decode keyBS
|
||||
SpendPKHash <$> decodeTxSig net sigBS <*> runGetS deserialize keyBS
|
||||
(PayMulSig _ _, "" : sigsBS) ->
|
||||
SpendMulSig <$> traverse (decodeTxSig net) sigsBS
|
||||
_ -> Left "decodeWitnessInput: Non-standard script output"
|
||||
@ -138,7 +140,7 @@ calcWitnessProgram so si = case (so, si) of
|
||||
simpleInputStack :: SimpleInput -> [ByteString]
|
||||
simpleInputStack = \case
|
||||
SpendPK sig -> [f sig]
|
||||
SpendPKHash sig k -> [f sig, S.encode k]
|
||||
SpendPKHash sig k -> [f sig, runPutS (serialize k)]
|
||||
SpendMulSig sigs -> "" : fmap f sigs
|
||||
where
|
||||
f TxSignatureEmpty = ""
|
||||
|
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-|
|
||||
Module : Haskoin.Util
|
||||
@ -17,7 +18,9 @@ module Haskoin.Util
|
||||
, integerToBS
|
||||
, hexBuilder
|
||||
, encodeHex
|
||||
, encodeHexLazy
|
||||
, decodeHex
|
||||
, decodeHexLazy
|
||||
, getBits
|
||||
|
||||
-- * Maybe & Either Helpers
|
||||
@ -40,23 +43,43 @@ module Haskoin.Util
|
||||
, dropFieldLabel
|
||||
, dropSumLabels
|
||||
|
||||
-- * Serialization Helpers
|
||||
, putList, getList
|
||||
, putMaybe, getMaybe
|
||||
, putLengthBytes, getLengthBytes
|
||||
, putInteger, getInteger
|
||||
, putInt32be, getInt32be
|
||||
, putInt64be, getInt64be
|
||||
, getIntMap, putIntMap
|
||||
, getTwo, putTwo
|
||||
|
||||
) where
|
||||
|
||||
import Control.Monad (guard)
|
||||
import Control.Monad.Except (ExceptT (..), liftEither)
|
||||
import Data.Aeson.Types (Options (..), SumEncoding (..),
|
||||
defaultOptions, defaultTaggedObject)
|
||||
import Control.Monad
|
||||
import Control.Monad.Except (ExceptT (..), liftEither)
|
||||
import Data.Aeson.Types (Options (..), SumEncoding (..),
|
||||
defaultOptions,
|
||||
defaultTaggedObject)
|
||||
import Data.Bits
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Base16 as B16
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Base16 as B16
|
||||
import Data.ByteString.Builder
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Char (toLower)
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
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.IntMap (IntMap)
|
||||
import qualified Data.IntMap as IntMap
|
||||
import Data.List
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text.Encoding as E
|
||||
import Data.Word (Word8)
|
||||
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
|
||||
|
||||
-- ByteString helpers
|
||||
|
||||
@ -76,22 +99,22 @@ integerToBS i
|
||||
f 0 = Nothing
|
||||
f x = Just (fromInteger x :: Word8, x `shiftR` 8)
|
||||
|
||||
hexBuilder :: ByteString -> Builder
|
||||
hexBuilder = byteStringHex
|
||||
hexBuilder :: BL.ByteString -> Builder
|
||||
hexBuilder = lazyByteStringHex
|
||||
|
||||
encodeHex :: ByteString -> Text
|
||||
encodeHex = B16.encodeBase16
|
||||
|
||||
-- | Encode as string of human-readable hex characters.
|
||||
encodeHex :: ByteString -> Text
|
||||
encodeHex = E.decodeUtf8 . BL.toStrict . toLazyByteString . byteStringHex
|
||||
encodeHexLazy :: BL.ByteString -> TL.Text
|
||||
encodeHexLazy = BL16.encodeBase16
|
||||
|
||||
decodeHex :: Text -> Maybe ByteString
|
||||
decodeHex = eitherToMaybe . B16.decodeBase16 . E.encodeUtf8
|
||||
|
||||
-- | Decode string of human-readable hex characters.
|
||||
decodeHex :: Text -> Maybe ByteString
|
||||
# if MIN_VERSION_base16_bytestring(1,0,0)
|
||||
decodeHex = eitherToMaybe . B16.decode . E.encodeUtf8
|
||||
# else
|
||||
decodeHex text =
|
||||
let (x, b) = B16.decode (E.encodeUtf8 text)
|
||||
in guard (b == BS.empty) >> return x
|
||||
# endif
|
||||
decodeHexLazy :: TL.Text -> Maybe BL.ByteString
|
||||
decodeHexLazy = eitherToMaybe . BL16.decodeBase16 . EL.encodeUtf8
|
||||
|
||||
-- | Obtain 'Int' bits from beginning of 'ByteString'. Resulting 'ByteString'
|
||||
-- will be smallest required to hold that many bits, padded with zeroes to the
|
||||
@ -205,3 +228,125 @@ convertBits pad frombits tobits i = (reverse yout, rem')
|
||||
out' = ((acc `shiftR` bits') .&. maxv) : out
|
||||
in inner acc out' bits'
|
||||
| otherwise = (out, bits)
|
||||
|
||||
--
|
||||
-- Serialization helpers
|
||||
--
|
||||
|
||||
putInt32be :: MonadPut m => Int32 -> m ()
|
||||
putInt32be n
|
||||
| n < 0 = putWord32be (complement (fromIntegral (abs n)) + 1)
|
||||
| otherwise = putWord32be (fromIntegral (abs n))
|
||||
|
||||
getInt32be :: MonadGet m => m Int32
|
||||
getInt32be = do
|
||||
n <- getWord32be
|
||||
if testBit n 31
|
||||
then return (negate (complement (fromIntegral n) + 1))
|
||||
else return (fromIntegral n)
|
||||
|
||||
putInt64be :: MonadPut m => Int64 -> m ()
|
||||
putInt64be n
|
||||
| n < 0 = putWord64be (complement (fromIntegral (abs n)) + 1)
|
||||
| otherwise = putWord64be (fromIntegral (abs n))
|
||||
|
||||
getInt64be :: MonadGet m => m Int64
|
||||
getInt64be = do
|
||||
n <- getWord64be
|
||||
if testBit n 63
|
||||
then return (negate (complement (fromIntegral n) + 1))
|
||||
else return (fromIntegral n)
|
||||
|
||||
putInteger :: MonadPut m => Integer -> m ()
|
||||
putInteger n
|
||||
| n >= lo && n <= hi = do
|
||||
putWord8 0x00
|
||||
putInt32be (fromIntegral n)
|
||||
| otherwise = do
|
||||
putWord8 0x01
|
||||
putWord8 (fromIntegral (signum n))
|
||||
let len = (nrBits (abs n) + 7) `div` 8
|
||||
putWord64be (fromIntegral len)
|
||||
mapM_ putWord8 (unroll (abs n))
|
||||
where
|
||||
lo = fromIntegral (minBound :: Int32)
|
||||
hi = fromIntegral (maxBound :: Int32)
|
||||
|
||||
getInteger :: MonadGet m => m Integer
|
||||
getInteger =
|
||||
getWord8 >>= \case
|
||||
0 -> fromIntegral <$> getInt32be
|
||||
_ -> do
|
||||
sign <- getWord8
|
||||
bytes <- getList 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
|
||||
|
||||
getMaybe :: MonadGet m => m a -> m (Maybe a)
|
||||
getMaybe f =
|
||||
getWord8 >>= \case
|
||||
0x00 -> return Nothing
|
||||
0x01 -> Just <$> f
|
||||
_ -> fail "Not a Maybe"
|
||||
|
||||
putLengthBytes :: MonadPut m => ByteString -> m ()
|
||||
putLengthBytes bs = do
|
||||
putWord64be (fromIntegral (BS.length bs))
|
||||
putByteString bs
|
||||
|
||||
getLengthBytes :: MonadGet m => m ByteString
|
||||
getLengthBytes = do
|
||||
len <- fromIntegral <$> getWord64be
|
||||
getByteString len
|
||||
|
||||
--
|
||||
-- Fold and unfold an Integer to and from a list of its bytes
|
||||
--
|
||||
unroll :: (Integral a, Bits a) => a -> [Word8]
|
||||
unroll = unfoldr step
|
||||
where
|
||||
step 0 = Nothing
|
||||
step i = Just (fromIntegral i, i `shiftR` 8)
|
||||
|
||||
roll :: (Integral a, Bits a) => [Word8] -> a
|
||||
roll = foldr unstep 0
|
||||
where
|
||||
unstep b a = a `shiftL` 8 .|. fromIntegral b
|
||||
|
||||
nrBits :: (Ord a, Integral a) => a -> Int
|
||||
nrBits k =
|
||||
let expMax = until (\e -> 2 ^ e > k) (* 2) 1
|
||||
findNr :: Int -> Int -> Int
|
||||
findNr lo hi
|
||||
| mid == lo = hi
|
||||
| 2 ^ mid <= k = findNr mid hi
|
||||
| 2 ^ mid > k = findNr lo mid
|
||||
where mid = (lo + hi) `div` 2
|
||||
in findNr (expMax `div` 2) expMax
|
||||
|
||||
-- | Read as a list of pairs of int and element.
|
||||
getIntMap :: MonadGet m => m Int -> m a -> m (IntMap a)
|
||||
getIntMap i m = IntMap.fromList <$> getList (getTwo i m)
|
||||
|
||||
putIntMap :: MonadPut m => (Int -> m ()) -> (a -> m ()) -> IntMap a -> m ()
|
||||
putIntMap f g = putList (putTwo f g) . IntMap.toAscList
|
||||
|
||||
putTwo :: MonadPut m => (a -> m ()) -> (b -> m ()) -> (a, b) -> m ()
|
||||
putTwo f g (x, y) = f x >> g y
|
||||
|
||||
getTwo :: MonadGet m => m a -> m b -> m (a, b)
|
||||
getTwo f g = (,) <$> f <*> g
|
||||
|
||||
putList :: MonadPut m => (a -> m ()) -> [a] -> m ()
|
||||
putList f ls = do
|
||||
putWord64be (fromIntegral (length ls))
|
||||
mapM_ f ls
|
||||
|
||||
getList :: MonadGet m => m a -> m [a]
|
||||
getList f = do
|
||||
l <- fromIntegral <$> getWord64be
|
||||
replicateM l f
|
||||
|
@ -274,7 +274,7 @@ arbitraryWSHOutput = PayWitnessScriptHash <$> arbitraryHash256
|
||||
|
||||
arbitraryWitOutput :: Gen ScriptOutput
|
||||
arbitraryWitOutput = do
|
||||
ver <- choose (0, 16)
|
||||
ver <- choose (1, 16)
|
||||
len <- choose (2, 40)
|
||||
ws <- vectorOf len arbitrary
|
||||
let bs = B.pack ws
|
||||
|
@ -32,23 +32,24 @@ module Haskoin.Util.Arbitrary.Util
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad (forM_, (<=<))
|
||||
import qualified Data.Aeson as A
|
||||
import qualified Data.Aeson.Encoding as A
|
||||
import qualified Data.Aeson.Types as A
|
||||
import Data.ByteString (ByteString, pack)
|
||||
import qualified Data.ByteString.Short as BSS
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Control.Monad (forM_, (<=<))
|
||||
import qualified Data.Aeson as A
|
||||
import qualified Data.Aeson.Encoding as A
|
||||
import qualified Data.Aeson.Types as A
|
||||
import Data.ByteString (ByteString, pack)
|
||||
import qualified Data.ByteString.Short as BSS
|
||||
import Data.Bytes.Get
|
||||
import Data.Bytes.Put
|
||||
import Data.Bytes.Serial
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Proxy
|
||||
import qualified Data.Serialize as S
|
||||
import Data.Time.Clock (UTCTime (..))
|
||||
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
|
||||
import qualified Data.Typeable as T
|
||||
import Data.Word (Word32)
|
||||
import Data.Time.Clock (UTCTime (..))
|
||||
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
|
||||
import qualified Data.Typeable as T
|
||||
import Data.Word (Word32)
|
||||
import Haskoin.Constants
|
||||
import Test.Hspec (Spec, describe, shouldBe,
|
||||
shouldSatisfy)
|
||||
import Test.Hspec.QuickCheck (prop)
|
||||
import Test.Hspec (Spec, describe, shouldBe, shouldSatisfy)
|
||||
import Test.Hspec.QuickCheck (prop)
|
||||
import Test.QuickCheck
|
||||
|
||||
-- | Arbitrary strict 'ByteString'.
|
||||
@ -94,7 +95,7 @@ arbitraryNetwork = elements allNets
|
||||
-- Helpers for creating Serial and JSON Identity tests
|
||||
|
||||
data SerialBox =
|
||||
forall a. (Show a, Eq a, T.Typeable a, S.Serialize a) =>
|
||||
forall a. (Show a, Eq a, T.Typeable a, Serial a) =>
|
||||
SerialBox (Gen a)
|
||||
|
||||
data ReadBox =
|
||||
@ -115,7 +116,7 @@ data NetBox =
|
||||
|
||||
testIdentity :: [SerialBox] -> [ReadBox] -> [JsonBox] -> [NetBox] -> Spec
|
||||
testIdentity serialVals readVals jsonVals netVals = do
|
||||
describe "Data.Serialize Encoding" $
|
||||
describe "Binary Encoding" $
|
||||
forM_ serialVals $ \(SerialBox g) -> testSerial g
|
||||
describe "Read/Show Encoding" $
|
||||
forM_ readVals $ \(ReadBox g) -> testRead g
|
||||
@ -124,12 +125,13 @@ testIdentity serialVals readVals jsonVals netVals = do
|
||||
describe "Data.Aeson Encoding with Network" $
|
||||
forM_ netVals $ \(NetBox (j,e,p,g)) -> testNetJson j e p g
|
||||
|
||||
-- | Generate Data.Serialize identity tests
|
||||
-- | Generate binary identity tests
|
||||
testSerial ::
|
||||
(Eq a, Show a, T.Typeable a, S.Serialize a) => Gen a -> Spec
|
||||
(Eq a, Show a, T.Typeable a, Serial a) => Gen a -> Spec
|
||||
testSerial gen =
|
||||
prop ("Data.Serialize encoding/decoding identity for " <> name) $
|
||||
forAll gen $ \x -> (S.decode . S.encode) x `shouldBe` Right x
|
||||
prop ("Binary encoding/decoding identity for " <> name) $
|
||||
forAll gen $ \x ->
|
||||
(runGetS deserialize . runPutS . serialize) x `shouldBe` Right x
|
||||
where
|
||||
name = show $ T.typeRep $ proxy gen
|
||||
proxy :: Gen a -> Proxy a
|
||||
|
@ -1,7 +1,5 @@
|
||||
resolver: lts-16.24
|
||||
resolver: lts-17.4
|
||||
nix:
|
||||
packages:
|
||||
- secp256k1
|
||||
- pkg-config
|
||||
extra-deps:
|
||||
- secp256k1-haskell-0.5.0
|
||||
|
@ -3,17 +3,10 @@
|
||||
# For more information, please see the documentation at:
|
||||
# https://docs.haskellstack.org/en/stable/lock_files
|
||||
|
||||
packages:
|
||||
- completed:
|
||||
hackage: secp256k1-haskell-0.5.0@sha256:26d8897b0b81a1ca46134e3b1cc7784c975880e2334936d92681b07ae9703c26,2158
|
||||
pantry-tree:
|
||||
size: 599
|
||||
sha256: e1e0b1d98213c7874a4260b946d1024571ac659e81822d51ea1df7d00f4c14b0
|
||||
original:
|
||||
hackage: secp256k1-haskell-0.5.0
|
||||
packages: []
|
||||
snapshots:
|
||||
- completed:
|
||||
size: 532835
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/24.yaml
|
||||
sha256: cf2b52420b2262fe9cf0f6744929120131abd6675b1c3fb2d8b155a47f80d103
|
||||
original: lts-16.24
|
||||
size: 563103
|
||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/4.yaml
|
||||
sha256: f11e2153044f5f71ea7b1c9398f4721f517c9bd37642ed769647b896564021f3
|
||||
original: lts-17.4
|
||||
|
@ -7,8 +7,10 @@ import Data.ByteString.Builder
|
||||
import qualified Data.ByteString.Char8 as C
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
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.Serialize as S
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions
|
||||
import Data.Text (Text)
|
||||
@ -17,15 +19,14 @@ import Haskoin.Block
|
||||
import Haskoin.Crypto
|
||||
import Haskoin.Util
|
||||
import Haskoin.Util.Arbitrary
|
||||
import Test.HUnit
|
||||
import Test.Hspec
|
||||
import Test.Hspec.QuickCheck
|
||||
import Test.HUnit
|
||||
import Test.QuickCheck
|
||||
|
||||
serialVals :: [SerialBox]
|
||||
serialVals =
|
||||
[ SerialBox arbitraryBS
|
||||
, SerialBox arbitraryBSS
|
||||
, SerialBox arbitraryHash160
|
||||
, SerialBox arbitraryHash256
|
||||
, SerialBox arbitraryHash512
|
||||
@ -50,13 +51,13 @@ spec =
|
||||
prop "decodeCompact . encodeCompact i == i" decEncCompact
|
||||
prop "from string Hash512" $
|
||||
forAll arbitraryHash512 $ \h ->
|
||||
fromString (cs $ encodeHex $ encode h) == h
|
||||
fromString (cs $ encodeHex $ runPutS $ serialize h) == h
|
||||
prop "from string Hash256" $
|
||||
forAll arbitraryHash256 $ \h ->
|
||||
fromString (cs $ encodeHex $ encode h) == h
|
||||
fromString (cs $ encodeHex $ runPutS $ serialize h) == h
|
||||
prop "from string Hash160" $
|
||||
forAll arbitraryHash160 $ \h ->
|
||||
fromString (cs $ encodeHex $ encode h) == h
|
||||
fromString (cs $ encodeHex $ runPutS $ serialize h) == h
|
||||
describe "Test Vectors" $ do
|
||||
it "Passes RIPEMD160 test vectors" $
|
||||
mapM_ (testVector ripemd160 getHash160) ripemd160Vectors
|
||||
|
@ -6,9 +6,11 @@ import Control.Monad (forM_)
|
||||
import Data.Aeson as A
|
||||
import Data.Bits ((.&.))
|
||||
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.Serialize as S
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Text (Text)
|
||||
@ -19,9 +21,9 @@ import Haskoin.Keys
|
||||
import Haskoin.Util
|
||||
import Haskoin.Util.Arbitrary
|
||||
import Haskoin.UtilSpec (customCerealID)
|
||||
import Test.HUnit (Assertion, assertBool, assertEqual)
|
||||
import Test.Hspec
|
||||
import Test.Hspec.QuickCheck
|
||||
import Test.HUnit (Assertion, assertBool, assertEqual)
|
||||
import Test.QuickCheck hiding ((.&.))
|
||||
|
||||
serialVals :: [SerialBox]
|
||||
@ -309,8 +311,8 @@ vectorSpec mTxt vecTxt =
|
||||
|
||||
runVector :: XPrvKey -> TestVector -> Assertion
|
||||
runVector m v = do
|
||||
assertBool "xPrvID" $ encodeHex (S.encode $ xPrvID m) == v !! 0
|
||||
assertBool "xPrvFP" $ encodeHex (S.encode $ xPrvFP m) == v !! 1
|
||||
assertBool "xPrvID" $ encodeHex (runPutS . serialize $ xPrvID m) == v !! 0
|
||||
assertBool "xPrvFP" $ encodeHex (runPutS . serialize $ xPrvFP m) == v !! 1
|
||||
assertBool "xPrvAddr" $
|
||||
addrToText btc (xPubAddr $ deriveXPubKey m) == Just (v !! 2)
|
||||
assertBool "bip44Addr" $
|
||||
@ -320,18 +322,18 @@ 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 (S.encode $ xPrvChain m) == v !! 7
|
||||
assertBool "chain code" $ encodeHex (runPutS . serialize $ xPrvChain m) == v !! 7
|
||||
assertBool "Hex PubKey" $
|
||||
encodeHex (runPut $ putXPubKey btc $ deriveXPubKey m) == v !! 8
|
||||
assertBool "Hex PrvKey" $ encodeHex (runPut (putXPrvKey btc m)) == v !! 9
|
||||
encodeHex (runPutS $ putXPubKey btc $ deriveXPubKey m) == v !! 8
|
||||
assertBool "Hex PrvKey" $ encodeHex (runPutS (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 (S.encode $ xPrvID m))
|
||||
, ("xPrvFP", encodeHex (S.encode $ xPrvFP m))
|
||||
[ ("xPrvID", encodeHex (runPutS . serialize $ xPrvID m))
|
||||
, ("xPrvFP", encodeHex (runPutS . serialize $ xPrvFP m))
|
||||
, ("xPrvAddr", fromJust $ addrToText btc (xPubAddr $ deriveXPubKey m))
|
||||
, ( "bip44Addr"
|
||||
, fromJust $
|
||||
@ -339,9 +341,9 @@ genVector m =
|
||||
, ("prvKey", encodeHex (getSecKey $ xPrvKey m))
|
||||
, ("xPrvWIF", xPrvWif btc m)
|
||||
, ("pubKey", encodeHex (exportPubKey True $ xPubKey $ deriveXPubKey m))
|
||||
, ("chain code", encodeHex (S.encode $ xPrvChain m))
|
||||
, ("Hex PubKey", encodeHex (runPut $ putXPubKey btc $ deriveXPubKey m))
|
||||
, ("Hex PrvKey", encodeHex (runPut (putXPrvKey btc 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)]
|
||||
|
@ -7,8 +7,11 @@ import Data.Aeson as A
|
||||
import Data.Aeson.Lens
|
||||
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 Data.Serialize as S
|
||||
import qualified Data.Serialize as S
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Text (Text)
|
||||
@ -20,15 +23,14 @@ import Haskoin.Script
|
||||
import Haskoin.Util
|
||||
import Haskoin.Util.Arbitrary
|
||||
import Haskoin.UtilSpec (readTestFile)
|
||||
import Test.HUnit
|
||||
import Test.Hspec
|
||||
import Test.Hspec.QuickCheck
|
||||
import Test.HUnit
|
||||
import Test.QuickCheck
|
||||
|
||||
serialVals :: [SerialBox]
|
||||
serialVals =
|
||||
[ SerialBox (arbitrary :: Gen SecKey)
|
||||
, SerialBox (snd <$> arbitraryKeyPair) -- PubKeyI
|
||||
[ SerialBox (snd <$> arbitraryKeyPair) -- PubKeyI
|
||||
]
|
||||
|
||||
readVals :: [ReadBox]
|
||||
@ -51,7 +53,7 @@ spec = do
|
||||
forAll arbitraryKeyPair (isCanonicalPubKey . snd)
|
||||
prop "Public key fromString identity" $
|
||||
forAll arbitraryKeyPair $ \(_, k) ->
|
||||
fromString (cs . encodeHex $ S.encode k) == k
|
||||
fromString (cs . encodeHex $ runPutS $ serialize k) == k
|
||||
describe "SecKey properties" $
|
||||
prop "fromWif . toWif identity" $
|
||||
forAll arbitraryNetwork $ \net ->
|
||||
@ -88,13 +90,13 @@ isCanonicalPubKey p = not $
|
||||
-- Non-canonical public key: compressed nor uncompressed
|
||||
(BS.index bs 0 `notElem` [2,3,4])
|
||||
where
|
||||
bs = S.encode p
|
||||
bs = runPutS $ serialize p
|
||||
|
||||
testMiniKey :: Assertion
|
||||
testMiniKey =
|
||||
assertEqual "fromMiniKey" (Just res) (go "S6c56bnXQiBjk9mqSYE7ykVQ7NzrRy")
|
||||
where
|
||||
go = fmap (encodeHex . S.encode . secKeyData) . fromMiniKey
|
||||
go = fmap (encodeHex . runPutS . S.put . secKeyData) . fromMiniKey
|
||||
res = "4c7a9640c72dc2099f23715d0c8a0d8a35f8906e3cab61dd3f78b67bf887c9ab"
|
||||
|
||||
-- Test vectors from:
|
||||
@ -107,14 +109,14 @@ testKeyIOValidVector (a, payload, obj)
|
||||
-- Test from WIF to SecKey
|
||||
let isComp = obj ^?! key "isCompressed" . _Bool
|
||||
prvKeyM = fromWif net a
|
||||
prvKeyHexM = encodeHex . S.encode . secKeyData <$> prvKeyM
|
||||
prvKeyHexM = encodeHex . runPutS . S.put . 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 . S.decode =<< decodeHex payload
|
||||
let secM = eitherToMaybe . runGetS S.get =<< decodeHex payload
|
||||
wifM = toWif net . wrapSecKey isComp <$> secM
|
||||
assertEqual "Payload matches WIF" (Just a) wifM
|
||||
| otherwise = do
|
||||
@ -124,7 +126,9 @@ 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 . S.decode =<< decodeHex a :: Maybe SecKey
|
||||
pubAsSecM =
|
||||
eitherToMaybe . runGetS S.get =<<
|
||||
decodeHex a :: Maybe SecKey
|
||||
assertBool "Address is invalid Wif" $ isNothing pubAsWifM
|
||||
assertBool "Address is invalid PrvKey" $ isNothing pubAsSecM
|
||||
-- Test Script to Addr
|
||||
@ -145,7 +149,7 @@ testKeyIOValidVector (a, payload, obj)
|
||||
testKeyIOInvalidVector :: [Text] -> Assertion
|
||||
testKeyIOInvalidVector [a] = do
|
||||
let wifMs = (`fromWif` a) <$> allNets
|
||||
secKeyM = (eitherToMaybe . S.decode <=< decodeHex) a :: Maybe SecKey
|
||||
secKeyM = (eitherToMaybe . runGetS S.get <=< 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
|
||||
|
@ -1,8 +1,10 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Haskoin.NetworkSpec (spec) where
|
||||
|
||||
import Data.Bytes.Get
|
||||
import Data.Bytes.Put
|
||||
import Data.Bytes.Serial
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Serialize as S
|
||||
import Data.Text (Text)
|
||||
import Data.Word (Word32)
|
||||
import Haskoin.Address
|
||||
@ -13,9 +15,9 @@ import Haskoin.Transaction
|
||||
import Haskoin.Util
|
||||
import Haskoin.Util.Arbitrary
|
||||
import Haskoin.UtilSpec (customCerealID)
|
||||
import Test.HUnit (Assertion, assertBool, assertEqual)
|
||||
import Test.Hspec
|
||||
import Test.Hspec.QuickCheck
|
||||
import Test.HUnit (Assertion, assertBool, assertEqual)
|
||||
import Test.QuickCheck
|
||||
|
||||
serialVals :: [SerialBox]
|
||||
@ -67,7 +69,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" $
|
||||
S.encode f4 == bs
|
||||
runPutS (serialize f4) == bs
|
||||
where
|
||||
f0 = bloomCreate 3 0.01 n BloomUpdateAll
|
||||
f1 = bloomInsert f0 v1
|
||||
@ -88,11 +90,11 @@ bloomFilter2 = bloomFilter 2147483649 "03ce4299050000000100008001"
|
||||
bloomFilter3 :: Assertion
|
||||
bloomFilter3 =
|
||||
assertBool "Bloom filter serialization is incorrect" $
|
||||
S.encode f2 == bs
|
||||
runPutS (serialize f2) == bs
|
||||
where
|
||||
f0 = bloomCreate 2 0.001 0 BloomUpdateAll
|
||||
f1 = bloomInsert f0 $ S.encode p
|
||||
f2 = bloomInsert f1 $ S.encode $ getAddrHash160 $ pubKeyAddr p
|
||||
f1 = bloomInsert f0 $ runPutS $ serialize p
|
||||
f2 = bloomInsert f1 $ runPutS $ serialize $ getAddrHash160 $ pubKeyAddr p
|
||||
k = fromJust $ fromWif btc "5Kg1gnAjaLfKiwhhPpGS3QfRg2m6awQvaj98JCZBZQ5SuS2F15C"
|
||||
p = derivePubKeyI k
|
||||
bs = fromJust $ decodeHex "038fc16b080000000000000001"
|
||||
@ -105,7 +107,7 @@ relevantOutputUpdated = assertBool "Bloom filter output updated" $
|
||||
relevantOutputHash = fromJust $ decodeHex"03f47604ea2736334151081e13265b4fe38e6fa8"
|
||||
bf1 = bloomInsert bf0 relevantOutputHash
|
||||
bf2 = fromJust $ bloomRelevantUpdate bf1 relevantTx
|
||||
spendTxInput = encode .prevOutput <$> txIn spendRelevantTx
|
||||
spendTxInput = runPutS . serialize . prevOutput <$> txIn spendRelevantTx
|
||||
|
||||
irrelevantOutputNotUpdated :: Assertion
|
||||
irrelevantOutputNotUpdated = assertEqual "Bloom filter not updated" Nothing bf2
|
||||
|
@ -5,10 +5,12 @@ import Control.Monad
|
||||
import Data.Aeson as A
|
||||
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.Serialize as S
|
||||
import Data.String
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Text (Text)
|
||||
@ -21,9 +23,9 @@ import Haskoin.Transaction
|
||||
import Haskoin.Util
|
||||
import Haskoin.Util.Arbitrary
|
||||
import Haskoin.UtilSpec (readTestFile)
|
||||
import Test.HUnit as HUnit
|
||||
import Test.Hspec
|
||||
import Test.Hspec.QuickCheck
|
||||
import Test.HUnit as HUnit
|
||||
import Test.QuickCheck
|
||||
import Text.Read
|
||||
|
||||
@ -89,21 +91,26 @@ standardSpec net = do
|
||||
decodeInput net (encodeInput si) `shouldBe` Right si
|
||||
prop "can sort multisig scripts" $
|
||||
forAll arbitraryMSOutput $ \out ->
|
||||
map S.encode (getOutputMulSigKeys (sortMulSig out)) `shouldSatisfy` \xs ->
|
||||
xs == sort xs
|
||||
map
|
||||
(runPutS . serialize)
|
||||
(getOutputMulSigKeys (sortMulSig out))
|
||||
`shouldSatisfy`
|
||||
\xs -> xs == sort xs
|
||||
it "can decode inputs with empty signatures" $ do
|
||||
decodeInput net (Script [OP_0]) `shouldBe`
|
||||
Right (RegularInput (SpendPK TxSignatureEmpty))
|
||||
decodeInput net (Script [opPushData ""]) `shouldBe`
|
||||
Right (RegularInput (SpendPK TxSignatureEmpty))
|
||||
let pk =
|
||||
derivePubKeyI $
|
||||
wrapSecKey True $ fromJust $ secKey $ B.replicate 32 1
|
||||
decodeInput net (Script [OP_0, opPushData $ S.encode pk]) `shouldBe`
|
||||
let pk = derivePubKeyI $
|
||||
wrapSecKey True $ fromJust $ secKey $ B.replicate 32 1
|
||||
decodeInput net (Script [OP_0, opPushData $ runPutS $ serialize pk])
|
||||
`shouldBe`
|
||||
Right (RegularInput (SpendPKHash TxSignatureEmpty pk))
|
||||
decodeInput net (Script [OP_0, OP_0]) `shouldBe`
|
||||
decodeInput net (Script [OP_0, OP_0])
|
||||
`shouldBe`
|
||||
Right (RegularInput (SpendMulSig [TxSignatureEmpty]))
|
||||
decodeInput net (Script [OP_0, OP_0, OP_0, OP_0]) `shouldBe`
|
||||
decodeInput net (Script [OP_0, OP_0, OP_0, OP_0])
|
||||
`shouldBe`
|
||||
Right (RegularInput (SpendMulSig $ replicate 3 TxSignatureEmpty))
|
||||
|
||||
scriptSpec :: Network -> Spec
|
||||
@ -189,7 +196,7 @@ creditTx scriptPubKey val =
|
||||
txI =
|
||||
TxIn
|
||||
{ prevOutput = nullOutPoint
|
||||
, scriptInput = S.encode $ Script [OP_0, OP_0]
|
||||
, scriptInput = runPutS $ serialize $ Script [OP_0, OP_0]
|
||||
, txInSequence = maxBound
|
||||
}
|
||||
|
||||
@ -216,7 +223,7 @@ parseScript str =
|
||||
|
||||
replaceToken :: String -> String
|
||||
replaceToken str = case readMaybe $ "OP_" <> str of
|
||||
Just opcode -> "0x" <> cs (encodeHex $ S.encode (opcode :: ScriptOp))
|
||||
Just opcode -> "0x" <> cs (encodeHex $ runPutS $ serialize (opcode :: ScriptOp))
|
||||
_ -> str
|
||||
|
||||
strictSigSpec :: Network -> Spec
|
||||
@ -251,10 +258,10 @@ txSigHashSpec net =
|
||||
let tx = fromString txStr
|
||||
s =
|
||||
fromMaybe (error $ "Could not decode script: " <> cs scpStr) $
|
||||
eitherToMaybe . S.decode =<< decodeHex (cs scpStr)
|
||||
eitherToMaybe . runGetS deserialize =<< decodeHex (cs scpStr)
|
||||
sh = fromIntegral shI
|
||||
res =
|
||||
eitherToMaybe . S.decode . B.reverse =<<
|
||||
eitherToMaybe . runGetS deserialize . B.reverse =<<
|
||||
decodeHex (cs resStr)
|
||||
Just (txSigHash net tx s 0 i sh) `shouldBe` res
|
||||
|
||||
@ -275,9 +282,9 @@ txSigHashForkIdSpec net =
|
||||
let tx = fromString txStr
|
||||
s =
|
||||
fromMaybe (error $ "Could not decode script: " <> cs scpStr) $
|
||||
eitherToMaybe . S.decode =<< decodeHex (cs scpStr)
|
||||
eitherToMaybe . runGetS deserialize =<< decodeHex (cs scpStr)
|
||||
sh = fromIntegral shI
|
||||
res = eitherToMaybe . S.decode =<< decodeHex (cs resStr)
|
||||
res = eitherToMaybe . runGetS deserialize =<< decodeHex (cs resStr)
|
||||
Just (txSigHashForkId net tx s val i sh) `shouldBe` res
|
||||
|
||||
sigHashSpec :: Network -> Spec
|
||||
@ -359,7 +366,7 @@ runMulSigVector (a, ops) = assertBool "multisig vector" $ Just a == b
|
||||
where
|
||||
s = do
|
||||
s' <- decodeHex ops
|
||||
eitherToMaybe $ S.decode s'
|
||||
eitherToMaybe $ runGetS deserialize s'
|
||||
b = do
|
||||
o <- s
|
||||
d <- eitherToMaybe $ decodeOutput o
|
||||
@ -413,7 +420,7 @@ scriptSigSignatures =
|
||||
|
||||
encodeScriptVector :: Assertion
|
||||
encodeScriptVector =
|
||||
assertEqual "Encode script" res (encodeHex $ S.encode s)
|
||||
assertEqual "Encode script" res (encodeHex $ runPutS $ serialize s)
|
||||
where
|
||||
res =
|
||||
"514104cc71eb30d653c0c3163990c47b976f3fb3f37cccdcbedb169a1dfef58b\
|
||||
|
@ -4,14 +4,17 @@ module Haskoin.Transaction.PartialSpec (spec) where
|
||||
|
||||
import Control.Monad.Fail (MonadFail)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Bytes.Get
|
||||
import Data.Bytes.Put
|
||||
import Data.Bytes.Serial
|
||||
import Data.Either (fromRight, isLeft, isRight)
|
||||
import Data.HashMap.Strict (fromList, singleton)
|
||||
import Data.Maybe (fromJust, isJust)
|
||||
import Data.Serialize as S
|
||||
import Data.Text (Text)
|
||||
import Test.Hspec
|
||||
import Test.HUnit (Assertion, assertBool,
|
||||
assertEqual)
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
|
||||
import Haskoin.Address
|
||||
@ -150,10 +153,11 @@ decodeHexPSBTM errMsg = either (fail . (errMsg <>) . (": " <>)) return . decodeH
|
||||
|
||||
hexScript :: Text -> ByteString
|
||||
hexScript =
|
||||
either (error "Could not decode script") encodeScript . S.decode . fromJust . decodeHex
|
||||
either (error "Could not decode script") encodeScript .
|
||||
runGetS deserialize . fromJust . decodeHex
|
||||
where
|
||||
encodeScript :: Script -> ByteString
|
||||
encodeScript = S.encode
|
||||
encodeScript = runPutS . serialize
|
||||
|
||||
invalidVecTest :: Text -> Assertion
|
||||
invalidVecTest = assertBool "invalid psbt" . isLeft . decodeHexPSBT
|
||||
@ -194,7 +198,12 @@ unfinalizedPkhPSBT net (prvKey, pubKey) = (emptyPSBT currTx)
|
||||
currTx = unfinalizedTx (txHash prevTx)
|
||||
prevTx = testUtxo [prevOut]
|
||||
prevOutScript = addressToScript (pubKeyAddr pubKey)
|
||||
prevOut = TxOut { outValue = 200000000, scriptOutput = S.encode prevOutScript }
|
||||
prevOut =
|
||||
TxOut
|
||||
{
|
||||
outValue = 200000000,
|
||||
scriptOutput = runPutS (serialize prevOutScript)
|
||||
}
|
||||
h = txSigHash net currTx prevOutScript (outValue prevOut) 0 sigHashAll
|
||||
sig = encodeTxSig $ TxSignature (signHash (secKeyData prvKey) h) sigHashAll
|
||||
|
||||
|
@ -2,14 +2,16 @@
|
||||
|
||||
module Haskoin.TransactionSpec (spec) where
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
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 Data.Serialize as S
|
||||
import Data.String (fromString)
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions
|
||||
import Data.Text (Text)
|
||||
import Data.Word (Word32, Word64)
|
||||
import Data.Text (Text)
|
||||
import Data.Word (Word32, Word64)
|
||||
import Haskoin.Address
|
||||
import Haskoin.Constants
|
||||
import Haskoin.Keys
|
||||
@ -17,9 +19,9 @@ import Haskoin.Script
|
||||
import Haskoin.Transaction
|
||||
import Haskoin.Util
|
||||
import Haskoin.Util.Arbitrary
|
||||
import Test.HUnit
|
||||
import Test.Hspec
|
||||
import Test.Hspec.QuickCheck
|
||||
import Test.HUnit
|
||||
import Test.QuickCheck
|
||||
|
||||
serialVals :: [SerialBox]
|
||||
@ -94,7 +96,7 @@ testTxidVector :: (Text, Text) -> Assertion
|
||||
testTxidVector (tid, tx) =
|
||||
assertEqual "txid" (Just tid) (txHashToHex . txHash <$> txM)
|
||||
where
|
||||
txM = eitherToMaybe . S.decode =<< decodeHex tx
|
||||
txM = eitherToMaybe . runGetS deserialize =<< decodeHex tx
|
||||
|
||||
txidVectors :: [(Text, Text)]
|
||||
txidVectors =
|
||||
@ -156,7 +158,10 @@ txidVectors =
|
||||
|
||||
testPKHashVector :: ([(Text, Word32)], [(Text, Word64)], Text) -> Assertion
|
||||
testPKHashVector (is, os, res) =
|
||||
assertEqual "Build PKHash Tx" (Right res) (encodeHex . S.encode <$> txE)
|
||||
assertEqual
|
||||
"Build PKHash Tx"
|
||||
(Right res)
|
||||
(encodeHex . runPutS . serialize <$> txE)
|
||||
where
|
||||
txE = buildAddrTx btc (map f is) os
|
||||
f (tid, ix) = OutPoint (fromJust $ hexToTxHash tid) ix
|
||||
@ -223,7 +228,7 @@ testGuessSize net tx =
|
||||
where
|
||||
delta = pki + sum (map fst msi)
|
||||
guess = guessTxSize pki msi pkout msout
|
||||
len = B.length $ S.encode tx
|
||||
len = B.length $ runPutS $ serialize tx
|
||||
ins = map f $ txIn tx
|
||||
f i =
|
||||
fromRight (error "Could not decode input") $
|
||||
@ -231,7 +236,7 @@ testGuessSize net tx =
|
||||
pki = length $ filter isSpendPKHash ins
|
||||
msi = concatMap shData ins
|
||||
shData (ScriptHashInput _ (PayMulSig keys r)) = [(r, length keys)]
|
||||
shData _ = []
|
||||
shData _ = []
|
||||
out =
|
||||
map
|
||||
(fromRight (error "Could not decode transaction output") .
|
||||
|
Loading…
Reference in New Issue
Block a user