module Storage.Hashed.Tree
( Tree, Blob(..), TreeItem(..), ItemType(..), Hash(..)
, makeTree, makeTreeWithHash, emptyTree, emptyBlob
, expand, expandPath
, items, list, listImmediate, treeHash
, lookup, find, findFile, findTree, itemHash, itemType
, zipCommonFiles, zipFiles, zipTrees, diffTrees
, read
, finish, filter, restrict, modifyTree ) where
import Prelude hiding( lookup, filter, read, all )
import Storage.Hashed.AnchoredPath
import Storage.Hashed.Utils( Hash(..) )
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.Map as M
import Data.Maybe( catMaybes )
import Data.List( union, sort )
data Blob = Blob !(IO BL.ByteString) !(Maybe Hash)
data TreeItem = File !Blob
| SubTree !Tree
| Stub !(IO Tree) !(Maybe Hash)
data ItemType = BlobType | TreeType deriving (Show, Eq)
data Tree = Tree { items :: (M.Map Name TreeItem)
, listImmediate :: [(Name, TreeItem)]
, treeHash :: !(Maybe Hash)
, finish :: Tree -> IO Tree }
itemHash :: TreeItem -> Maybe Hash
itemHash (File (Blob _ h)) = h
itemHash (SubTree t) = treeHash t
itemHash (Stub _ h) = h
itemType :: TreeItem -> ItemType
itemType (File _) = BlobType
itemType (SubTree _) = TreeType
itemType (Stub _ _) = TreeType
emptyTree :: Tree
emptyTree = Tree { items = M.empty
, listImmediate = []
, treeHash = Nothing
, finish = return }
emptyBlob :: Blob
emptyBlob = Blob (return BL.empty) Nothing
makeTree :: [(Name,TreeItem)] -> Tree
makeTree l = Tree { items = M.fromList l
, listImmediate = l
, treeHash = Nothing
, finish = return }
makeTreeWithHash :: [(Name,TreeItem)] -> Hash -> Tree
makeTreeWithHash l h = Tree { items = M.fromList l
, listImmediate = l
, treeHash = Just h
, finish = return }
lookup :: Tree -> Name -> Maybe TreeItem
lookup t n = M.lookup n (items t)
find' :: TreeItem -> AnchoredPath -> Maybe TreeItem
find' t (AnchoredPath []) = Just t
find' (SubTree t) (AnchoredPath (d : rest)) =
case lookup t d of
Just sub -> find' sub (AnchoredPath rest)
Nothing -> Nothing
find' _ _ = Nothing
find :: Tree -> AnchoredPath -> Maybe TreeItem
find = find' . SubTree
findFile :: Tree -> AnchoredPath -> Maybe Blob
findFile t p = case find t p of
Just (File x) -> Just x
_ -> Nothing
findTree :: Tree -> AnchoredPath -> Maybe Tree
findTree t p = case find t p of
Just (SubTree x) -> Just x
_ -> Nothing
list :: Tree -> [(AnchoredPath, TreeItem)]
list t_ = paths t_ (AnchoredPath [])
where paths t p = [ (appendPath p n, i)
| (n,i) <- listImmediate t ] ++
concat [ paths subt (appendPath p subn)
| (subn, SubTree subt) <- listImmediate t ]
expand :: Tree -> IO Tree
expand t = do
expanded <- mapM subtree [ x | x@(_, item) <- listImmediate t, isSub item ]
let orig = [ i | i <- listImmediate t, not $ isSub $ snd i ]
orig_map = M.filter (not . isSub) (items t)
expanded_map = M.fromList expanded
tree = t { items = M.union orig_map expanded_map
, listImmediate = orig ++ expanded }
finish tree tree
where subtree (name, sub) = do tree <- expand =<< unstub sub
return (name, SubTree tree)
unstub (Stub s _) = s
unstub (SubTree t) = return t
isSub (File _) = False
isSub _ = True
expandPath :: Tree -> AnchoredPath -> IO Tree
expandPath t_ path_ = do expand' t_ path_
where expand' t (AnchoredPath [_]) = return t
expand' t (AnchoredPath (n:rest)) = do
case lookup t n of
(Just (Stub stub _)) ->
do unstubbed <- stub
amend t n rest unstubbed
(Just (SubTree t')) -> amend t n rest t'
_ -> fail $ "Descent error in expandPath: " ++ show path_
amend t name rest sub = do
sub' <- expand' sub (AnchoredPath rest)
let orig_l = [ i | i@(n',_) <- listImmediate t, name /= n' ]
tree = t { items = M.insert name (SubTree sub') (items t)
, listImmediate = (name, SubTree sub') : orig_l }
return tree
restrict :: Tree -> Tree -> Tree
restrict guide tree = filter accept tree
where accept path item =
case (find guide path, item) of
(Just (SubTree _), SubTree _) -> True
(Just (SubTree _), Stub _ _) -> True
(Just (File _), File _) -> True
(Just (Stub _ _), _) ->
error "*sulk* Go away, you, you precondition violator!"
(_, _) -> False
filter :: (AnchoredPath -> TreeItem -> Bool) -> Tree -> Tree
filter predicate t_ = filter' t_ (AnchoredPath [])
where filter' t path =
let subs = (catMaybes [ (,) name `fmap` wibble path name item
| (name,item) <- listImmediate t ])
in t { items = M.mapMaybeWithKey (wibble path) $ items t
, listImmediate = subs
, treeHash = Nothing }
wibble path name item =
let npath = path `appendPath` name in
if predicate npath item
then Just $ filterSub npath item
else Nothing
filterSub npath (SubTree t) = SubTree $ filter' t npath
filterSub npath (Stub stub _) =
Stub (do x <- stub
return $ filter' x npath) Nothing
filterSub _ x = x
read :: Blob -> IO BL.ByteString
read (Blob r _) = r
zipCommonFiles :: (AnchoredPath -> Blob -> Blob -> a) -> Tree -> Tree -> [a]
zipCommonFiles f a b = catMaybes [ flip (f p) x `fmap` findFile a p
| (p, File x) <- list b ]
zipFiles :: (AnchoredPath -> Maybe Blob -> Maybe Blob -> a)
-> Tree -> Tree -> [a]
zipFiles f a b = [ f p (findFile a p) (findFile b p)
| p <- paths a `union` paths b ]
where paths t = sort [ p | (p, File _) <- list t ]
zipTrees :: (AnchoredPath -> Maybe TreeItem -> Maybe TreeItem -> a)
-> Tree -> Tree -> [a]
zipTrees f a b = [ f p (find a p) (find b p)
| p <- reverse (paths a `union` paths b) ]
where paths t = sort [ p | (p, _) <- list t ]
diffTrees :: Tree -> Tree -> IO (Tree, Tree)
diffTrees left right =
if treeHash left `match` treeHash right
then return (emptyTree, emptyTree)
else diff left right
where match (Just h) (Just j) | h == j = True
match _ _ = False
isFile (File _) = True
isFile _ = False
notFile = not . isFile
subtree :: TreeItem -> IO Tree
subtree (Stub x _) = x
subtree (SubTree x) = return x
subtree (File _) = error "diffTrees tried to descend a File as a subtree"
maybeUnfold (Stub x _) = SubTree `fmap` (x >>= expand)
maybeUnfold (SubTree x) = SubTree `fmap` expand x
maybeUnfold i = return i
immediateN t = [ n | (n, _) <- listImmediate t ]
diff left' right' = do
is <- sequence [
case (lookup left' n, lookup right' n) of
(Just l, Nothing) -> do
l' <- maybeUnfold l
return (n, Just l', Nothing)
(Nothing, Just r) -> do
r' <- maybeUnfold r
return (n, Nothing, Just r')
(Just l, Just r)
| itemHash l `match` itemHash r ->
return (n, Nothing, Nothing)
| notFile l && notFile r ->
do x <- subtree l
y <- subtree r
(x', y') <- diffTrees x y
return (n, Just $ SubTree x', Just $ SubTree y')
| isFile l && isFile r ->
return (n, Just l, Just r)
| otherwise -> do l' <- maybeUnfold l
r' <- maybeUnfold r
return (n, Just l', Just r')
_ -> error "n lookups failed"
| n <- immediateN left' `union` immediateN right' ]
let is_l = [ (n, l) | (n, Just l ,_) <- is ]
is_r = [ (n, r) | (n, _, Just r) <- is ]
return (makeTree is_l, makeTree is_r)
modifyTree :: Tree -> AnchoredPath -> Maybe TreeItem -> Tree
modifyTree _ (AnchoredPath []) (Just (SubTree sub)) = sub
modifyTree t (AnchoredPath [n]) (Just item) =
t { items = M.insert n item (items t)
, listImmediate = (n,item) : subs
, treeHash = Nothing }
where subs = [ x | x@(n', _) <- listImmediate t, n /= n' ]
modifyTree t (AnchoredPath [n]) Nothing =
t { items = M.delete n (items t)
, listImmediate = subs
, treeHash = Nothing }
where subs = [ x | x@(n', _) <- listImmediate t, n /= n' ]
modifyTree t path@(AnchoredPath (n:r)) item =
t { items = M.insert n sub (items t)
, listImmediate = (n,sub) : subs
, treeHash = Nothing }
where subs = [ x | x@(n', _) <- listImmediate t, n /= n' ]
modSubtree s = modifyTree s (AnchoredPath r) item
sub = case lookup t n of
Just (SubTree s) -> SubTree $ modSubtree s
Just (Stub s _) -> Stub (do x <- s
return $ modSubtree x) Nothing
Nothing -> SubTree $ modSubtree emptyTree
_ -> error $ "Modify tree at " ++ show path
modifyTree _ (AnchoredPath []) (Just (Stub _ _)) =
error "Bug in descent in modifyTree."
modifyTree _ (AnchoredPath []) (Just (File _)) =
error "Bug in descent in modifyTree."
modifyTree _ (AnchoredPath []) Nothing =
error "Bug in descent in modifyTree."