{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Tahoe.CHK.Merkle (
    MerkleTree (MerkleNode, MerkleLeaf),
    Direction (..),
    leafNumberToNode,
    leafNumberToNodeNumber,
    breadthFirstList,
    merklePathLengthForSize,
    heightForLeafCount,
    makeTree,
    makeTreePartial,
    merkleProof,
    checkMerkleProof,
    neededHashes,
    firstLeafNum,
    rootHash,
    pairHash,
    emptyLeafHash,
    size,
    height,
    mapTree,
    merklePath,
    leafHashes,
    -- exported for testing in ghci
    treeFromRows,
    buildTreeOutOfAllTheNodes,
    dumpTree,
) where

import Control.Monad ((>=>))
import Crypto.Hash (HashAlgorithm (hashDigestSize), digestFromByteString)
import Data.Binary (Binary (get, put))
import Data.Binary.Get (getRemainingLazyByteString)
import Data.Binary.Put (putByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as LBS
import Data.Function (on)
import Data.List.HT (
    padLeft,
 )
import Data.Text (Text)
import qualified Data.Text as T
import Data.TreeDiff.Class (ToExpr (..))
import Data.Tuple.HT (
    mapFst,
 )
import GHC.Generics (Generic)
import Tahoe.CHK.Crypto (
    taggedHash',
    taggedPairHash',
    toBytes,
 )
import Tahoe.CHK.SHA256d (Digest' (..), SHA256d)
import Tahoe.Util (
    chunkedBy,
    nextPowerOf,
    toBinary,
 )

{- | A Merkle tree parameterized on a value type and hash algorithm.  The value
 type is phantom and is intended to help avoid mixing up opaque hashes from
 Merkle trees used for different purposes.
-}
data MerkleTree value hash
    = MerkleLeaf (Digest' hash)
    | MerkleNode (Digest' hash) (MerkleTree value hash) (MerkleTree value hash)
    deriving (MerkleTree value hash -> MerkleTree value hash -> Bool
(MerkleTree value hash -> MerkleTree value hash -> Bool)
-> (MerkleTree value hash -> MerkleTree value hash -> Bool)
-> Eq (MerkleTree value hash)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall value hash.
MerkleTree value hash -> MerkleTree value hash -> Bool
/= :: MerkleTree value hash -> MerkleTree value hash -> Bool
$c/= :: forall value hash.
MerkleTree value hash -> MerkleTree value hash -> Bool
== :: MerkleTree value hash -> MerkleTree value hash -> Bool
$c== :: forall value hash.
MerkleTree value hash -> MerkleTree value hash -> Bool
Eq, Eq (MerkleTree value hash)
Eq (MerkleTree value hash)
-> (MerkleTree value hash -> MerkleTree value hash -> Ordering)
-> (MerkleTree value hash -> MerkleTree value hash -> Bool)
-> (MerkleTree value hash -> MerkleTree value hash -> Bool)
-> (MerkleTree value hash -> MerkleTree value hash -> Bool)
-> (MerkleTree value hash -> MerkleTree value hash -> Bool)
-> (MerkleTree value hash
    -> MerkleTree value hash -> MerkleTree value hash)
-> (MerkleTree value hash
    -> MerkleTree value hash -> MerkleTree value hash)
-> Ord (MerkleTree value hash)
MerkleTree value hash -> MerkleTree value hash -> Bool
MerkleTree value hash -> MerkleTree value hash -> Ordering
MerkleTree value hash
-> MerkleTree value hash -> MerkleTree value hash
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall value hash. Eq (MerkleTree value hash)
forall value hash.
MerkleTree value hash -> MerkleTree value hash -> Bool
forall value hash.
MerkleTree value hash -> MerkleTree value hash -> Ordering
forall value hash.
MerkleTree value hash
-> MerkleTree value hash -> MerkleTree value hash
min :: MerkleTree value hash
-> MerkleTree value hash -> MerkleTree value hash
$cmin :: forall value hash.
MerkleTree value hash
-> MerkleTree value hash -> MerkleTree value hash
max :: MerkleTree value hash
-> MerkleTree value hash -> MerkleTree value hash
$cmax :: forall value hash.
MerkleTree value hash
-> MerkleTree value hash -> MerkleTree value hash
>= :: MerkleTree value hash -> MerkleTree value hash -> Bool
$c>= :: forall value hash.
MerkleTree value hash -> MerkleTree value hash -> Bool
> :: MerkleTree value hash -> MerkleTree value hash -> Bool
$c> :: forall value hash.
MerkleTree value hash -> MerkleTree value hash -> Bool
<= :: MerkleTree value hash -> MerkleTree value hash -> Bool
$c<= :: forall value hash.
MerkleTree value hash -> MerkleTree value hash -> Bool
< :: MerkleTree value hash -> MerkleTree value hash -> Bool
$c< :: forall value hash.
MerkleTree value hash -> MerkleTree value hash -> Bool
compare :: MerkleTree value hash -> MerkleTree value hash -> Ordering
$ccompare :: forall value hash.
MerkleTree value hash -> MerkleTree value hash -> Ordering
$cp1Ord :: forall value hash. Eq (MerkleTree value hash)
Ord, (forall x. MerkleTree value hash -> Rep (MerkleTree value hash) x)
-> (forall x.
    Rep (MerkleTree value hash) x -> MerkleTree value hash)
-> Generic (MerkleTree value hash)
forall x. Rep (MerkleTree value hash) x -> MerkleTree value hash
forall x. MerkleTree value hash -> Rep (MerkleTree value hash) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall value hash x.
Rep (MerkleTree value hash) x -> MerkleTree value hash
forall value hash x.
MerkleTree value hash -> Rep (MerkleTree value hash) x
$cto :: forall value hash x.
Rep (MerkleTree value hash) x -> MerkleTree value hash
$cfrom :: forall value hash x.
MerkleTree value hash -> Rep (MerkleTree value hash) x
Generic, [MerkleTree value hash] -> Expr
MerkleTree value hash -> Expr
(MerkleTree value hash -> Expr)
-> ([MerkleTree value hash] -> Expr)
-> ToExpr (MerkleTree value hash)
forall a. (a -> Expr) -> ([a] -> Expr) -> ToExpr a
forall value hash. [MerkleTree value hash] -> Expr
forall value hash. MerkleTree value hash -> Expr
listToExpr :: [MerkleTree value hash] -> Expr
$clistToExpr :: forall value hash. [MerkleTree value hash] -> Expr
toExpr :: MerkleTree value hash -> Expr
$ctoExpr :: forall value hash. MerkleTree value hash -> Expr
ToExpr)

-- | Count the number of nodes in a tree.
size :: MerkleTree v a -> Int
size :: MerkleTree v a -> Int
size = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int)
-> (MerkleTree v a -> [Int]) -> MerkleTree v a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MerkleTree v a -> Int) -> MerkleTree v a -> [Int]
forall v a b. (MerkleTree v a -> b) -> MerkleTree v a -> [b]
mapTree (Int -> MerkleTree v a -> Int
forall a b. a -> b -> a
const Int
1)

-- | Measure the height of a tree.
height :: MerkleTree v a -> Int
height :: MerkleTree v a -> Int
height (MerkleLeaf Digest' a
_) = Int
1
height (MerkleNode Digest' a
_ MerkleTree v a
left MerkleTree v a
_) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ MerkleTree v a -> Int
forall v a. MerkleTree v a -> Int
height MerkleTree v a
left

{- | Compute the minimum height for a tree that can hold the given number of
 leaves.
-}
heightForLeafCount :: Integral n => n -> Int
heightForLeafCount :: n -> Int
heightForLeafCount n
num = Float -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Float -> Int) -> Float -> Int
forall a b. (a -> b) -> a -> b
$ Float -> Float -> Float
forall a. Floating a => a -> a -> a
logBase (Float
2 :: Float) (n -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral n
num)

mapTree :: (MerkleTree v a -> b) -> MerkleTree v a -> [b]
mapTree :: (MerkleTree v a -> b) -> MerkleTree v a -> [b]
mapTree MerkleTree v a -> b
f l :: MerkleTree v a
l@(MerkleLeaf Digest' a
_) = [MerkleTree v a -> b
f MerkleTree v a
l]
mapTree MerkleTree v a -> b
f n :: MerkleTree v a
n@(MerkleNode Digest' a
_ MerkleTree v a
left MerkleTree v a
right) = MerkleTree v a -> b
f MerkleTree v a
n b -> [b] -> [b]
forall a. a -> [a] -> [a]
: (MerkleTree v a -> b) -> MerkleTree v a -> [b]
forall v a b. (MerkleTree v a -> b) -> MerkleTree v a -> [b]
mapTree MerkleTree v a -> b
f MerkleTree v a
left [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
++ (MerkleTree v a -> b) -> MerkleTree v a -> [b]
forall v a b. (MerkleTree v a -> b) -> MerkleTree v a -> [b]
mapTree MerkleTree v a -> b
f MerkleTree v a
right

instance (HashAlgorithm hash) => Show (MerkleTree value hash) where
    show :: MerkleTree value hash -> String
show (MerkleLeaf Digest' hash
value) = String
"MerkleLeaf " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Digest' hash -> String
forall a. Show a => a -> String
show Digest' hash
value
    show (MerkleNode Digest' hash
value MerkleTree value hash
left MerkleTree value hash
right) =
        Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
            [Text] -> Text
T.concat
                [ Text
"MerkleNode " :: T.Text
                , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Digest' hash -> String
forall a. Show a => a -> String
show Digest' hash
value
                , Text
" ("
                , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ MerkleTree value hash -> String
forall a. Show a => a -> String
show MerkleTree value hash
left
                , Text
")"
                , Text
" ("
                , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ MerkleTree value hash -> String
forall a. Show a => a -> String
show MerkleTree value hash
right
                , Text
")"
                ]

emptyLeafHash :: HashAlgorithm hash => Int -> Digest' hash
emptyLeafHash :: Int -> Digest' hash
emptyLeafHash = ByteString -> ByteString -> Digest' hash
forall hash.
HashAlgorithm hash =>
ByteString -> ByteString -> Digest' hash
taggedHash' ByteString
"Merkle tree empty leaf" (ByteString -> Digest' hash)
-> (Int -> ByteString) -> Int -> Digest' hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
C8.pack (String -> ByteString) -> (Int -> String) -> Int -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show

pairHash :: HashAlgorithm a => B.ByteString -> B.ByteString -> Digest' a
pairHash :: ByteString -> ByteString -> Digest' a
pairHash = ByteString -> ByteString -> ByteString -> Digest' a
forall hash.
HashAlgorithm hash =>
ByteString -> ByteString -> ByteString -> Digest' hash
taggedPairHash' ByteString
"Merkle tree internal node"

rootHash :: MerkleTree v a -> Digest' a
rootHash :: MerkleTree v a -> Digest' a
rootHash (MerkleLeaf Digest' a
value) = Digest' a
value
rootHash (MerkleNode Digest' a
value MerkleTree v a
_ MerkleTree v a
_) = Digest' a
value

-- Like makeTree but error on empty list
makeTreePartial :: HashAlgorithm hash => [Digest' hash] -> MerkleTree value hash
makeTreePartial :: [Digest' hash] -> MerkleTree value hash
makeTreePartial = Maybe (MerkleTree value hash) -> MerkleTree value hash
forall p. Maybe p -> p
unJust (Maybe (MerkleTree value hash) -> MerkleTree value hash)
-> ([Digest' hash] -> Maybe (MerkleTree value hash))
-> [Digest' hash]
-> MerkleTree value hash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Digest' hash] -> Maybe (MerkleTree value hash)
forall hash value.
HashAlgorithm hash =>
[Digest' hash] -> Maybe (MerkleTree value hash)
makeTree
  where
    unJust :: Maybe p -> p
unJust Maybe p
Nothing = String -> p
forall a. HasCallStack => String -> a
error String
"Merkle.makeTreePartial failed to make a tree"
    unJust (Just p
t) = p
t

-- Make a merkle tree for the given values.  Extra values are generated to
-- fill the tree if necessary.  The given values are the values of the leaf
-- nodes.
makeTree :: forall hash value. HashAlgorithm hash => [Digest' hash] -> Maybe (MerkleTree value hash)
makeTree :: [Digest' hash] -> Maybe (MerkleTree value hash)
makeTree [] = Maybe (MerkleTree value hash)
forall a. Maybe a
Nothing
makeTree [Digest' hash]
leaves =
    MerkleTree value hash -> Maybe (MerkleTree value hash)
forall a. a -> Maybe a
Just (MerkleTree value hash -> Maybe (MerkleTree value hash))
-> MerkleTree value hash -> Maybe (MerkleTree value hash)
forall a b. (a -> b) -> a -> b
$ [Digest' hash] -> MerkleTree value hash
makeTree' ([Digest' hash] -> [Digest' hash]
pad [Digest' hash]
leaves)
  where
    -- Pad the leaves out to the next power of two so the tree is full.
    pad :: [Digest' hash] -> [Digest' hash]
    pad :: [Digest' hash] -> [Digest' hash]
pad [Digest' hash]
leaves' = [Digest' hash]
leaves' [Digest' hash] -> [Digest' hash] -> [Digest' hash]
forall a. [a] -> [a] -> [a]
++ Int -> [Digest' hash]
padding ([Digest' hash] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Digest' hash]
leaves')

    -- Create the padding for the pad function.  The number of leaves in the
    -- tree must be a power of 2 (a height zero tree has 2 ^ 0 leaves, a
    -- height one tree has 2 ^ 1 leaves, etc) so compute a number of empty
    -- leaves that when added to the non-empty leaves gives us a power of 2.
    -- This could be none if we happened to already have a number of leaves
    -- that is a power of 2.
    --
    -- This function assumes that the number of non-empty leaves is at least
    -- half the number of total leaves.  If it is fewer it will create less
    -- padding than necessary.  This should be reasonable since if there fewer
    -- leaves then a smaller tree could hold them all.
    padding :: Int -> [Digest' hash]
    padding :: Int -> [Digest' hash]
padding Int
numLeaves = Int -> Digest' hash
forall hash. HashAlgorithm hash => Int -> Digest' hash
emptyLeafHash (Int -> Digest' hash) -> [Int] -> [Digest' hash]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
numLeaves .. Int -> Int -> Int
forall p. (Ord p, Num p) => p -> p -> p
nextPowerOf Int
2 Int
numLeaves Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]

    -- Turn a length-of-power-of-2 list into a tree
    makeTree' :: [Digest' hash] -> MerkleTree value hash
    makeTree' :: [Digest' hash] -> MerkleTree value hash
makeTree' [Digest' hash
x] = Digest' hash -> MerkleTree value hash
forall value hash. Digest' hash -> MerkleTree value hash
MerkleLeaf Digest' hash
x
    makeTree' [Digest' hash]
xs =
        MerkleTree value hash
-> MerkleTree value hash -> MerkleTree value hash
makeNode ([Digest' hash] -> MerkleTree value hash
makeTree' [Digest' hash]
left) ([Digest' hash] -> MerkleTree value hash
makeTree' [Digest' hash]
right)
      where
        ([Digest' hash]
left, [Digest' hash]
right) = Int -> [Digest' hash] -> ([Digest' hash], [Digest' hash])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Digest' hash] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Digest' hash]
xs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) [Digest' hash]
xs

    -- Make a parent node referencing two given child nodes, calculating the
    -- parent node's hash in the process.
    makeNode :: MerkleTree value hash -> MerkleTree value hash -> MerkleTree value hash
    makeNode :: MerkleTree value hash
-> MerkleTree value hash -> MerkleTree value hash
makeNode MerkleTree value hash
left MerkleTree value hash
right = Digest' hash
-> MerkleTree value hash
-> MerkleTree value hash
-> MerkleTree value hash
forall value hash.
Digest' hash
-> MerkleTree value hash
-> MerkleTree value hash
-> MerkleTree value hash
MerkleNode ((ByteString -> ByteString -> Digest' hash
forall hash.
HashAlgorithm hash =>
ByteString -> ByteString -> Digest' hash
pairHash (ByteString -> ByteString -> Digest' hash)
-> (MerkleTree value hash -> ByteString)
-> MerkleTree value hash
-> MerkleTree value hash
-> Digest' hash
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Digest' hash -> ByteString
forall a. ByteArrayAccess a => a -> ByteString
toBytes (Digest' hash -> ByteString)
-> (MerkleTree value hash -> Digest' hash)
-> MerkleTree value hash
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MerkleTree value hash -> Digest' hash
forall v a. MerkleTree v a -> Digest' a
rootHash) MerkleTree value hash
left MerkleTree value hash
right) MerkleTree value hash
left MerkleTree value hash
right

-- | Represent a direction to take when walking down a binary tree.
data Direction = TurnLeft | TurnRight deriving (Int -> Direction -> ShowS
[Direction] -> ShowS
Direction -> String
(Int -> Direction -> ShowS)
-> (Direction -> String)
-> ([Direction] -> ShowS)
-> Show Direction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Direction] -> ShowS
$cshowList :: [Direction] -> ShowS
show :: Direction -> String
$cshow :: Direction -> String
showsPrec :: Int -> Direction -> ShowS
$cshowsPrec :: Int -> Direction -> ShowS
Show, Eq Direction
Eq Direction
-> (Direction -> Direction -> Ordering)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool)
-> (Direction -> Direction -> Direction)
-> (Direction -> Direction -> Direction)
-> Ord Direction
Direction -> Direction -> Bool
Direction -> Direction -> Ordering
Direction -> Direction -> Direction
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Direction -> Direction -> Direction
$cmin :: Direction -> Direction -> Direction
max :: Direction -> Direction -> Direction
$cmax :: Direction -> Direction -> Direction
>= :: Direction -> Direction -> Bool
$c>= :: Direction -> Direction -> Bool
> :: Direction -> Direction -> Bool
$c> :: Direction -> Direction -> Bool
<= :: Direction -> Direction -> Bool
$c<= :: Direction -> Direction -> Bool
< :: Direction -> Direction -> Bool
$c< :: Direction -> Direction -> Bool
compare :: Direction -> Direction -> Ordering
$ccompare :: Direction -> Direction -> Ordering
$cp1Ord :: Eq Direction
Ord, Direction -> Direction -> Bool
(Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool) -> Eq Direction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Direction -> Direction -> Bool
$c/= :: Direction -> Direction -> Bool
== :: Direction -> Direction -> Bool
$c== :: Direction -> Direction -> Bool
Eq)

{- | Return a list of tuples of node numbers and corresponding merkle hashes.
 The node numbers correspond to a numbering of the nodes in the tree where the
 root node is numbered 1, each node's left child is the node's number times
 two, and the node's right child is the node's number times two plus one.
-}
merkleProof :: MerkleTree v a -> Int -> Maybe [(Int, Digest' a)]
merkleProof :: MerkleTree v a -> Int -> Maybe [(Int, Digest' a)]
merkleProof MerkleTree v a
tree Int
targetLeaf = Int -> MerkleTree v a -> [Direction] -> Maybe [(Int, Digest' a)]
forall v a.
Int -> MerkleTree v a -> [Direction] -> Maybe [(Int, Digest' a)]
merkleProof' Int
1 MerkleTree v a
tree ([Direction] -> Maybe [(Int, Digest' a)])
-> [Direction] -> Maybe [(Int, Digest' a)]
forall a b. (a -> b) -> a -> b
$ Int -> Int -> [Direction]
merklePath (MerkleTree v a -> Int
forall v a. MerkleTree v a -> Int
height MerkleTree v a
tree) Int
targetLeaf

{- | Check a merkle proof for validity.  The proof is valid if it represents
 the correct hash chain from the given leaf to the given root.
-}
checkMerkleProof ::
    forall n hash.
    (Integral n, HashAlgorithm hash) =>
    -- | The proof to check.
    [(n, Digest' hash)] ->
    -- | The root hash of the merkle tree against which to check the proof.
    Digest' hash ->
    -- | The leaf hash against which to check the proof.
    Digest' hash ->
    -- | True if the proof checks out, False otherwise.
    Bool
checkMerkleProof :: [(n, Digest' hash)] -> Digest' hash -> Digest' hash -> Bool
checkMerkleProof [(n, Digest' hash)]
proof Digest' hash
expectedRootHash Digest' hash
leafHash = Digest' hash
expectedRootHash Digest' hash -> Digest' hash -> Bool
forall a. Eq a => a -> a -> Bool
== [(n, Digest' hash)] -> Digest' hash
check [(n, Digest' hash)]
proof
  where
    check :: [(n, Digest' hash)] -> Digest' hash
    check :: [(n, Digest' hash)] -> Digest' hash
check [] = Digest' hash
leafHash
    check ((n
nodeNum, Digest' hash
nodeHash) : [(n, Digest' hash)]
more)
        | n -> Bool
forall a. Integral a => a -> Bool
even n
nodeNum = Digest' hash -> Digest' hash -> Digest' hash
pairHashD Digest' hash
nodeHash ([(n, Digest' hash)] -> Digest' hash
check [(n, Digest' hash)]
more)
        | Bool
otherwise = Digest' hash -> Digest' hash -> Digest' hash
pairHashD ([(n, Digest' hash)] -> Digest' hash
check [(n, Digest' hash)]
more) Digest' hash
nodeHash
      where
        pairHashD :: Digest' hash -> Digest' hash -> Digest' hash
pairHashD = ByteString -> ByteString -> Digest' hash
forall hash.
HashAlgorithm hash =>
ByteString -> ByteString -> Digest' hash
pairHash (ByteString -> ByteString -> Digest' hash)
-> (Digest' hash -> ByteString)
-> Digest' hash
-> Digest' hash
-> Digest' hash
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Digest' hash -> ByteString
forall a. ByteArrayAccess a => a -> ByteString
toBytes

{- | Compute the path to a leaf from the root of a merkle tree of a certain
 height.
-}
merklePath :: Int -> Int -> [Direction]
merklePath :: Int -> Int -> [Direction]
merklePath Int
height' Int
leafNum = Direction -> Int -> [Direction] -> [Direction]
forall a. a -> Int -> [a] -> [a]
padLeft Direction
TurnLeft (Int
height' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Direction -> Direction -> Int -> [Direction]
forall a. a -> a -> Int -> [a]
toBinary Direction
TurnLeft Direction
TurnRight Int
leafNum)

-- | Compute the length of a merkle path through a tree of the given height.
merklePathLengthForSize :: Int -> Int
merklePathLengthForSize :: Int -> Int
merklePathLengthForSize Int
size' = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> Int) -> (Int -> Double) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase (Double
2 :: Double) (Double -> Double) -> (Int -> Double) -> Int -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall p. (Ord p, Num p) => p -> p -> p
nextPowerOf Int
2 Int
size'

-- Convert a tree to a breadth-first list of its hash values.
breadthFirstList :: forall v a. MerkleTree v a -> [Digest' a]
breadthFirstList :: MerkleTree v a -> [Digest' a]
breadthFirstList MerkleTree v a
tree = [MerkleTree v a] -> [Digest' a]
traverse' [MerkleTree v a
tree]
  where
    traverse' :: [MerkleTree v a] -> [Digest' a]
    traverse' :: [MerkleTree v a] -> [Digest' a]
traverse' [] = []
    traverse' [MerkleTree v a]
trees =
        [MerkleTree v a -> Digest' a
forall v a. MerkleTree v a -> Digest' a
rootHash MerkleTree v a
tree' | MerkleTree v a
tree' <- [MerkleTree v a]
trees] [Digest' a] -> [Digest' a] -> [Digest' a]
forall a. [a] -> [a] -> [a]
++ [MerkleTree v a] -> [Digest' a]
traverse' ([[MerkleTree v a]] -> [MerkleTree v a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [MerkleTree v a -> [MerkleTree v a]
forall value hash. MerkleTree value hash -> [MerkleTree value hash]
children MerkleTree v a
tree'' | MerkleTree v a
tree'' <- [MerkleTree v a]
trees])

    children :: MerkleTree value hash -> [MerkleTree value hash]
children (MerkleLeaf Digest' hash
_) = []
    children (MerkleNode Digest' hash
_ MerkleTree value hash
left MerkleTree value hash
right) = [MerkleTree value hash
left, MerkleTree value hash
right]

{- | Construct Just a merkle proof along the pre-computed path or Nothing if
 the path runs past the leaves of the tree.
-}
merkleProof' :: Int -> MerkleTree v a -> [Direction] -> Maybe [(Int, Digest' a)]
merkleProof' :: Int -> MerkleTree v a -> [Direction] -> Maybe [(Int, Digest' a)]
merkleProof' Int
_ MerkleTree v a
_ [] = [(Int, Digest' a)] -> Maybe [(Int, Digest' a)]
forall a. a -> Maybe a
Just []
merkleProof' Int
thisNodeNum (MerkleNode Digest' a
_ MerkleTree v a
left MerkleTree v a
right) (Direction
d : [Direction]
ds) =
    case Direction
d of
        Direction
TurnLeft ->
            ((Int
rightChildNum, MerkleTree v a -> Digest' a
forall v a. MerkleTree v a -> Digest' a
rootHash MerkleTree v a
right) (Int, Digest' a) -> [(Int, Digest' a)] -> [(Int, Digest' a)]
forall a. a -> [a] -> [a]
:) ([(Int, Digest' a)] -> [(Int, Digest' a)])
-> Maybe [(Int, Digest' a)] -> Maybe [(Int, Digest' a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> MerkleTree v a -> [Direction] -> Maybe [(Int, Digest' a)]
forall v a.
Int -> MerkleTree v a -> [Direction] -> Maybe [(Int, Digest' a)]
merkleProof' Int
leftChildNum MerkleTree v a
left [Direction]
ds
        Direction
TurnRight ->
            ((Int
leftChildNum, MerkleTree v a -> Digest' a
forall v a. MerkleTree v a -> Digest' a
rootHash MerkleTree v a
left) (Int, Digest' a) -> [(Int, Digest' a)] -> [(Int, Digest' a)]
forall a. a -> [a] -> [a]
:) ([(Int, Digest' a)] -> [(Int, Digest' a)])
-> Maybe [(Int, Digest' a)] -> Maybe [(Int, Digest' a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> MerkleTree v a -> [Direction] -> Maybe [(Int, Digest' a)]
forall v a.
Int -> MerkleTree v a -> [Direction] -> Maybe [(Int, Digest' a)]
merkleProof' Int
rightChildNum MerkleTree v a
right [Direction]
ds
  where
    leftChildNum :: Int
leftChildNum = Int
thisNodeNum Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2
    rightChildNum :: Int
rightChildNum = Int
thisNodeNum Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
merkleProof' Int
_ (MerkleLeaf Digest' a
_) [Direction]
ds = String -> Maybe [(Int, Digest' a)]
forall a. HasCallStack => String -> a
error (String -> Maybe [(Int, Digest' a)])
-> String -> Maybe [(Int, Digest' a)]
forall a b. (a -> b) -> a -> b
$ [Direction] -> String
forall a. Show a => a -> String
show [Direction]
ds

{- | Translate a leaf number to a node number.  Leaf numbers are zero indexed
 and identify leaves of a tree from left to right.  Node numbers are one
 indexed and identify nodes of a tree from top to bottom, left to right.
-}
leafNumberToNodeNumber :: MerkleTree v a -> Int -> Int
leafNumberToNodeNumber :: MerkleTree v a -> Int -> Int
leafNumberToNodeNumber MerkleTree v a
tree Int
leafNum = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
leafNum Int -> Int -> Int
forall a. Num a => a -> a -> a
+ MerkleTree v a -> Int
forall v a. MerkleTree v a -> Int
firstLeafNum MerkleTree v a
tree

{- | Get a leaf node by its leaf number, if possible.  Leaf numbers are zero indexed
  and identify leaves of a tree from left to right.
-}
leafNumberToNode :: MerkleTree v a -> Int -> Maybe (MerkleTree v a)
leafNumberToNode :: MerkleTree v a -> Int -> Maybe (MerkleTree v a)
leafNumberToNode MerkleTree v a
tree Int
leafNum = MerkleTree v a -> [Direction] -> Maybe (MerkleTree v a)
forall value hash.
MerkleTree value hash
-> [Direction] -> Maybe (MerkleTree value hash)
nodeAtPath MerkleTree v a
tree [Direction]
path
  where
    path :: [Direction]
path = Int -> Int -> [Direction]
merklePath (MerkleTree v a -> Int
forall v a. MerkleTree v a -> Int
height MerkleTree v a
tree) Int
leafNum

    nodeAtPath :: MerkleTree value hash
-> [Direction] -> Maybe (MerkleTree value hash)
nodeAtPath MerkleTree value hash
node [] = MerkleTree value hash -> Maybe (MerkleTree value hash)
forall a. a -> Maybe a
Just MerkleTree value hash
node
    nodeAtPath (MerkleNode Digest' hash
_ MerkleTree value hash
left MerkleTree value hash
_) (Direction
TurnLeft : [Direction]
ds) = MerkleTree value hash
-> [Direction] -> Maybe (MerkleTree value hash)
nodeAtPath MerkleTree value hash
left [Direction]
ds
    nodeAtPath (MerkleNode Digest' hash
_ MerkleTree value hash
_ MerkleTree value hash
right) (Direction
TurnRight : [Direction]
ds) = MerkleTree value hash
-> [Direction] -> Maybe (MerkleTree value hash)
nodeAtPath MerkleTree value hash
right [Direction]
ds
    nodeAtPath (MerkleLeaf Digest' hash
_) [Direction]
_ = Maybe (MerkleTree value hash)
forall a. Maybe a
Nothing

{- | Get a merkle proof but re-number the node numbers to be zero-indexed
 instead of one-indexed.
-}
neededHashes :: MerkleTree v a -> Int -> Maybe [(Int, Digest' a)]
neededHashes :: MerkleTree v a -> Int -> Maybe [(Int, Digest' a)]
neededHashes MerkleTree v a
tree = ([(Int, Digest' a)] -> [(Int, Digest' a)])
-> Maybe [(Int, Digest' a)] -> Maybe [(Int, Digest' a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Int, Digest' a) -> (Int, Digest' a))
-> [(Int, Digest' a)] -> [(Int, Digest' a)]
forall a b. (a -> b) -> [a] -> [b]
map (((Int, Digest' a) -> (Int, Digest' a))
 -> [(Int, Digest' a)] -> [(Int, Digest' a)])
-> ((Int, Digest' a) -> (Int, Digest' a))
-> [(Int, Digest' a)]
-> [(Int, Digest' a)]
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> (Int, Digest' a) -> (Int, Digest' a)
forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1)) (Maybe [(Int, Digest' a)] -> Maybe [(Int, Digest' a)])
-> (Int -> Maybe [(Int, Digest' a)])
-> Int
-> Maybe [(Int, Digest' a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MerkleTree v a -> Int -> Maybe [(Int, Digest' a)]
forall v a. MerkleTree v a -> Int -> Maybe [(Int, Digest' a)]
merkleProof MerkleTree v a
tree

{- | Determine the smallest index into the breadth first list for the given
 tree where a leaf may be found.
-}
firstLeafNum :: MerkleTree v a -> Int
firstLeafNum :: MerkleTree v a -> Int
firstLeafNum MerkleTree v a
tree = MerkleTree v a -> Int
forall v a. MerkleTree v a -> Int
size MerkleTree v a
tree Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2

{- | Serialize a MerkleTree to bytes by concatenating all of the leaf hashes
 left to right.

 This serialization includes no framing so the only thing we can do is
 consume all available input.  Use this instance with `isolate` and bring
 your own framing mechanism to determine how many bytes to process.
-}
instance (Show hash, HashAlgorithm hash) => Binary (MerkleTree v hash) where
    put :: MerkleTree v hash -> Put
put = ByteString -> Put
putByteString (ByteString -> Put)
-> (MerkleTree v hash -> ByteString) -> MerkleTree v hash -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString)
-> (MerkleTree v hash -> [ByteString])
-> MerkleTree v hash
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Digest' hash -> ByteString) -> [Digest' hash] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Digest' hash -> ByteString
forall a. ByteArrayAccess a => a -> ByteString
toBytes ([Digest' hash] -> [ByteString])
-> (MerkleTree v hash -> [Digest' hash])
-> MerkleTree v hash
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MerkleTree v hash -> [Digest' hash]
forall v a. MerkleTree v a -> [Digest' a]
breadthFirstList
    get :: Get (MerkleTree v hash)
get =
        Get ByteString
getRemainingLazyByteString
            Get ByteString
-> (ByteString -> Get (MerkleTree v hash))
-> Get (MerkleTree v hash)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Get (MerkleTree v hash)
-> (MerkleTree v hash -> Get (MerkleTree v hash))
-> Maybe (MerkleTree v hash)
-> Get (MerkleTree v hash)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Get (MerkleTree v hash)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"could not construct MerkleTree") MerkleTree v hash -> Get (MerkleTree v hash)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                (Maybe (MerkleTree v hash) -> Get (MerkleTree v hash))
-> (ByteString -> Maybe (MerkleTree v hash))
-> ByteString
-> Get (MerkleTree v hash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString -> Maybe (Digest' hash))
-> [ByteString] -> Maybe [Digest' hash]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Digest hash -> Digest' hash)
-> Maybe (Digest hash) -> Maybe (Digest' hash)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Digest hash -> Digest' hash
forall a. Digest a -> Digest' a
Digest' (Maybe (Digest hash) -> Maybe (Digest' hash))
-> (ByteString -> Maybe (Digest hash))
-> ByteString
-> Maybe (Digest' hash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe (Digest hash)
forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString) ([ByteString] -> Maybe [Digest' hash])
-> ([Digest' hash] -> Maybe (MerkleTree v hash))
-> [ByteString]
-> Maybe (MerkleTree v hash)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [Digest' hash] -> Maybe (MerkleTree v hash)
forall hash value.
(Show hash, HashAlgorithm hash) =>
[Digest' hash] -> Maybe (MerkleTree value hash)
buildTreeOutOfAllTheNodes)
                ([ByteString] -> Maybe (MerkleTree v hash))
-> (ByteString -> [ByteString])
-> ByteString
-> Maybe (MerkleTree v hash)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> [ByteString]
chunkedBy (SHA256d -> Int
forall a. HashAlgorithm a => a -> Int
hashDigestSize (SHA256d
forall a. HasCallStack => a
undefined :: SHA256d))
                (ByteString -> [ByteString])
-> (ByteString -> ByteString) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict

-- | Get a list of all of the leaf hashes of a tree from left to right.
leafHashes :: MerkleTree v a -> [Digest' a]
leafHashes :: MerkleTree v a -> [Digest' a]
leafHashes (MerkleLeaf Digest' a
h) = [Digest' a
h]
leafHashes (MerkleNode Digest' a
_ MerkleTree v a
l MerkleTree v a
r) = MerkleTree v a -> [Digest' a]
forall v a. MerkleTree v a -> [Digest' a]
leafHashes MerkleTree v a
l [Digest' a] -> [Digest' a] -> [Digest' a]
forall a. Semigroup a => a -> a -> a
<> MerkleTree v a -> [Digest' a]
forall v a. MerkleTree v a -> [Digest' a]
leafHashes MerkleTree v a
r

{- | Make a merkle tree out of a flat list of all nodes (start from
 root, then first two children, etc .. [0, 1, 2] is a two-layer
 tree, [0, 1, 2, 3, 4, 5, 6] is three-layer, etc
-}
buildTreeOutOfAllTheNodes :: (Show hash, HashAlgorithm hash) => [Digest' hash] -> Maybe (MerkleTree value hash)
buildTreeOutOfAllTheNodes :: [Digest' hash] -> Maybe (MerkleTree value hash)
buildTreeOutOfAllTheNodes [Digest' hash]
nodes
    | [Digest' hash] -> Bool
forall a. [a] -> Bool
validMerkleSize [Digest' hash]
nodes = MerkleTree value hash -> Maybe (MerkleTree value hash)
forall a. a -> Maybe a
Just ([MerkleTree value hash] -> MerkleTree value hash
forall a. [a] -> a
head ([MerkleTree value hash]
-> [[Digest' hash]] -> [MerkleTree value hash]
forall hash value.
(Show hash, HashAlgorithm hash) =>
[MerkleTree value hash]
-> [[Digest' hash]] -> [MerkleTree value hash]
treeFromRows [] ([Int] -> [Digest' hash] -> [[Digest' hash]]
forall a. [Int] -> [a] -> [[a]]
clumpRows [Int]
powersOfTwo [Digest' hash]
nodes)))
    | Bool
otherwise = Maybe (MerkleTree value hash)
forall a. Maybe a
Nothing

{- | Increasing consecutive powers of 2 from 2 ^ 0 to the maximum value
 representable in `Int`.
-}
powersOfTwo :: [Int]
powersOfTwo :: [Int]
powersOfTwo = (Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^) (Int -> Int) -> [Int] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
0 :: Int .. Int
62]

{- | Determine whether a list of nodes is a possible representation of a
 merkle tree.

 It is possible if the number of elements in the list is one less than a
 positive power of 2.
-}
validMerkleSize :: [a] -> Bool
validMerkleSize :: [a] -> Bool
validMerkleSize [a]
nodes =
    [Int] -> Int
forall a. [a] -> a
head ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
size') ([Int] -> [Int]
forall a. [a] -> [a]
tail [Int]
powersOfTwo)) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
size'
  where
    size' :: Int
size' = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
nodes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

{- | Reorganize a flat list of merkle tree node values into a list of lists of
 merkle tree node values.  Each inner list gives the values from left to right
 at a particular height in the tree.  The head of the outer list gives the
 leaves.
-}
clumpRows ::
    -- | The numbers of elements of the flat list to take to make this (the
    -- head) and subsequent (the tail) clumps.
    [Int] ->
    -- | The values of the nodes themselves.
    [a] ->
    [[a]]
clumpRows :: [Int] -> [a] -> [[a]]
clumpRows [Int]
_ [] = []
clumpRows [] [a]
_ = String -> [[a]]
forall a. HasCallStack => String -> a
error String
"Ran out of clump lengths (too many nodes!)"
clumpRows (Int
p : [Int]
ps) [a]
rows = [Int] -> [a] -> [[a]]
forall a. [Int] -> [a] -> [[a]]
clumpRows [Int]
ps (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
p [a]
rows) [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
++ [Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
p [a]
rows]

-- | Given some children
treeFromRows ::
    (Show hash, HashAlgorithm hash) =>
    -- | Some children to attach to a list of nodes representing the next
    -- shallowest level of the tree.
    [MerkleTree value hash] ->
    -- | The values of the nodes to create at the next shallowest level of the
    -- tree.
    [[Digest' hash]] ->
    -- | The nodes forming the shallowest level of the tree.  If we built a
    -- full tree, there will be exactly one node here.
    [MerkleTree value hash]
-- if we've processed nothing yet, we're on the "all leafs" children row
treeFromRows :: [MerkleTree value hash]
-> [[Digest' hash]] -> [MerkleTree value hash]
treeFromRows [] ([Digest' hash]
children : [[Digest' hash]]
rest) = [MerkleTree value hash]
-> [[Digest' hash]] -> [MerkleTree value hash]
forall hash value.
(Show hash, HashAlgorithm hash) =>
[MerkleTree value hash]
-> [[Digest' hash]] -> [MerkleTree value hash]
treeFromRows (Digest' hash -> MerkleTree value hash
forall value hash. Digest' hash -> MerkleTree value hash
MerkleLeaf (Digest' hash -> MerkleTree value hash)
-> [Digest' hash] -> [MerkleTree value hash]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Digest' hash]
children) [[Digest' hash]]
rest
-- if we're out of other stuff then we're done
treeFromRows [MerkleTree value hash]
children [] = [MerkleTree value hash]
children
-- with only a single thing in the "rest", we're at the root
treeFromRows [MerkleTree value hash
left, MerkleTree value hash
right] [[Digest' hash
root]] = [Digest' hash
-> MerkleTree value hash
-> MerkleTree value hash
-> MerkleTree value hash
forall value hash.
Digest' hash
-> MerkleTree value hash
-> MerkleTree value hash
-> MerkleTree value hash
MerkleNode Digest' hash
root MerkleTree value hash
left MerkleTree value hash
right]
-- this recursion is harder to think about: we want to "collect" done
-- stuff from the first argument and build it up into a tree. kind of.
treeFromRows (MerkleTree value hash
left : MerkleTree value hash
right : [MerkleTree value hash]
children) ([Digest' hash]
row : [[Digest' hash]]
rest) = [MerkleTree value hash]
-> [[Digest' hash]] -> [MerkleTree value hash]
forall hash value.
(Show hash, HashAlgorithm hash) =>
[MerkleTree value hash]
-> [[Digest' hash]] -> [MerkleTree value hash]
treeFromRows ([MerkleTree value hash]
-> [Digest' hash] -> [MerkleTree value hash]
forall hash value.
HashAlgorithm hash =>
[MerkleTree value hash]
-> [Digest' hash] -> [MerkleTree value hash]
mTree (MerkleTree value hash
left MerkleTree value hash
-> [MerkleTree value hash] -> [MerkleTree value hash]
forall a. a -> [a] -> [a]
: MerkleTree value hash
right MerkleTree value hash
-> [MerkleTree value hash] -> [MerkleTree value hash]
forall a. a -> [a] -> [a]
: [MerkleTree value hash]
children) [Digest' hash]
row) [[Digest' hash]]
rest
treeFromRows [MerkleTree value hash]
x [[Digest' hash]]
y = String -> [MerkleTree value hash]
forall a. HasCallStack => String -> a
error (String -> [MerkleTree value hash])
-> String -> [MerkleTree value hash]
forall a b. (a -> b) -> a -> b
$ String
"treeFromRows not sure what to do with " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [MerkleTree value hash] -> String
forall a. Show a => a -> String
show [MerkleTree value hash]
x String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [[Digest' hash]] -> String
forall a. Show a => a -> String
show [[Digest' hash]]
y

-- this does the "second recursion"; see above -- building out a row
-- of parents from children + parent node content
mTree :: HashAlgorithm hash => [MerkleTree value hash] -> [Digest' hash] -> [MerkleTree value hash]
mTree :: [MerkleTree value hash]
-> [Digest' hash] -> [MerkleTree value hash]
mTree [MerkleTree value hash
left, MerkleTree value hash
right] [Digest' hash
head'] = [Digest' hash
-> MerkleTree value hash
-> MerkleTree value hash
-> MerkleTree value hash
forall value hash.
Digest' hash
-> MerkleTree value hash
-> MerkleTree value hash
-> MerkleTree value hash
MerkleNode Digest' hash
head' MerkleTree value hash
left MerkleTree value hash
right]
mTree (MerkleTree value hash
left : MerkleTree value hash
right : [MerkleTree value hash]
more) [Digest' hash]
row = Digest' hash
-> MerkleTree value hash
-> MerkleTree value hash
-> MerkleTree value hash
forall value hash.
Digest' hash
-> MerkleTree value hash
-> MerkleTree value hash
-> MerkleTree value hash
MerkleNode ([Digest' hash] -> Digest' hash
forall a. [a] -> a
head [Digest' hash]
row) MerkleTree value hash
left MerkleTree value hash
right MerkleTree value hash
-> [MerkleTree value hash] -> [MerkleTree value hash]
forall a. a -> [a] -> [a]
: [MerkleTree value hash]
-> [Digest' hash] -> [MerkleTree value hash]
forall hash value.
HashAlgorithm hash =>
[MerkleTree value hash]
-> [Digest' hash] -> [MerkleTree value hash]
mTree [MerkleTree value hash]
more ([Digest' hash] -> [Digest' hash]
forall a. [a] -> [a]
tail [Digest' hash]
row)
mTree [MerkleTree value hash]
x [Digest' hash]
y = String -> [MerkleTree value hash]
forall a. HasCallStack => String -> a
error (String -> [MerkleTree value hash])
-> String -> [MerkleTree value hash]
forall a b. (a -> b) -> a -> b
$ String
"mTree not sure what to do with " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [MerkleTree value hash] -> String
forall a. Show a => a -> String
show [MerkleTree value hash]
x String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Digest' hash] -> String
forall a. Show a => a -> String
show [Digest' hash]
y

dumpTree :: HashAlgorithm hash => MerkleTree value hash -> [Text]
dumpTree :: MerkleTree value hash -> [Text]
dumpTree (MerkleLeaf Digest' hash
hash) = [Text
"Leaf " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text)
-> (Digest' hash -> String) -> Digest' hash -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest' hash -> String
forall a. Show a => a -> String
show) Digest' hash
hash]
dumpTree (MerkleNode Digest' hash
hash MerkleTree value hash
left MerkleTree value hash
right) =
    (Text
"Node " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text)
-> (Digest' hash -> String) -> Digest' hash -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest' hash -> String
forall a. Show a => a -> String
show) Digest' hash
hash) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text] -> [Text]
indent (MerkleTree value hash -> [Text]
forall hash value.
HashAlgorithm hash =>
MerkleTree value hash -> [Text]
dumpTree MerkleTree value hash
left) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text] -> [Text]
indent (MerkleTree value hash -> [Text]
forall hash value.
HashAlgorithm hash =>
MerkleTree value hash -> [Text]
dumpTree MerkleTree value hash
right)
  where
    indent :: [Text] -> [Text]
indent = (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
"   \\" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)