|
|
|
|
module HashTrees where
|
|
|
|
|
|
|
|
|
|
import Data.Digest.Pure.SHA
|
|
|
|
|
import qualified Data.ByteString.Lazy as BL
|
|
|
|
|
import Control.Monad
|
|
|
|
|
import Data.List
|
|
|
|
|
|
|
|
|
|
data HashTree k a = Leaf | HashTree (Digest k) (HashTree k a) (HashTree k a) deriving (Show)
|
|
|
|
|
|
|
|
|
|
groupsOf _ ([]) = []
|
|
|
|
|
groupsOf n xs = case splitAt n xs of
|
|
|
|
|
(a, as) -> a : (groupsOf n as)
|
|
|
|
|
|
|
|
|
|
groupsOf2 xs = map (\(x:y:[]) -> (x,y)) $ groupsOf 2 xs
|
|
|
|
|
|
|
|
|
|
hashCatInner (h1, h2) = sha1 $ BL.concat [(bytestringDigest h1), (bytestringDigest h2), BL.singleton 1]
|
|
|
|
|
|
|
|
|
|
hashes = map sha1
|
|
|
|
|
|
|
|
|
|
singletonTrees xs = map (\x -> HashTree x Leaf Leaf) xs
|
|
|
|
|
|
|
|
|
|
reduceHashes xs = map (\((HashTree x _ _), (HashTree y _ _)) -> HashTree (hashCatInner (x,y)) Leaf Leaf) (groupsOf2 xs)
|
|
|
|
|
|
|
|
|
|
combineTrees (HashTree x _ _) (t1, t2) = HashTree x t1 t2
|
|
|
|
|
|
|
|
|
|
combineTreeLists lower upper = zipWith combineTrees upper (groupsOf2 lower)
|
|
|
|
|
|
|
|
|
|
buildPreliminaryLevels ([x]) = [[x]]
|
|
|
|
|
buildPreliminaryLevels xs = xs : (buildPreliminaryLevels $ (reduceHashes xs))
|
|
|
|
|
|
|
|
|
|
buildTree' :: [HashTree k t] -> [[HashTree k t]] -> [HashTree k t]
|
|
|
|
|
buildTree' acc ([]) = acc
|
|
|
|
|
buildTree' acc (x:xs) = buildTree' (combineTreeLists acc x) xs
|
|
|
|
|
|
|
|
|
|
buildTree = (\x -> buildTree' (head x) (tail x)) . buildPreliminaryLevels . singletonTrees . hashes . (map (\x -> BL.concat [x,BL.singleton 0])) . padHashes
|
|
|
|
|
|
|
|
|
|
-- Padding functions
|
|
|
|
|
|
|
|
|
|
nextPowerOf n = 2 ^ (ceiling $ logBase 2 $ fromIntegral n)
|
|
|
|
|
|
|
|
|
|
padHashes xs = pad' 0 xs where
|
|
|
|
|
pad' n ([]) = [] ++ (take ((nextPowerOf n) - n) $ repeat BL.empty)
|
|
|
|
|
pad' n (x:xs) = x : (pad' (n +1) xs)
|
|
|
|
|
|
