-
Notifications
You must be signed in to change notification settings - Fork 0
/
HashTree.hs
142 lines (117 loc) · 4.46 KB
/
HashTree.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
module HashTree where
import Utils
import Hashable32
data Tree a = Leaf Hash a | Twig Hash (Tree a) | Node Hash (Tree a) (Tree a)
leaf :: Hashable a => a -> Tree a
leaf e = Leaf (hash e) e
twig :: Hashable a => Tree a -> Tree a
twig t = Twig h_root t
where
h_t = treeHash t
h_root = combine h_t h_t
node :: Hashable a => Tree a -> Tree a -> Tree a
node l r = Node h_root l r
where
h_root = combine (treeHash l) (treeHash r)
buildTree :: Hashable a => [a] -> Tree a
buildTree [] = error "buildTree: empty list"
buildTree l = build . map leaf $ l
where
build :: Hashable a => [Tree a] -> Tree a
build [] = error "build: empty list"
build [t] = t
build list = build . pair_trees $ list
pair_trees :: Hashable a => [Tree a] -> [Tree a]
pair_trees [] = []
pair_trees [t] = [twig t]
pair_trees (t1:t2:ts) = node t1 t2 : pair_trees ts
treeHash :: Tree a -> Hash
treeHash (Leaf h _) = h
treeHash (Twig h _) = h
treeHash (Node h _ _) = h
{- | drawsTree
>>> putStr $ drawTree $ buildTree "fubar"
0x2e1cc0e4 -
0xfbfe18ac -
0x6600a107 -
0x00000066 'f'
0x00000075 'u'
0x62009aa7 -
0x00000062 'b'
0x00000061 'a'
0xd11bea20 +
0x7200b3e8 +
0x00000072 'r'
>>> print $ drawTree $ buildTree "a"
"0x00000061 'a'\n"
-}
indent :: Int -> ShowS
indent k
| k <= 0 = id
| otherwise = showString . showChar '\n' $ replicate k ' '
drawsTree :: Show a => Tree a -> Int -> ShowS
drawsTree (Leaf h e) k = indent k . showsHash h . showChar ' ' . shows e
drawsTree (Twig h t) k = indent k . showsHash h . showString " +" . drawsTree t (k + 2)
drawsTree (Node h l r) k = indent k . showsHash h . showString " -" . drawsTree l (k + 2) . drawsTree r (k + 2)
drawTree :: Show a => Tree a -> String
drawTree t = drawsTree t 0 "\n"
{- | Merkle Paths & proofs
>>> mapM_ print $ map showMerklePath $ merklePaths 'i' $ buildTree "bitcoin"
"<0x5214666a<0x7400b6ff>0x00000062"
">0x69f4387c<0x6e00ad98>0x0000006f"
>>> merklePaths 'i' $ buildTree "bitcoin"
[[Left 1377068650,Left 1946203903,Right 98],[Right 1777612924,Left 1845538200,Right 111]]
>>> buildProof 'i' $ buildTree "bitcoin"
Just (MerkleProof 'i' <0x5214666a<0x7400b6ff>0x00000062)
>>> buildProof 'e' $ buildTree "bitcoin"
Nothing
>>> let t = buildTree "bitcoin"
>>> let proof = buildProof 'i' t
>>> verifyProof (treeHash t) <$> proof
Just True
>>> verifyProof 0xbada55bb <$> proof
Just False
>>> buildProof 'a' $ buildTree "a"
Just (MerkleProof 'a' )
-}
type MerklePath = [Either Hash Hash]
data MerkleProof a = MerkleProof a MerklePath
instance (Show a) => Show (MerkleProof a) where
showsPrec d (MerkleProof e path) =
showParen (d > 0) $ showString "MerkleProof " . showsPrec 11 e . showChar ' ' . showsMerklePath path
buildProof :: Hashable a => a -> Tree a -> Maybe (MerkleProof a)
buildProof e t = build e . maybeHead $ merklePaths e t
where
build :: Hashable a => a -> Maybe MerklePath -> Maybe (MerkleProof a)
build _ Nothing = Nothing
build e' (Just path) = Just (MerkleProof e' path)
merklePaths :: Hashable a => a -> Tree a -> [MerklePath]
merklePaths e t = foldr check_and_drop_last [] . all_paths $ t
where
h_e = hash e
all_paths :: Tree a -> [MerklePath]
all_paths (Leaf h _) = [[Right h]]
all_paths (Twig _ t') = [Left (treeHash t') : path | path <- all_paths t']
all_paths (Node _ l r) = [Left (treeHash r) : path | path <- all_paths l] ++ [Right (treeHash l) : path | path <- all_paths r]
check_and_drop_last :: MerklePath -> [MerklePath] -> [MerklePath]
check_and_drop_last [] acc = acc
check_and_drop_last path acc =
let
p_init = init path
p_last = fromEither . last $ path
in
if p_last == h_e then p_init:acc else acc
showsMerklePath :: MerklePath -> ShowS
showsMerklePath path = foldr showsStep id path
where
showsStep :: Either Hash Hash -> ShowS -> ShowS
showsStep (Left h) acc = showString "<" . showsHash h . acc
showsStep (Right h) acc = showString ">" . showsHash h . acc
showMerklePath :: MerklePath -> String
showMerklePath path = showsMerklePath path ""
verifyProof :: Hashable a => Hash -> MerkleProof a -> Bool
verifyProof h (MerkleProof e path) = foldr step (hash e) path == h
where
step :: Either Hash Hash -> Hash -> Hash
step (Left h') acc = combine acc h'
step (Right h') acc = combine h' acc