{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}

{- |
Module      : Haskoin.Block.Merkle
Copyright   : No rights reserved
License     : MIT
Maintainer  : jprupp@protonmail.ch
Stability   : experimental
Portability : POSIX

Function to deal with Merkle trees inside blocks.
-}
module Haskoin.Block.Merkle (
    -- * Merkle Blocks
    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.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 (..))
import Data.Word (Word32, Word8)
import GHC.Generics
import Haskoin.Block.Common
import Haskoin.Crypto.Hash
import Haskoin.Data
import Haskoin.Network.Common
import Haskoin.Transaction.Common

-- | Hash of the block's Merkle root.
type MerkleRoot = Hash256

-- | Bits that are used to rebuild partial merkle tree transaction hash list.
type FlagBits = [Bool]

-- | Partial Merkle tree for a filtered block.
type PartialMerkleTree = [Hash256]

{- | Filtered block: a block with a partial Merkle tree that only includes the
 transactions that pass a bloom filter that was negotiated.
-}
data MerkleBlock = MerkleBlock
    { -- | block header
      MerkleBlock -> BlockHeader
merkleHeader :: !BlockHeader
    , -- | total number of transactions in block
      MerkleBlock -> Word32
merkleTotalTxns :: !Word32
    , -- | hashes in depth-first order
      MerkleBlock -> PartialMerkleTree
mHashes :: !PartialMerkleTree
    , -- | bits to rebuild partial merkle tree
      MerkleBlock -> FlagBits
mFlags :: !FlagBits
    }
    deriving (MerkleBlock -> MerkleBlock -> Bool
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
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]
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. 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, Eq MerkleBlock
Int -> MerkleBlock -> Int
MerkleBlock -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: MerkleBlock -> Int
$chash :: MerkleBlock -> Int
hashWithSalt :: Int -> MerkleBlock -> Int
$chashWithSalt :: Int -> MerkleBlock -> Int
Hashable, MerkleBlock -> ()
forall a. (a -> ()) -> NFData a
rnf :: MerkleBlock -> ()
$crnf :: MerkleBlock -> ()
NFData)

instance Serial MerkleBlock where
    deserialize :: forall (m :: * -> *). MonadGet m => m MerkleBlock
deserialize = do
        BlockHeader
header <- forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
        Word32
ntx <- forall (m :: * -> *). MonadGet m => m Word32
getWord32le
        (VarInt Word64
matchLen) <- forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
        PartialMerkleTree
hashes <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
matchLen) forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
        (VarInt Word64
flagLen) <- forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
        [Word8]
ws <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
flagLen) forall (m :: * -> *). MonadGet m => m Word8
getWord8
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ BlockHeader
-> Word32 -> PartialMerkleTree -> FlagBits -> MerkleBlock
MerkleBlock BlockHeader
header Word32
ntx PartialMerkleTree
hashes ([Word8] -> FlagBits
decodeMerkleFlags [Word8]
ws)

    serialize :: forall (m :: * -> *). MonadPut m => MerkleBlock -> m ()
serialize (MerkleBlock BlockHeader
h Word32
ntx PartialMerkleTree
hashes FlagBits
flags) = do
        forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize BlockHeader
h
        forall (m :: * -> *). MonadPut m => Word32 -> m ()
putWord32le Word32
ntx
        forall (m :: * -> *) a. (MonadPut m, Integral a) => a -> m ()
putVarInt forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length PartialMerkleTree
hashes
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ PartialMerkleTree
hashes forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize
        let ws :: [Word8]
ws = FlagBits -> [Word8]
encodeMerkleFlags FlagBits
flags
        forall (m :: * -> *) a. (MonadPut m, Integral a) => a -> m ()
putVarInt forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
ws
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Word8]
ws forall (m :: * -> *). MonadPut m => Word8 -> m ()
putWord8

instance Binary MerkleBlock where
    put :: MerkleBlock -> Put
put = forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize
    get :: Get MerkleBlock
get = forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize

instance Serialize MerkleBlock where
    put :: Putter MerkleBlock
put = forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize
    get :: Get MerkleBlock
get = forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize

-- | Unpack Merkle flags into 'FlagBits' structure.
decodeMerkleFlags :: [Word8] -> FlagBits
decodeMerkleFlags :: [Word8] -> FlagBits
decodeMerkleFlags [Word8]
ws =
    [ Bool
b | Int
p <- [Int
0 .. forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
ws forall a. Num a => a -> a -> a
* Int
8 forall a. Num a => a -> a -> a
- Int
1], Bool
b <- [forall a. Bits a => a -> Int -> Bool
testBit ([Word8]
ws forall a. [a] -> Int -> a
!! (Int
p forall a. Integral a => a -> a -> a
`div` Int
8)) (Int
p forall a. Integral a => a -> a -> a
`mod` Int
8)]
    ]

