{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
module Haskoin.Block.Merkle
(
MerkleBlock(..)
, MerkleRoot
, FlagBits
, PartialMerkleTree
, buildMerkleRoot
, merkleBlockTxs
, testMerkleRoot
, buildPartialMerkle
, decodeMerkleFlags
, encodeMerkleFlags
, calcTreeHeight
, calcTreeWidth
, hash2
, calcHash
, traverseAndBuild
, traverseAndExtract
, extractMatches
, splitIn
, boolsToWord8
) where
import Control.DeepSeq
import Control.Monad (forM_, replicateM, when)
import Data.Bits
import qualified Data.ByteString as BS
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.Word (Word32, Word8)
import GHC.Generics
import Haskoin.Block.Common
import Haskoin.Constants
import Haskoin.Crypto.Hash
import Haskoin.Network.Common
import Haskoin.Transaction.Common
type MerkleRoot = Hash256
type FlagBits = [Bool]
type PartialMerkleTree = [Hash256]
data MerkleBlock =
MerkleBlock {
:: !BlockHeader
, MerkleBlock -> Word32
merkleTotalTxns :: !Word32
, MerkleBlock -> PartialMerkleTree
mHashes :: !PartialMerkleTree
, MerkleBlock -> FlagBits
mFlags :: !FlagBits
} deriving (MerkleBlock -> MerkleBlock -> Bool
(MerkleBlock -> MerkleBlock -> Bool)
-> (MerkleBlock -> MerkleBlock -> Bool) -> Eq MerkleBlock
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MerkleBlock -> MerkleBlock -> Bool
$c/= :: MerkleBlock -> MerkleBlock -> Bool
== :: MerkleBlock -> MerkleBlock -> Bool
$c== :: MerkleBlock -> MerkleBlock -> Bool
Eq, Int -> MerkleBlock -> ShowS
[MerkleBlock] -> ShowS
MerkleBlock -> String
(Int -> MerkleBlock -> ShowS)
-> (MerkleBlock -> String)
-> ([MerkleBlock] -> ShowS)
-> Show MerkleBlock
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MerkleBlock] -> ShowS
$cshowList :: [MerkleBlock] -> ShowS
show :: MerkleBlock -> String
$cshow :: MerkleBlock -> String
showsPrec :: Int -> MerkleBlock -> ShowS
$cshowsPrec :: Int -> MerkleBlock -> ShowS
Show, ReadPrec [MerkleBlock]
ReadPrec MerkleBlock
Int -> ReadS MerkleBlock
ReadS [MerkleBlock]
(Int -> ReadS MerkleBlock)
-> ReadS [MerkleBlock]
-> ReadPrec MerkleBlock
-> ReadPrec [MerkleBlock]
-> Read MerkleBlock
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [MerkleBlock]
$creadListPrec :: ReadPrec [MerkleBlock]
readPrec :: ReadPrec MerkleBlock
$creadPrec :: ReadPrec MerkleBlock
readList :: ReadS [MerkleBlock]
$creadList :: ReadS [MerkleBlock]
readsPrec :: Int -> ReadS MerkleBlock
$creadsPrec :: Int -> ReadS MerkleBlock
Read, (forall x. MerkleBlock -> Rep MerkleBlock x)
-> (forall x. Rep MerkleBlock x -> MerkleBlock)
-> Generic MerkleBlock
forall x. Rep MerkleBlock x -> MerkleBlock
forall x. MerkleBlock -> Rep MerkleBlock x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MerkleBlock x -> MerkleBlock
$cfrom :: forall x. MerkleBlock -> Rep MerkleBlock x
Generic, Int -> MerkleBlock -> Int
MerkleBlock -> Int
(Int -> MerkleBlock -> Int)
-> (MerkleBlock -> Int) -> Hashable MerkleBlock
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: MerkleBlock -> Int
$chash :: MerkleBlock -> Int
hashWithSalt :: Int -> MerkleBlock -> Int
$chashWithSalt :: Int -> MerkleBlock -> Int
Hashable, MerkleBlock -> ()
(MerkleBlock -> ()) -> NFData MerkleBlock
forall a. (a -> ()) -> NFData a
rnf :: MerkleBlock -> ()
$crnf :: MerkleBlock -> ()
NFData)
instance Serialize MerkleBlock where
get :: Get MerkleBlock
get = do
BlockHeader
header <- Get BlockHeader
forall t. Serialize t => Get t
get
Word32
ntx <- Get Word32
getWord32le
(VarInt matchLen :: Word64
matchLen) <- Get VarInt
forall t. Serialize t => Get t
get
PartialMerkleTree
hashes <- Int -> Get Hash256 -> Get PartialMerkleTree
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
matchLen) Get Hash256
forall t. Serialize t => Get t
get
(VarInt flagLen :: Word64
flagLen) <- Get VarInt
forall t. Serialize t => Get t
get
[Word8]
ws <- Int -> Get Word8 -> Get [Word8]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
flagLen) Get Word8
getWord8
MerkleBlock -> Get MerkleBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (MerkleBlock -> Get MerkleBlock) -> MerkleBlock -> Get MerkleBlock
forall a b. (a -> b) -> a -> b
$ BlockHeader
-> Word32 -> PartialMerkleTree -> FlagBits -> MerkleBlock
MerkleBlock BlockHeader
header Word32
ntx PartialMerkleTree
hashes ([Word8] -> FlagBits
decodeMerkleFlags [Word8]
ws)
put :: Putter MerkleBlock
put (MerkleBlock h :: BlockHeader
h ntx :: Word32
ntx hashes :: PartialMerkleTree
hashes flags :: FlagBits
flags) = do
Putter BlockHeader
forall t. Serialize t => Putter t
put BlockHeader
h
Putter Word32
putWord32le Word32
ntx
Int -> Put
forall a. Integral a => a -> Put
putVarInt (Int -> Put) -> Int -> Put
forall a b. (a -> b) -> a -> b
$ PartialMerkleTree -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length PartialMerkleTree
hashes
PartialMerkleTree -> (Hash256 -> Put) -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ PartialMerkleTree
hashes Hash256 -> Put
forall t. Serialize t => Putter t
put
let ws :: [Word8]
ws = FlagBits -> [Word8]
encodeMerkleFlags FlagBits
flags
Int -> Put
forall a. Integral a => a -> Put
putVarInt (Int -> Put) -> Int -> Put
forall a b. (a -> b) -> a -> b
$ [Word8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
ws
[Word8] -> (Word8 -> Put) -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Word8]
ws Word8 -> Put
putWord8
decodeMerkleFlags :: [Word8] -> FlagBits
decodeMerkleFlags :: [Word8] -> FlagBits
decodeMerkleFlags ws :: [Word8]
ws =
[ Bool
b | Int
p <- [ 0 .. [Word8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
ws Int -> Int -> Int
forall a. Num a => a -> a -> a
* 8 Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1 ]
, Bool
b <- [ Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit ([Word8]
ws [Word8] -> Int -> Word8
forall a. [a] -> Int -> a
!! (Int
p Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 8)) (Int
p Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` 8) ]
]
encodeMerkleFlags :: FlagBits -> [Word8]
encodeMerkleFlags :: FlagBits -> [Word8]
encodeMerkleFlags bs :: FlagBits
bs = (FlagBits -> Word8) -> [FlagBits] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map FlagBits -> Word8
boolsToWord8 ([FlagBits] -> [Word8]) -> [FlagBits] -> [Word8]
forall a b. (a -> b) -> a -> b
$ Int -> FlagBits -> [FlagBits]
forall a. Int -> [a] -> [[a]]
splitIn 8 FlagBits
bs
calcTreeHeight :: Int
-> Int
calcTreeHeight :: Int -> Int
calcTreeHeight ntx :: Int
ntx | Int
ntx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 2 = 0
| Int -> Bool
forall a. Integral a => a -> Bool
even Int
ntx = 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
calcTreeHeight (Int
ntx Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2)
| Bool
otherwise = Int -> Int
calcTreeHeight (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
ntx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
calcTreeWidth :: Int
-> Int
-> Int
calcTreeWidth :: Int -> Int -> Int
calcTreeWidth ntx :: Int
ntx h :: Int
h = (Int
ntx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
h) Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
h
buildMerkleRoot :: [TxHash]
-> MerkleRoot
buildMerkleRoot :: [TxHash] -> Hash256
buildMerkleRoot txs :: [TxHash]
txs = Int -> Int -> [TxHash] -> Hash256
calcHash (Int -> Int
calcTreeHeight (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [TxHash] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxHash]
txs) 0 [TxHash]
txs
hash2 :: Hash256 -> Hash256 -> Hash256
hash2 :: Hash256 -> Hash256 -> Hash256
hash2 a :: Hash256
a b :: Hash256
b = ByteString -> Hash256
forall b. ByteArrayAccess b => b -> Hash256
doubleSHA256 (ByteString -> Hash256) -> ByteString -> Hash256
forall a b. (a -> b) -> a -> b
$ Hash256 -> ByteString
forall a. Serialize a => a -> ByteString
encode Hash256
a ByteString -> ByteString -> ByteString
`BS.append` Hash256 -> ByteString
forall a. Serialize a => a -> ByteString
encode Hash256
b
calcHash :: Int
-> Int
-> [TxHash]
-> Hash256
calcHash :: Int -> Int -> [TxHash] -> Hash256
calcHash height :: Int
height pos :: Int
pos txs :: [TxHash]
txs
| Int
height Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 Bool -> Bool -> Bool
|| Int
pos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = String -> Hash256
forall a. HasCallStack => String -> a
error "calcHash: Invalid parameters"
| Int
height Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = TxHash -> Hash256
getTxHash (TxHash -> Hash256) -> TxHash -> Hash256
forall a b. (a -> b) -> a -> b
$ [TxHash]
txs [TxHash] -> Int -> TxHash
forall a. [a] -> Int -> a
!! Int
pos
| Bool
otherwise = Hash256 -> Hash256 -> Hash256
hash2 Hash256
left Hash256
right
where
left :: Hash256
left = Int -> Int -> [TxHash] -> Hash256
calcHash (Int
heightInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
*2) [TxHash]
txs
right :: Hash256
right | Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
*2Int -> Int -> Int
forall a. Num a => a -> a -> a
+1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Int -> Int
calcTreeWidth ([TxHash] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxHash]
txs) (Int
heightInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) =
Int -> Int -> [TxHash] -> Hash256
calcHash (Int
heightInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
*2Int -> Int -> Int
forall a. Num a => a -> a -> a
+1) [TxHash]
txs
| Bool
otherwise = Hash256
left
buildPartialMerkle ::
[(TxHash, Bool)]
-> (FlagBits, PartialMerkleTree)
buildPartialMerkle :: [(TxHash, Bool)] -> (FlagBits, PartialMerkleTree)
buildPartialMerkle hs :: [(TxHash, Bool)]
hs = Int -> Int -> [(TxHash, Bool)] -> (FlagBits, PartialMerkleTree)
traverseAndBuild (Int -> Int
calcTreeHeight (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [(TxHash, Bool)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(TxHash, Bool)]
hs) 0 [(TxHash, Bool)]
hs
traverseAndBuild ::
Int -> Int -> [(TxHash, Bool)] -> (FlagBits, PartialMerkleTree)
traverseAndBuild :: Int -> Int -> [(TxHash, Bool)] -> (FlagBits, PartialMerkleTree)
traverseAndBuild height :: Int
height pos :: Int
pos txs :: [(TxHash, Bool)]
txs
| Int
height Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 Bool -> Bool -> Bool
|| Int
pos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = String -> (FlagBits, PartialMerkleTree)
forall a. HasCallStack => String -> a
error "traverseAndBuild: Invalid parameters"
| Int
height Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
match = ([Bool
match], [Int -> Int -> [TxHash] -> Hash256
calcHash Int
height Int
pos [TxHash]
t])
| Bool
otherwise = (Bool
match Bool -> FlagBits -> FlagBits
forall a. a -> [a] -> [a]
: FlagBits
lb FlagBits -> FlagBits -> FlagBits
forall a. [a] -> [a] -> [a]
++ FlagBits
rb, PartialMerkleTree
lh PartialMerkleTree -> PartialMerkleTree -> PartialMerkleTree
forall a. [a] -> [a] -> [a]
++ PartialMerkleTree
rh)
where
t :: [TxHash]
t = ((TxHash, Bool) -> TxHash) -> [(TxHash, Bool)] -> [TxHash]
forall a b. (a -> b) -> [a] -> [b]
map (TxHash, Bool) -> TxHash
forall a b. (a, b) -> a
fst [(TxHash, Bool)]
txs
s :: Int
s = Int
pos Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
height
e :: Int
e = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min ([(TxHash, Bool)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(TxHash, Bool)]
txs) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
height
match :: Bool
match = ((TxHash, Bool) -> Bool) -> [(TxHash, Bool)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TxHash, Bool) -> Bool
forall a b. (a, b) -> b
snd ([(TxHash, Bool)] -> Bool) -> [(TxHash, Bool)] -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> [(TxHash, Bool)] -> [(TxHash, Bool)]
forall a. Int -> [a] -> [a]
take (Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
s) ([(TxHash, Bool)] -> [(TxHash, Bool)])
-> [(TxHash, Bool)] -> [(TxHash, Bool)]
forall a b. (a -> b) -> a -> b
$ Int -> [(TxHash, Bool)] -> [(TxHash, Bool)]
forall a. Int -> [a] -> [a]
drop Int
s [(TxHash, Bool)]
txs
(lb :: FlagBits
lb, lh :: PartialMerkleTree
lh) = Int -> Int -> [(TxHash, Bool)] -> (FlagBits, PartialMerkleTree)
traverseAndBuild (Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2) [(TxHash, Bool)]
txs
(rb :: FlagBits
rb, rh :: PartialMerkleTree
rh)
| (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Int -> Int
calcTreeWidth ([(TxHash, Bool)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(TxHash, Bool)]
txs) (Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) =
Int -> Int -> [(TxHash, Bool)] -> (FlagBits, PartialMerkleTree)
traverseAndBuild (Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) [(TxHash, Bool)]
txs
| Bool
otherwise = ([], [])
traverseAndExtract :: Int -> Int -> Int -> FlagBits -> PartialMerkleTree
-> Maybe (MerkleRoot, [TxHash], Int, Int)
traverseAndExtract :: Int
-> Int
-> Int
-> FlagBits
-> PartialMerkleTree
-> Maybe (Hash256, [TxHash], Int, Int)
traverseAndExtract height :: Int
height pos :: Int
pos ntx :: Int
ntx flags :: FlagBits
flags hashes :: PartialMerkleTree
hashes
| FlagBits -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FlagBits
flags = Maybe (Hash256, [TxHash], Int, Int)
forall a. Maybe a
Nothing
| Int
height Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
match = Maybe (Hash256, [TxHash], Int, Int)
leafResult
| Maybe (Hash256, [TxHash], Int, Int) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Hash256, [TxHash], Int, Int)
leftM = Maybe (Hash256, [TxHash], Int, Int)
forall a. Maybe a
Nothing
| (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
*2Int -> Int -> Int
forall a. Num a => a -> a -> a
+1) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Int -> Int
calcTreeWidth Int
ntx (Int
heightInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) =
(Hash256, [TxHash], Int, Int)
-> Maybe (Hash256, [TxHash], Int, Int)
forall a. a -> Maybe a
Just (Hash256 -> Hash256 -> Hash256
hash2 Hash256
lh Hash256
lh, [TxHash]
lm, Int
lcfInt -> Int -> Int
forall a. Num a => a -> a -> a
+1, Int
lch)
| Maybe (Hash256, [TxHash], Int, Int) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Hash256, [TxHash], Int, Int)
rightM = Maybe (Hash256, [TxHash], Int, Int)
forall a. Maybe a
Nothing
| Bool
otherwise =
(Hash256, [TxHash], Int, Int)
-> Maybe (Hash256, [TxHash], Int, Int)
forall a. a -> Maybe a
Just (Hash256 -> Hash256 -> Hash256
hash2 Hash256
lh Hash256
rh, [TxHash]
lm [TxHash] -> [TxHash] -> [TxHash]
forall a. [a] -> [a] -> [a]
++ [TxHash]
rm, Int
lcfInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
rcfInt -> Int -> Int
forall a. Num a => a -> a -> a
+1, Int
lchInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
rch)
where
leafResult :: Maybe (Hash256, [TxHash], Int, Int)
leafResult
| PartialMerkleTree -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null PartialMerkleTree
hashes = Maybe (Hash256, [TxHash], Int, Int)
forall a. Maybe a
Nothing
| Bool
otherwise = (Hash256, [TxHash], Int, Int)
-> Maybe (Hash256, [TxHash], Int, Int)
forall a. a -> Maybe a
Just (Hash256
h, [ Hash256 -> TxHash
TxHash Hash256
h | Int
height Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
&& Bool
match ], 1, 1)
(match :: Bool
match:fs :: FlagBits
fs) = FlagBits
flags
(h :: Hash256
h:_) = PartialMerkleTree
hashes
leftM :: Maybe (Hash256, [TxHash], Int, Int)
leftM = Int
-> Int
-> Int
-> FlagBits
-> PartialMerkleTree
-> Maybe (Hash256, [TxHash], Int, Int)
traverseAndExtract (Int
heightInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
*2) Int
ntx FlagBits
fs PartialMerkleTree
hashes
(lh :: Hash256
lh,lm :: [TxHash]
lm,lcf :: Int
lcf,lch :: Int
lch) = (Hash256, [TxHash], Int, Int)
-> Maybe (Hash256, [TxHash], Int, Int)
-> (Hash256, [TxHash], Int, Int)
forall a. a -> Maybe a -> a
fromMaybe (Hash256, [TxHash], Int, Int)
forall a. a
e Maybe (Hash256, [TxHash], Int, Int)
leftM
rightM :: Maybe (Hash256, [TxHash], Int, Int)
rightM = Int
-> Int
-> Int
-> FlagBits
-> PartialMerkleTree
-> Maybe (Hash256, [TxHash], Int, Int)
traverseAndExtract (Int
heightInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
*2Int -> Int -> Int
forall a. Num a => a -> a -> a
+1) Int
ntx
(Int -> FlagBits -> FlagBits
forall a. Int -> [a] -> [a]
drop Int
lcf FlagBits
fs) (Int -> PartialMerkleTree -> PartialMerkleTree
forall a. Int -> [a] -> [a]
drop Int
lch PartialMerkleTree
hashes)
(rh :: Hash256
rh,rm :: [TxHash]
rm,rcf :: Int
rcf,rch :: Int
rch) = (Hash256, [TxHash], Int, Int)
-> Maybe (Hash256, [TxHash], Int, Int)
-> (Hash256, [TxHash], Int, Int)
forall a. a -> Maybe a -> a
fromMaybe (Hash256, [TxHash], Int, Int)
forall a. a
e Maybe (Hash256, [TxHash], Int, Int)
rightM
e :: a
e = String -> a
forall a. HasCallStack => String -> a
error "traverseAndExtract: unexpected error extracting a Maybe value"
extractMatches :: Network
-> FlagBits
-> PartialMerkleTree
-> Int
-> Either String (MerkleRoot, [TxHash])
net :: Network
net flags :: FlagBits
flags hashes :: PartialMerkleTree
hashes ntx :: Int
ntx
| Int
ntx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = String -> Either String (Hash256, [TxHash])
forall a b. a -> Either a b
Left
"extractMatches: number of transactions can not be 0"
| Int
ntx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Network -> Int
getMaxBlockSize Network
net Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 60 = String -> Either String (Hash256, [TxHash])
forall a b. a -> Either a b
Left
"extractMatches: number of transactions excessively high"
| PartialMerkleTree -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length PartialMerkleTree
hashes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
ntx = String -> Either String (Hash256, [TxHash])
forall a b. a -> Either a b
Left
"extractMatches: More hashes provided than the number of transactions"
| FlagBits -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FlagBits
flags Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< PartialMerkleTree -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length PartialMerkleTree
hashes = String -> Either String (Hash256, [TxHash])
forall a b. a -> Either a b
Left
"extractMatches: At least one bit per node and one bit per hash"
| Maybe (Hash256, [TxHash], Int, Int) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Hash256, [TxHash], Int, Int)
resM = String -> Either String (Hash256, [TxHash])
forall a b. a -> Either a b
Left
"extractMatches: traverseAndExtract failed"
| (Int
nBitsUsedInt -> Int -> Int
forall a. Num a => a -> a -> a
+7) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 8 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= (FlagBits -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FlagBits
flagsInt -> Int -> Int
forall a. Num a => a -> a -> a
+7) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 8 = String -> Either String (Hash256, [TxHash])
forall a b. a -> Either a b
Left
"extractMatches: All bits were not consumed"
| Int
nHashUsed Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= PartialMerkleTree -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length PartialMerkleTree
hashes = String -> Either String (Hash256, [TxHash])
forall a b. a -> Either a b
Left (String -> Either String (Hash256, [TxHash]))
-> String -> Either String (Hash256, [TxHash])
forall a b. (a -> b) -> a -> b
$
"extractMatches: All hashes were not consumed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
nHashUsed
| Bool
otherwise = (Hash256, [TxHash]) -> Either String (Hash256, [TxHash])
forall (m :: * -> *) a. Monad m => a -> m a
return (Hash256
merkRoot, [TxHash]
matches)
where
resM :: Maybe (Hash256, [TxHash], Int, Int)
resM = Int
-> Int
-> Int
-> FlagBits
-> PartialMerkleTree
-> Maybe (Hash256, [TxHash], Int, Int)
traverseAndExtract (Int -> Int
calcTreeHeight Int
ntx) 0 Int
ntx FlagBits
flags PartialMerkleTree
hashes
(merkRoot :: Hash256
merkRoot, matches :: [TxHash]
matches, nBitsUsed :: Int
nBitsUsed, nHashUsed :: Int
nHashUsed) = (Hash256, [TxHash], Int, Int)
-> Maybe (Hash256, [TxHash], Int, Int)
-> (Hash256, [TxHash], Int, Int)
forall a. a -> Maybe a -> a
fromMaybe (Hash256, [TxHash], Int, Int)
forall a. a
e Maybe (Hash256, [TxHash], Int, Int)
resM
e :: a
e = String -> a
forall a. HasCallStack => String -> a
error "extractMatches: unexpected error extracting a Maybe value"
splitIn :: Int -> [a] -> [[a]]
splitIn :: Int -> [a] -> [[a]]
splitIn _ [] = []
splitIn c :: Int
c xs :: [a]
xs = [a]
xs1 [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
splitIn Int
c [a]
xs2
where
(xs1 :: [a]
xs1, xs2 :: [a]
xs2) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
c [a]
xs
boolsToWord8 :: [Bool] -> Word8
boolsToWord8 :: FlagBits -> Word8
boolsToWord8 [] = 0
boolsToWord8 xs :: FlagBits
xs = (Word8 -> Int -> Word8) -> Word8 -> [Int] -> Word8
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
setBit 0 (((Bool, Int) -> Int) -> [(Bool, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, Int) -> Int
forall a b. (a, b) -> b
snd ([(Bool, Int)] -> [Int]) -> [(Bool, Int)] -> [Int]
forall a b. (a -> b) -> a -> b
$ ((Bool, Int) -> Bool) -> [(Bool, Int)] -> [(Bool, Int)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool, Int) -> Bool
forall a b. (a, b) -> a
fst ([(Bool, Int)] -> [(Bool, Int)]) -> [(Bool, Int)] -> [(Bool, Int)]
forall a b. (a -> b) -> a -> b
$ FlagBits -> [Int] -> [(Bool, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip FlagBits
xs [0..7])
merkleBlockTxs :: Network -> MerkleBlock -> Either String [TxHash]
merkleBlockTxs :: Network -> MerkleBlock -> Either String [TxHash]
merkleBlockTxs net :: Network
net b :: MerkleBlock
b =
let flags :: FlagBits
flags = MerkleBlock -> FlagBits
mFlags MerkleBlock
b
hs :: PartialMerkleTree
hs = MerkleBlock -> PartialMerkleTree
mHashes MerkleBlock
b
n :: Int
n = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ MerkleBlock -> Word32
merkleTotalTxns MerkleBlock
b
merkle :: Hash256
merkle = BlockHeader -> Hash256
merkleRoot (BlockHeader -> Hash256) -> BlockHeader -> Hash256
forall a b. (a -> b) -> a -> b
$ MerkleBlock -> BlockHeader
merkleHeader MerkleBlock
b
in do (root :: Hash256
root, ths :: [TxHash]
ths) <- Network
-> FlagBits
-> PartialMerkleTree
-> Int
-> Either String (Hash256, [TxHash])
extractMatches Network
net FlagBits
flags PartialMerkleTree
hs Int
n
Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Hash256
root Hash256 -> Hash256 -> Bool
forall a. Eq a => a -> a -> Bool
/= Hash256
merkle) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left "merkleBlockTxs: Merkle root incorrect"
[TxHash] -> Either String [TxHash]
forall (m :: * -> *) a. Monad m => a -> m a
return [TxHash]
ths
testMerkleRoot :: Network -> MerkleBlock -> Bool
testMerkleRoot :: Network -> MerkleBlock -> Bool
testMerkleRoot net :: Network
net = Either String [TxHash] -> Bool
forall a b. Either a b -> Bool
isRight (Either String [TxHash] -> Bool)
-> (MerkleBlock -> Either String [TxHash]) -> MerkleBlock -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Network -> MerkleBlock -> Either String [TxHash]
merkleBlockTxs Network
net