{-# 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
(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 Serial MerkleBlock where
    deserialize :: m MerkleBlock
deserialize = do
        BlockHeader
header <- m BlockHeader
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
        Word32
ntx <- m Word32
forall (m :: * -> *). MonadGet m => m Word32
getWord32le
        (VarInt Word64
matchLen) <- m VarInt
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
        PartialMerkleTree
hashes <- Int -> m Hash256 -> m 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) m Hash256
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
        (VarInt Word64
flagLen) <- m VarInt
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
deserialize
        [Word8]
ws <- Int -> m Word8 -> m [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) m Word8
forall (m :: * -> *). MonadGet m => m Word8
getWord8
        MerkleBlock -> m MerkleBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (MerkleBlock -> m MerkleBlock) -> MerkleBlock -> m 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)

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

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

instance Serialize MerkleBlock where
    put :: Putter MerkleBlock
put = Putter MerkleBlock
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize
    get :: Get MerkleBlock
get = Get MerkleBlock
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 .. [Word8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
ws Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
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` Int
8)) (Int
p Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8)]
    ]

-- | Pack Merkle flags from 'FlagBits'.
encodeMerkleFlags :: FlagBits -> [Word8]
encodeMerkleFlags :: FlagBits -> [Word8]
encodeMerkleFlags 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 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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 = Int
0
    | Int -> Bool
forall a. Integral a => a -> Bool
even Int
ntx = Int
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` Int
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
+ 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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
h) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
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 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [TxHash] -> Int
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 = ByteString -> Hash256
forall b. ByteArrayAccess b => b -> Hash256
doubleSHA256 (ByteString -> Hash256) -> ByteString -> Hash256
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
runPutS (Hash256 -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
serialize Hash256
a) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Put -> ByteString
runPutS (Hash256 -> Put
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
pos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = String -> Hash256
forall a. HasCallStack => String -> a
error String
"calcHash: Invalid parameters"
    | Int
height Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
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
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) [TxHash]
txs
    right :: Hash256
right
        | Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) =
            Int -> Int -> [TxHash] -> Hash256
calcHash (Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
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 (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) 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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
pos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = String -> (FlagBits, PartialMerkleTree)
forall a. HasCallStack => String -> a
error String
"traverseAndBuild: Invalid parameters"
    | Int
height Int -> Int -> Bool
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 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
+ Int
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
    (FlagBits
lb, PartialMerkleTree
lh) = Int -> Int -> [(TxHash, Bool)] -> (FlagBits, PartialMerkleTree)
traverseAndBuild (Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) [(TxHash, Bool)]
txs
    (FlagBits
rb, PartialMerkleTree
rh)
        | (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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
- Int
1) =
            Int -> Int -> [(TxHash, Bool)] -> (FlagBits, PartialMerkleTree)
traverseAndBuild (Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
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
    | 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
== Int
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
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Int -> Int
calcTreeWidth Int
ntx (Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
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
lcf Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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
lcf Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rcf Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
lch Int -> 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
== 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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) Int
ntx FlagBits
fs PartialMerkleTree
hashes
    (Hash256
lh, [TxHash]
lm, Int
lcf, 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
height Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
            (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
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)
    (Hash256
rh, [TxHash]
rm, Int
rcf, 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 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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 =
        String -> Either String (Hash256, [TxHash])
forall a b. a -> Either a b
Left
            String
"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` Int
60 =
        String -> Either String (Hash256, [TxHash])
forall a b. a -> Either a b
Left
            String
"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
            String
"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
            String
"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
            String
"extractMatches: traverseAndExtract failed"
    | (Int
nBitsUsed Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= (FlagBits -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FlagBits
flags Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8 =
        String -> Either String (Hash256, [TxHash])
forall a b. a -> Either a b
Left
            String
"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
$
            String
"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) Int
0 Int
ntx FlagBits
flags PartialMerkleTree
hashes
    (Hash256
merkRoot, [TxHash]
matches, Int
nBitsUsed, 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 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 :: Int -> [a] -> [[a]]
splitIn Int
_ [] = []
splitIn Int
c [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
    ([a]
xs1, [a]
xs2) = Int -> [a] -> ([a], [a])
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 = (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 Word8
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 [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 = 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
            (Hash256
root, [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 String
"merkleBlockTxs: Merkle root incorrect"
            [TxHash] -> Either String [TxHash]
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 = 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