-- | Pack Merkle flags from 'FlagBits'.
encodeMerkleFlags :: FlagBits -> [Word8]
encodeMerkleFlags :: FlagBits -> [Word8]
encodeMerkleFlags FlagBits
bs = forall a b. (a -> b) -> [a] -> [b]
map FlagBits -> Word8
boolsToWord8 forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [[a]]
splitIn Int
8 FlagBits
bs

-- | Computes the height of a Merkle tree.
calcTreeHeight ::
    -- | number of transactions (leaf nodes)
    Int ->
    -- | height of the merkle tree
    Int
calcTreeHeight :: Int -> Int
calcTreeHeight Int
ntx
    | Int
ntx forall a. Ord a => a -> a -> Bool
< Int
2 = Int
0
    | forall a. Integral a => a -> Bool
even Int
ntx = Int
1 forall a. Num a => a -> a -> a
+ Int -> Int
calcTreeHeight (Int
ntx forall a. Integral a => a -> a -> a
`div` Int
2)
    | Bool
otherwise = Int -> Int
calcTreeHeight forall a b. (a -> b) -> a -> b
$ Int
ntx forall a. Num a => a -> a -> a
+ Int
1

{- | Computes the width of a Merkle tree at a specific height. The transactions
 are at height 0.
-}
calcTreeWidth ::
    -- | number of transactions (leaf nodes)
    Int ->
    -- | height at which we want to compute the width
    Int ->
    -- | width of the Merkle tree
    Int
calcTreeWidth :: Int -> Int -> Int
calcTreeWidth Int
ntx Int
h = (Int
ntx forall a. Num a => a -> a -> a
+ (Int
1 forall a. Bits a => a -> Int -> a
`shiftL` Int
h) forall a. Num a => a -> a -> a
- Int
1) forall a. Bits a => a -> Int -> a
`shiftR` Int
h

-- | Computes the root of a Merkle tree from a list of leaf node hashes.
buildMerkleRoot ::
    -- | transaction hashes (leaf nodes)
    [TxHash] ->
    -- | root of the Merkle tree
    MerkleRoot
buildMerkleRoot :: [TxHash] -> Hash256
buildMerkleRoot [TxHash]
txs = Int -> Int -> [TxHash] -> Hash256
calcHash (Int -> Int
calcTreeHeight forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxHash]
txs) Int
0 [TxHash]
txs

-- | Concatenate and compute double SHA256.
hash2 :: Hash256 -> Hash256 -> Hash256
hash2 :: Hash256 -> Hash256 -> Hash256
hash2 Hash256
a Hash256
b = forall b. ByteArrayAccess b => b -> Hash256
doubleSHA256 forall a b. (a -> b) -> a -> b
$ Put -> ByteString
runPutS (forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize Hash256
a) forall a. Semigroup a => a -> a -> a
<> Put -> ByteString
runPutS (forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize Hash256
b)

-- | Computes the hash of a specific node in a Merkle tree.
calcHash ::
    -- | height of the node
    Int ->
    -- | position of the node (0 for the leftmost node)
    Int ->
    -- | transaction hashes (leaf nodes)
    [TxHash] ->
    -- | hash of the node at the specified position
    Hash256
calcHash :: Int -> Int -> [TxHash] -> Hash256
calcHash Int
height Int
pos [TxHash]
txs
    | Int
height forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
pos forall a. Ord a => a -> a -> Bool
< Int
0 = forall a. HasCallStack => String -> a
error String
"calcHash: Invalid parameters"
    | Int
height forall a. Eq a => a -> a -> Bool
== Int
0 = TxHash -> Hash256
getTxHash forall a b. (a -> b) -> a -> b
$ [TxHash]
txs 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
height forall a. Num a => a -> a -> a
- Int
1) (Int
pos forall a. Num a => a -> a -> a
* Int
2) [TxHash]
txs
    right :: Hash256
right
        | Int
pos forall a. Num a => a -> a -> a
* Int
2 forall a. Num a => a -> a -> a
+ Int
1 forall a. Ord a => a -> a -> Bool
< Int -> Int -> Int
calcTreeWidth (forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxHash]
txs) (Int
height forall a. Num a => a -> a -> a
- Int
1) =
            Int -> Int -> [TxHash] -> Hash256
