{-# 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,
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,
)
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)
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)
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
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
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
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 :: [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')
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]
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
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
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)
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
checkMerkleProof ::
forall n hash.
(Integral n, HashAlgorithm hash) =>
[(n, Digest' hash)] ->
Digest' hash ->
Digest' hash ->
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
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)
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'
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]
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
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
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
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
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
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
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
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
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]
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
clumpRows ::
[Int] ->
[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]
treeFromRows ::
(Show hash, HashAlgorithm hash) =>
[MerkleTree value hash] ->
[[Digest' hash]] ->
[MerkleTree value hash]
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
treeFromRows [MerkleTree value hash]
children [] = [MerkleTree value hash]
children
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]
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
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
<>)