{-# 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.Constants
import           Haskoin.Crypto.Hash
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 matchLen :: 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 flagLen :: 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 h :: BlockHeader
h ntx :: Word32
ntx hashes :: PartialMerkleTree
hashes flags :: 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 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) ]
    ]

-- | Pack Merkle flags from 'FlagBits'.
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

-- | Computes the height of a Merkle tree.
calcTreeHeight :: Int -- ^ number of transactions (leaf nodes)
               -> Int -- ^ height of the merkle tree
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

-- | Computes the width of a Merkle tree at a specific height. The transactions
-- are at height 0.
calcTreeWidth :: Int -- ^ number of transactions (leaf nodes)
              -> Int -- ^ height at which we want to compute the width
              -> Int -- ^ width of the Merkle tree
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

-- | Computes the root of a Merkle tree from a list of leaf node hashes.
buildMerkleRoot :: [TxHash]   -- ^ transaction hashes (leaf nodes)
                -> MerkleRoot -- ^ root of the Merkle tree
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

-- | Concatenate and compute double SHA256.
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
$ 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 :: Int       -- ^ height of the node
         -> Int       -- ^ position of the node (0 for the leftmost node)
         -> [TxHash]  -- ^ transaction hashes (leaf nodes)
         -> Hash256   -- ^ hash of the node at the specified position
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

-- | 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 ::
       [(TxHash, Bool)] -- ^ transaction hash and whether to include
    -> (FlagBits, PartialMerkleTree) -- ^ flag bits and partial Merkle tree
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

-- | 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 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 = ([], [])

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

-- | 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
               -> Int -- ^ number of transaction at height 0 (leaf nodes)
               -> Either String (MerkleRoot, [TxHash])
               -- ^ Merkle root and list of matching transaction hashes
extractMatches :: Network
-> FlagBits
-> PartialMerkleTree
-> Int
-> Either String (Hash256, [TxHash])
extractMatches 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"

-- | Helper function to split a list in chunks 'Int' length. Last chunk may be
-- smaller.
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

-- | Pack up to eight bools in a byte.
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])

-- | Get matching transactions from Merkle block.
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

-- | Check if Merkle block root is valid against the block header.
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