calcHash (Int
height forall a. Num a => a -> a -> a
- Int
1) (Int
pos forall a. Num a => a -> a -> a
* Int
2 forall a. Num a => a -> a -> a
+ Int
1) [TxHash]
txs
        | Bool
otherwise = Hash256
left

{- | Build a partial Merkle tree. Provide a list of tuples with all transaction
 hashes in the block, and whether the transaction is to be included in the
 partial tree. Returns a flag bits structure and the computed partial Merkle
 tree.
-}
buildPartialMerkle ::
    -- | transaction hash and whether to include
    [(TxHash, Bool)] ->
    -- | flag bits and partial Merkle tree
    (FlagBits, PartialMerkleTree)
buildPartialMerkle :: [(TxHash, Bool)] -> (FlagBits, PartialMerkleTree)
buildPartialMerkle [(TxHash, Bool)]
hs = Int -> Int -> [(TxHash, Bool)] -> (FlagBits, PartialMerkleTree)
traverseAndBuild (Int -> Int
calcTreeHeight forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [(TxHash, Bool)]
hs) Int
0 [(TxHash, Bool)]
hs

{- | Helper function to build partial Merkle tree. Used by 'buildPartialMerkle'
 above.
-}
traverseAndBuild ::
    Int -> Int -> [(TxHash, Bool)] -> (FlagBits, PartialMerkleTree)
traverseAndBuild :: Int -> Int -> [(TxHash, Bool)] -> (FlagBits, PartialMerkleTree)
traverseAndBuild Int
height Int
pos [(TxHash, Bool)]
txs
    | Int
height forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
pos forall a. Ord a => a -> a -> Bool
< Int
0 = forall a. HasCallStack => String -> a
error String
"traverseAndBuild: Invalid parameters"
    | Int
height forall a. Eq a => a -> a -> Bool
== Int
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 forall a. a -> [a] -> [a]
: FlagBits
lb forall a. [a] -> [a] -> [a]
++ FlagBits
rb, PartialMerkleTree
lh forall a. [a] -> [a] -> [a]
++ PartialMerkleTree
rh)
  where
    t :: [TxHash]
t = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(TxHash, Bool)]
txs
    s :: Int
s = Int
pos forall a. Bits a => a -> Int -> a
`shiftL` Int
height
    e :: Int
e = forall a. Ord a => a -> a -> a
min (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(TxHash, Bool)]
txs) forall a b. (a -> b) -> a -> b
$ (Int
pos forall a. Num a => a -> a -> a
+ Int
1) forall a. Bits a => a -> Int -> a
`shiftL` Int
height
    match :: Bool
match = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take (Int
e forall a. Num a => a -> a -> a
- Int
s) forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
s [(TxHash, Bool)]
txs
    (FlagBits
lb, PartialMerkleTree
lh) = Int -> Int -> [(TxHash, Bool)] -> (FlagBits, PartialMerkleTree)
traverseAndBuild (Int
height forall a. Num a => a -> a -> a
- Int
1) (Int
pos forall a. Num a => a -> a -> a
* Int
2) [(TxHash, Bool)]
txs
    (FlagBits
rb, PartialMerkleTree
rh)
        | (Int
pos forall a. Num a => a -> a -> a
* Int
2 forall a. Num a => a -> a -> a
+ Int
1) forall a. Ord a => a -> a -> Bool
< Int -> Int -> Int
calcTreeWidth (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(TxHash, Bool)]
txs) (Int
height forall a. Num a => a -> a -> a
- Int
1) =
            Int -> Int -> [(TxHash, Bool)] -> (FlagBits, PartialMerkleTree)
traverseAndBuild (Int
height forall a. Num a => a -> a -> a
- Int
1) (Int
pos forall a. Num a => a -> a -> a
* Int
2 forall a. Num a => a -> a -> a
+ Int
1) [(TxHash, Bool)]
txs
        | Bool
otherwise = ([], [])

-- | Helper function to extract transaction hashes from partial Merkle tree.
traverseAndExtract ::
    Int ->
    Int ->
    Int ->
    FlagBits ->
    PartialMerkleTree ->
    Maybe (MerkleRoot, [TxHash], Int, Int)
traverseAndExtract :: Int
-> Int
-> Int
-> FlagBits
-> PartialMerkleTree
-> Maybe (Hash256, [TxHash], Int, Int)
traverseAndExtract Int
height Int
pos Int
ntx FlagBits
flags PartialMerkleTree
hashes
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null FlagBits
flags = forall a. Maybe a
Nothing
    | Int
height forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
match = Maybe (Hash256, [TxHash], Int, Int)
leafResult
    | forall a. Maybe a -> Bool
isNothing Maybe (Hash256, [TxHash], Int, Int)
leftM = forall a. Maybe a
Nothing
    | (Int
pos forall a. Num a => a -> a -> a
* Int
2 forall a. Num a => a -> a -> a
+ Int
1) forall a. Ord a => a -> a -> Bool
>= Int -> Int -> Int
calcTreeWidth Int
ntx (Int
height forall a. Num a => a -> a -> a
- Int
1) =
        forall a. a -> Maybe a
Just (Hash256 -> Hash256 -> Hash256
hash2 Hash256
lh Hash256
lh, [TxHash]
lm, Int
lcf forall a. Num a => a -> a -> a
+ Int
1, Int
lch)
    | forall a. Maybe a -> Bool
isNothing Maybe (Hash256, [TxHash], Int, Int)
rightM = forall a. Maybe a
Nothing
    | Bool
otherwise =
        forall a. a -> Maybe a
Just (Hash256 -> Hash256 -> Hash256
hash2 Hash256
lh Hash256
rh, [TxHash]
lm forall a. [a] -> [a] -> [a]
++ [TxHash]
rm, Int
lcf forall a. Num a => a -> a -> a
+ Int
rcf forall a. Num a => a -> a -> a
+ Int
1, Int
lch forall a. Num a => a -> a -> a
+ Int
rch)
  where
    leafResult :: Maybe (Hash256, [TxHash], Int, Int)
leafResult
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null PartialMerkleTree
hashes = forall a. Maybe a
Nothing
        | Bool
otherwise = forall a. a -> Maybe a
Just (Hash256
h, [Hash256 -> TxHash
TxHash Hash256
h | Int
height forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Bool
match], Int
1, Int
1)
    (Bool
match : FlagBits
fs) = FlagBits
flags
    (Hash256
h : PartialMerkleTree
_) = PartialMerkleTree
hashes
    leftM :: Maybe (Hash256, [TxHash], Int, Int)
leftM = Int
-> Int
-> Int
-> FlagBits
-> PartialMerkleTree
-> Maybe (Hash256, [TxHash], Int, Int)
traverseAndExtract (Int
height forall a. Num a => a -> a -> a
- Int
1) (Int
pos forall a. Num a => a -> a -> a
* Int
2) Int
ntx FlagBits
fs PartialMerkleTree
hashes
    (Hash256
lh, [TxHash]
lm, Int
lcf, Int
lch) = forall a. a -> Maybe a -> a
fromMaybe 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
height forall a. Num a => a -> a -> a
- Int
1)
            (Int
pos forall a. Num a => a -> a -> a
* Int
2 forall a. Num a => a -> a -> a
+ Int
1)
            Int
ntx
            (forall a. Int -> [a] -> [a]
drop Int
lcf FlagBits
fs)
            (forall a. Int -> [a] -> [a]
drop Int
lch PartialMerkleTree
hashes)
    (Hash256
rh, [TxHash]
rm, Int
rcf, Int
rch) = forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
e Maybe (Hash256, [TxHash], Int, Int)
rightM
    e :: a
e = forall a. HasCallStack => String -> a
error String
"traverseAndExtract: unexpected error extracting a Maybe value"

{- | Extracts the matching hashes from a partial merkle tree. This will return
 the list of transaction hashes that have been included (set to true) in
 a call to 'buildPartialMerkle'.
-}
extractMatches ::
    Network ->
    FlagBits ->
    PartialMerkleTree ->
    -- | number of transaction at height 0 (leaf nodes)
    Int ->
    -- | Merkle root and list of matching transaction hashes
    Either String (MerkleRoot, [TxHash])
extractMatches :: Network
-> FlagBits
-> PartialMerkleTree
-> Int
-> Either String (Hash256, [TxHash])
extractMatches Network
net FlagBits
flags PartialMerkleTree
hashes Int
ntx
    | Int
ntx forall a. Eq a => a -> a -> Bool
== Int
0 =
        forall a b. a -> Either a b
Left
            String
"extractMatches: number of transactions can not be 0"
    | Int
ntx forall a. Ord a => a -> a -> Bool
> Network -> Int
getMaxBlockSize Network
net forall a. Integral a => a -> a -> a
`div` Int
60 =
        forall a b. a -> Either a b
Left
            String
"extractMatches: number of transactions excessively high"
    | forall (t :: * -> *) a. Foldable t => t a -> Int
