this repo has no description
1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE TypeFamilies #-}
3
4module Main where
5
6import Data.Bifunctor (Bifunctor (bimap))
7import Data.Bits (Bits (shiftR), (.&.), (.|.))
8import Data.Foldable (Foldable (foldr'), foldl')
9import Data.Hashable (Hashable, hash)
10import Data.Kind (Type)
11import Data.List (elemIndex, findIndex)
12import qualified Data.List.NonEmpty as NE
13import Data.Maybe (fromMaybe)
14import Data.Semigroup (Semigroup (sconcat))
15import qualified GHC.Generics as NE
16
17type Hash = Int
18
19nextHighestPowerOfTwoSmallerThan :: (Num a, Bits a) => a -> a
20nextHighestPowerOfTwoSmallerThan n = (1 + foldl' go (n -1) [1, 2, 4, 8, 16, 32]) `shiftR` 1
21 where
22 go m i = m .|. m `shiftR` i
23
24isPower2 :: (Integral i, Bits i) => i -> Bool
25isPower2 n = n .&. (n - 1) == 0
26
27splitOnPos :: [a] -> ([a], [a])
28splitOnPos [] = ([], [])
29splitOnPos [x] = ([x], [])
30splitOnPos (x1 : x2 : xs) = (x1 : odds, x2 : evens)
31 where
32 (odds, evens) = splitOnPos xs
33
34class 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
42
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
52instance CMerkle a => Semigroup (HashType a) where
53 (<>) = mkNode
54
55instance CMerkle a => Eq (HashType a) where
56 (==) = eqHash
57
58instance CMerkle a => Show (HashType a) where
59 show = showHash
60
61merkleTreeHash :: CMerkle a => a -> [a] -> HashType a
62merkleTreeHash d [] = mkLeaf d
63merkleTreeHash _ [x] = mkLeaf x
64merkleTreeHash 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
70combineHashes :: CMerkle a => a -> Int -> HashType a -> NE.NonEmpty (HashType a) -> Maybe (HashType a)
71combineHashes 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
78auditPath :: (CMerkle a, Eq a) => a -> a -> [a] -> [HashType a]
79auditPath _ _ [] = []
80auditPath 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
92consistencyProof :: (CMerkle a, Eq a) => a -> [a] -> [a] -> [HashType a]
93consistencyProof 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
118instance 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
127isIncluded :: String -> [String] -> Bool
128isIncluded = _isIncluded ""
129
130areConsistent :: [String] -> [String] -> Bool
131areConsistent = _areConsistent ""
132
133main :: IO ()
134main = do
135 let xs = fmap show [0 .. 9]
136 ys = fmap show [0 .. 4]
137 print $ isIncluded "4" xs
138 print $ areConsistent ys xs