this repo has no description
fix implementation
+119
-25
+119
-25
app/Main.hs
+119
-25
app/Main.hs
···
1
+
{-# LANGUAGE FlexibleInstances #-}
2
+
{-# LANGUAGE TypeFamilies #-}
3
+
1
4
module Main where
2
5
3
6
import Data.Bifunctor (Bifunctor (bimap))
4
-
import Data.Bits (Bits (shiftR), (.|.))
7
+
import Data.Bits (Bits (shiftR), (.&.), (.|.))
5
8
import Data.Foldable (Foldable (foldr'), foldl')
6
9
import Data.Hashable (Hashable, hash)
10
+
import Data.Kind (Type)
11
+
import Data.List (elemIndex, findIndex)
7
12
import qualified Data.List.NonEmpty as NE
13
+
import Data.Maybe (fromMaybe)
14
+
import Data.Semigroup (Semigroup (sconcat))
15
+
import qualified GHC.Generics as NE
8
16
9
17
type Hash = Int
10
18
11
-
-- this can be also rep as a Map<a, Hash>
12
-
data Merkle a = Merkle Hash a deriving (Show)
13
-
14
-
unHash :: Merkle a -> Hash
15
-
unHash (Merkle h _) = h
16
-
17
-
def :: Monoid a => [a] -> a
18
-
def = mempty
19
-
20
19
nextHighestPowerOfTwoSmallerThan :: (Num a, Bits a) => a -> a
21
20
nextHighestPowerOfTwoSmallerThan n = (1 + foldl' go (n -1) [1, 2, 4, 8, 16, 32]) `shiftR` 1
22
21
where
23
22
go m i = m .|. m `shiftR` i
24
23
25
-
merkleTreeHash :: (Hashable a, Monoid a) => [a] -> NE.NonEmpty (Merkle a)
26
-
merkleTreeHash xs@[] = return $ Merkle (hash $ def xs) mempty
27
-
merkleTreeHash [x] = return $ Merkle (hash x) x
28
-
merkleTreeHash xs =
29
-
let k = nextHighestPowerOfTwoSmallerThan $ length xs
30
-
(left, right) = bimap merkleTreeHash merkleTreeHash $ splitAt k xs
31
-
in left <> right
24
+
isPower2 :: (Integral i, Bits i) => i -> Bool
25
+
isPower2 n = n .&. (n - 1) == 0
32
26
33
-
getMerkle :: (Hashable a, Monoid a, Eq a) => a -> [a] -> Maybe (Merkle a)
34
-
getMerkle x = fmap NE.head . NE.nonEmpty . NE.dropWhile (\(Merkle _ a) -> a /= x) . merkleTreeHash
27
+
splitOnPos :: [a] -> ([a], [a])
28
+
splitOnPos [] = ([], [])
29
+
splitOnPos [x] = ([x], [])
30
+
splitOnPos (x1 : x2 : xs) = (x1 : odds, x2 : evens)
31
+
where
32
+
(odds, evens) = splitOnPos xs
35
33
36
-
getHash :: (Hashable a, Monoid a, Eq a) => a -> [a] -> Maybe Hash
37
-
getHash x xs = unHash <$> getMerkle x xs
34
+
class CMerkle a where
35
+
data HashType a :: Type
36
+
leaf_pad :: a
37
+
node_pad :: a
38
+
hhash :: a -> HashType a
39
+
eqHash :: HashType a -> HashType a -> Bool
40
+
showHash :: HashType a -> String
41
+
cconcat :: HashType a -> HashType a -> HashType a
38
42
39
-
auditPath :: (Hashable a) => Int -> [a] -> Maybe [Hash]
40
-
auditPath x xs | x > length xs = Nothing
41
-
auditPath x xs = error "todo"
43
+
mkLeaf :: a -> HashType a
44
+
mkLeaf x = hhash leaf_pad `cconcat` hhash x
45
+
46
+
mkNode :: HashType a -> HashType a -> HashType a
47
+
mkNode x y = hhash node_pad `cconcat` x `cconcat` y
48
+
49
+
mkLeafHash :: HashType a -> HashType a
50
+
mkLeafHash = cconcat $ hhash leaf_pad
51
+
52
+
instance CMerkle a => Semigroup (HashType a) where
53
+
(<>) = mkNode
54
+
55
+
instance CMerkle a => Eq (HashType a) where
56
+
(==) = eqHash
57
+
58
+
instance CMerkle a => Show (HashType a) where
59
+
show = showHash
60
+
61
+
merkleTreeHash :: CMerkle a => a -> [a] -> HashType a
62
+
merkleTreeHash d [] = mkLeaf d
63
+
merkleTreeHash _ [x] = mkLeaf x
64
+
merkleTreeHash d xs =
65
+
let n = length xs
66
+
k = nextHighestPowerOfTwoSmallerThan n
67
+
(left, right) = bimap (merkleTreeHash d) (merkleTreeHash d) $ splitAt k xs
68
+
in mkNode left right
69
+
70
+
combineHashes :: CMerkle a => a -> Int -> HashType a -> NE.NonEmpty (HashType a) -> Maybe (HashType a)
71
+
combineHashes d old_length old ps
72
+
| isPower2 old_length = return $ sconcat $ NE.cons old ps
73
+
| otherwise =
74
+
let (odds, evens) = splitOnPos $ NE.toList ps
75
+
go xs ys = sconcat $ NE.fromList $ [sconcat xs, sconcat ys]
76
+
in go <$> NE.nonEmpty odds <*> NE.nonEmpty evens
77
+
78
+
auditPath :: (CMerkle a, Eq a) => a -> a -> [a] -> [HashType a]
79
+
auditPath _ _ [] = []
80
+
auditPath d el xs =
81
+
let maybe_m = elemIndex el xs
82
+
go _ [x] = []
83
+
go m' xs' =
84
+
let n' = length xs'
85
+
k' = nextHighestPowerOfTwoSmallerThan n'
86
+
(left, right) = splitAt k' xs'
87
+
in if m' < k' then go m' left <> [merkleTreeHash d right] else go (m' - k') right <> [merkleTreeHash d left]
88
+
in case maybe_m of
89
+
Nothing -> []
90
+
Just m -> go m xs
91
+
92
+
consistencyProof :: (CMerkle a, Eq a) => a -> [a] -> [a] -> [HashType a]
93
+
consistencyProof d old new =
94
+
let m = length old
95
+
n = length new
96
+
subProof m' xs True | m' == length xs && m' == m = []
97
+
subProof m' xs False | m' == length xs = [merkleTreeHash d xs]
98
+
subProof m' xs b =
99
+
let n' = length xs
100
+
k = nextHighestPowerOfTwoSmallerThan n'
101
+
(left, right) = splitAt k xs
102
+
in if m' <= k
103
+
then subProof m' left b <> [merkleTreeHash d right]
104
+
else subProof (m' - k) right False <> [merkleTreeHash d left]
105
+
in if m <= n then subProof m new True else []
106
+
107
+
_isIncluded :: (CMerkle a, Eq a) => a -> a -> [a] -> Bool
108
+
_isIncluded d x xs = sconcat (NE.fromList $ mkLeaf x : auditPath d x xs) == merkleTreeHash d xs
109
+
110
+
_areConsistent :: (CMerkle a, Eq a) => a -> [a] -> [a] -> Bool
111
+
_areConsistent _ [] _ = False
112
+
_areConsistent d old new =
113
+
let old_hash = merkleTreeHash d old
114
+
new_hash = merkleTreeHash d new
115
+
old_length = length old
116
+
in (old_hash == new_hash) || (Just new_hash == (combineHashes d old_length old_hash =<< NE.nonEmpty (consistencyProof d old new)))
117
+
118
+
instance CMerkle String where
119
+
data HashType String = HashType Int
120
+
leaf_pad = "0"
121
+
node_pad = "1"
122
+
cconcat (HashType a) (HashType b) = HashType $ a + b
123
+
hhash = HashType . hash
124
+
eqHash (HashType a) (HashType b) = a == b
125
+
showHash (HashType a) = show a
126
+
127
+
isIncluded :: String -> [String] -> Bool
128
+
isIncluded = _isIncluded ""
129
+
130
+
areConsistent :: [String] -> [String] -> Bool
131
+
areConsistent = _areConsistent ""
42
132
43
133
main :: IO ()
44
-
main = putStrLn "Hello, Haskell!"
134
+
main = do
135
+
let xs = fmap show [0 .. 9]
136
+
ys = fmap show [0 .. 4]
137
+
print $ isIncluded "4" xs
138
+
print $ areConsistent ys xs