length PartialMerkleTree
hashes forall a. Ord a => a -> a -> Bool
> Int
ntx =
        forall a b. a -> Either a b
Left
            String
"extractMatches: More hashes provided than the number of transactions"
    | forall (t :: * -> *) a. Foldable t => t a -> Int
length FlagBits
flags forall a. Ord a => a -> a -> Bool
< forall (t :: * -> *) a. Foldable t => t a -> Int
length PartialMerkleTree
hashes =
        forall a b. a -> Either a b
Left
            String
"extractMatches: At least one bit per node and one bit per hash"
    | forall a. Maybe a -> Bool
isNothing Maybe (Hash256, [TxHash], Int, Int)
resM =
        forall a b. a -> Either a b
Left
            String
"extractMatches: traverseAndExtract failed"
    | (Int
nBitsUsed forall a. Num a => a -> a -> a
+ Int
7) forall a. Integral a => a -> a -> a
`div` Int
8 forall a. Eq a => a -> a -> Bool
/= (forall (t :: * -> *) a. Foldable t => t a -> Int
length FlagBits
flags forall a. Num a => a -> a -> a
+ Int
7) forall a. Integral a => a -> a -> a
`div` Int
8 =
        forall a b. a -> Either a b
Left
            String
"extractMatches: All bits were not consumed"
    | Int
nHashUsed forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length PartialMerkleTree
hashes =
        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
            String
"extractMatches: All hashes were not consumed: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
nHashUsed
    | Bool
otherwise = 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) Int
0 Int
ntx FlagBits
flags PartialMerkleTree
hashes
    (Hash256
merkRoot, [TxHash]
matches, Int
nBitsUsed, Int
nHashUsed) = forall a. a -> Maybe a -> a
fromMaybe forall {a}. a
e Maybe (Hash256, [TxHash], Int, Int)
resM
    e :: a
e = forall a. HasCallStack => String -> a
error String
"extractMatches: unexpected error extracting a Maybe value"

{- | Helper function to split a list in chunks 'Int' length. Last chunk may be
 smaller.
-}
splitIn :: Int -> [a] -> [[a]]
splitIn :: forall a. Int -> [a] -> [[a]]
splitIn Int
_ [] = []
splitIn Int
c [a]
xs = [a]
xs1 forall a. a -> [a] -> [a]
: forall a. Int -> [a] -> [[a]]
splitIn Int
c [a]
xs2
  where
    ([a]
xs1, [a]
xs2) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
c [a]
xs

-- | Pack up to eight bools in a byte.
boolsToWord8 :: [Bool] -> Word8
boolsToWord8 :: FlagBits -> Word8
boolsToWord8 [] = Word8
0
boolsToWord8 FlagBits
xs = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall a. Bits a => a -> Int -> a
setBit Word8
0 (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip FlagBits
xs [Int
0 .. Int
7])

-- | Get matching transactions from Merkle block.
merkleBlockTxs :: Network -> MerkleBlock -> Either String [TxHash]
merkleBlockTxs :: Network -> MerkleBlock -> Either String [TxHash]
merkleBlockTxs Network
net MerkleBlock
b =
    let flags :: FlagBits
flags = MerkleBlock -> FlagBits
mFlags MerkleBlock
b
        hs :: PartialMerkleTree
hs = MerkleBlock -> PartialMerkleTree
mHashes MerkleBlock
b
        n :: Int
n = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ MerkleBlock -> Word32
merkleTotalTxns MerkleBlock
b
        merkle :: Hash256
merkle = BlockHeader -> Hash256
merkleRoot forall a b. (a -> b) -> a -> b
$ MerkleBlock -> BlockHeader
merkleHeader MerkleBlock
b
     in do
            (Hash256
root, [TxHash]
ths) <- Network
-> FlagBits
-> PartialMerkleTree
-> Int
-> Either String (Hash256, [TxHash])
extractMatches Network
net FlagBits
flags PartialMerkleTree
hs Int
n
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Hash256
root forall a. Eq a => a -> a -> Bool
/= Hash256
merkle) forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
"merkleBlockTxs: Merkle root incorrect"
            forall (m :: * -> *) a. Monad m => a -> m a
return [TxHash]
ths

-- | Check if Merkle block root is valid against the block header.
testMerkleRoot :: Network -> MerkleBlock -> Bool
testMerkleRoot :: Network -> MerkleBlock -> Bool
testMerkleRoot Network
net = forall a b. Either a b -> Bool
isRight forall b c a. (b -> c) -> (a -> b) -> a -> c
. Network -> MerkleBlock -> Either String [TxHash]
merkleBlockTxs Network
net