haskoin/haskoin-core
1
1
Fork 0
mirror of https://github.com/haskoin/haskoin-core.git synced 2024-09-11 10:05:34 +03:00
Code Issues Projects Releases Wiki Activity

Use the bytes library for serialization

Browse Source
This commit is contained in:
JP Rupp 2021-02-22 11:27:03 +00:00
parent 323433e680
commit 1196c5a3ef
No known key found for this signature in database
GPG Key ID: 93391726EAFA0C5D
36 changed files with 1727 additions and 776 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
CHANGELOG.md
View File

@ -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.

18
haskoin-core.cabal
View File

@ -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

8
package.yaml
View File

@ -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

116
src/Haskoin/Address.hs
View File

@ -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

8
src/Haskoin/Address/Base58.hs
View File

@ -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

148
src/Haskoin/Block/Common.hs
View File

@ -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.
--

52
src/Haskoin/Block/Headers.hs
View File

@ -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.

37
src/Haskoin/Block/Merkle.hs
View File

@ -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

20
src/Haskoin/Constants.hs
View File

@ -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

56
src/Haskoin/Crypto/Hash.hs
View File

@ -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

12
src/Haskoin/Crypto/Signature.hs
View File

@ -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.

57
src/Haskoin/Keys/Common.hs
View File

@ -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.

155
src/Haskoin/Keys/Extended.hs
View File

@ -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

85
src/Haskoin/Network/Bloom.hs
View File

@ -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

306
src/Haskoin/Network/Common.hs
View File

@ -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)

136
src/Haskoin/Network/Message.hs
View File

@ -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

53
src/Haskoin/Script/Common.hs
View File

@ -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

36
src/Haskoin/Script/SigHash.hs
View File

@ -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

54
src/Haskoin/Script/Standard.hs
View File

@ -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

32
src/Haskoin/Transaction/Builder.hs
View File

@ -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 &&

6
src/Haskoin/Transaction/Builder/Sign.hs
View File

@ -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')

152
src/Haskoin/Transaction/Common.hs
View File

@ -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 =

509
src/Haskoin/Transaction/Partial.hs
View File

@ -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

16
src/Haskoin/Transaction/Segwit.hs
View File

@ -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 = ""

193
src/Haskoin/Util.hs
View File

@ -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

2
src/Haskoin/Util/Arbitrary/Script.hs
View File

@ -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

44
src/Haskoin/Util/Arbitrary/Util.hs
View File

@ -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

4
stack.yaml
View File

@ -1,7 +1,5 @@
resolver: lts-16.24
resolver: lts-17.4
nix:
packages:
- secp256k1
- pkg-config
extra-deps:
- secp256k1-haskell-0.5.0

17
stack.yaml.lock
View File

@ -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

13
test/Haskoin/Crypto/HashSpec.hs
View File

@ -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

26
test/Haskoin/Keys/ExtendedSpec.hs
View File

@ -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)]

26
test/Haskoin/KeysSpec.hs
View File

@ -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

16
test/Haskoin/NetworkSpec.hs
View File

@ -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

43
test/Haskoin/ScriptSpec.hs
View File

@ -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\

17
test/Haskoin/Transaction/PartialSpec.hs
View File

@ -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

25
test/Haskoin/TransactionSpec.hs
View File

@ -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") .