diff --git a/Storage/Hashed/Darcs.hs b/Storage/Hashed/Darcs.hs --- a/Storage/Hashed/Darcs.hs +++ b/Storage/Hashed/Darcs.hs @@ -182,8 +182,10 @@ let dirs = darcsFormatDir t : [ darcsFormatDir d | (_, SubTree d) <- list t ] os' <- mapM dump $ map fromJust dirs return $ darcsTreeHash t - where dump bits = BL.writeFile (dir BS.unpack (encodeBase16 $ sha256 bits)) (compress bits) - + where dump bits = + do let name = dir BS.unpack (encodeBase16 $ sha256 bits) + exist <- doesFileExist name + unless exist $ BL.writeFile name (compress bits) -- | Create a hashed file from a 'FilePath' and content. In case the file exists -- it is kept untouched and is assumed to have the right content. XXX Corrupt diff --git a/Storage/Hashed/Index.hs b/Storage/Hashed/Index.hs --- a/Storage/Hashed/Index.hs +++ b/Storage/Hashed/Index.hs @@ -239,7 +239,7 @@ do following <- fromIntegral <$> xlatePeek64 (iAux item) exists <- fileExists <$> getFileStatusBS (iPath item) let name it dirlen = Name $ (BS.drop (dirlen + 1) $ iDescriptor it) -- FIXME MAGIC - namelength = (BS.length $ iDescriptor item) - (dirlength state) -- FIXME MAGIC + namelength = (BS.length $ iDescriptor item) - (dirlength state) myname = name item (dirlength state) substate = state { start = start state + itemNext item , path = path state `appendPath` myname diff --git a/Storage/Hashed/Test.hs b/Storage/Hashed/Test.hs --- a/Storage/Hashed/Test.hs +++ b/Storage/Hashed/Test.hs @@ -173,13 +173,15 @@ , testCase "expandPath" check_expand_path , testCase "diffTrees" check_diffTrees , testCase "diffTrees identical" check_diffTrees_ident - , testProperty "treeEq" prop_tree_eq - , testProperty "deepTreeEq" prop_deep_tree_eq + , testProperty "shapeEq" prop_shape_eq + , testProperty "expandedShapeEq" prop_expanded_shape_eq , testProperty "expand is identity" prop_expand_id , testProperty "filter True is identity" prop_filter_id , testProperty "filter False is empty" prop_filter_empty , testProperty "restrict both ways keeps shape" prop_restrict_shape_commutative - , testProperty "restrict is a subtree of both" prop_restrict_subtree ] + , testProperty "restrict is a subtree of both" prop_restrict_subtree + , testProperty "overlay keeps shape" prop_overlay_shape + , testProperty "overlay is superset of over" prop_overlay_super ] where blob x = File $ Blob (return (BL.pack x)) (sha256 $ BL.pack x) name = Name . BS.pack check_modify = @@ -261,8 +263,8 @@ (working', pristine') <- diffTrees working pristine let foo_work = findFile working' (floatPath "foo_dir/foo_a") foo_pris = findFile pristine' (floatPath "foo_dir/foo_a") - working' `treeEq` pristine' - @? show working' ++ " `treeEq` " ++ show pristine' + working' `shapeEq` pristine' + @? show working' ++ " `shapeEq` " ++ show pristine' assertBool "foo_dir/foo_a is in working'" $ isJust foo_work assertBool "foo_dir/foo_a is in pristine'" $ isJust foo_pris foo_work_c <- readBlob (fromJust foo_work) @@ -278,28 +280,35 @@ assertBool "t1 is empty" $ null (list t1) assertBool "t2 is empty" $ null (list t2) - prop_tree_eq x = no_stubs x ==> x `treeEq` x + prop_shape_eq x = no_stubs x ==> x `shapeEq` x where types = x :: Tree Identity - prop_deep_tree_eq x = runIdentity $ deepTreeEq x x + prop_expanded_shape_eq x = runIdentity $ expandedShapeEq x x where types = x :: Tree Identity - prop_expand_id x = no_stubs x ==> runIdentity (expand x) `treeEq` x + prop_expand_id x = no_stubs x ==> runIdentity (expand x) `shapeEq` x where types = x :: Tree Identity - prop_filter_id x = runIdentity $ deepTreeEq x $ filter (\_ _ -> True) x + prop_filter_id x = runIdentity $ expandedShapeEq x $ filter (\_ _ -> True) x where types = x :: Tree Identity - prop_filter_empty x = runIdentity $ deepTreeEq emptyTree $ filter (\_ _ -> False) x + prop_filter_empty x = runIdentity $ expandedShapeEq emptyTree $ filter (\_ _ -> False) x where types = x :: Tree Identity prop_restrict_shape_commutative (t1, t2) = - no_stubs t1 && no_stubs t2 && not (restrict t1 t2 `treeEq` emptyTree) ==> - restrict t1 t2 `treeEq` restrict t2 t1 + no_stubs t1 && no_stubs t2 && not (restrict t1 t2 `shapeEq` emptyTree) ==> + restrict t1 t2 `shapeEq` restrict t2 t1 where types = (t1 :: Tree Identity, t2 :: Tree Identity) prop_restrict_subtree (t1, t2) = - no_stubs t1 && not (restrict t1 t2 `treeEq` emptyTree) ==> + no_stubs t1 && not (restrict t1 t2 `shapeEq` emptyTree) ==> let restricted = S.fromList (map fst $ list $ restrict t1 t2) orig1 = S.fromList (map fst $ list t1) orig2 = S.fromList (map fst $ list t2) in and [restricted `S.isSubsetOf` orig1, restricted `S.isSubsetOf` orig2] where types = (t1 :: Tree Identity, t2 :: Tree Identity) + prop_overlay_shape (t1 :: Tree Identity, t2) = + (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) ==> + runIdentity $ (t1 `overlay` t2) `expandedShapeEq` t1 + prop_overlay_super (t1 :: Tree Identity, t2) = + (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) ==> + Just EQ == (runIdentity $ restrict t2 (t1 `overlay` t2) `cmpTree` t2) + packed = [ testCase "loose pristine tree" check_loose , testCase "load" check_load , testCase "live" check_live @@ -514,18 +523,38 @@ -- Test utilities -- -treeItemEq (File _) (File _) = True -treeItemEq (SubTree s) (SubTree p) = s `treeEq` p -treeItemEq _ _ = False +shapeEq a b = Just EQ == cmpShape a b +expandedShapeEq a b = (Just EQ ==) <$> cmpExpandedShape a b -treeEq t r = and $ zipTrees cmp t r - where cmp _ (Just a) (Just b) = a `treeItemEq` b - cmp _ _ _ = False +cmpcat (x:y:rest) | x == y = cmpcat (x:rest) + | x == Just EQ = cmpcat (y:rest) + | y == Just EQ = cmpcat (x:rest) + | otherwise = Nothing +cmpcat [x] = x +cmpcat [] = Just EQ -- empty things are equal -deepTreeEq :: (Monad m) => Tree m -> Tree m -> m Bool -deepTreeEq a b = do x <- expand a - y <- expand b - return $ x `treeEq` y +cmpTree a b = do a' <- expand a + b' <- expand b + con <- contentsEq a' b' + return $ cmpcat [cmpShape a' b', con] + where contentsEq a b = cmpcat <$> sequence (zipTrees cmp a b) + cmp _ (Just (File a)) (Just (File b)) = do a' <- readBlob a + b' <- readBlob b + return $ Just (compare a' b') + cmp _ _ _ = return (Just EQ) -- neutral + +cmpShape t r = cmpcat $ zipTrees cmp t r + where cmp _ (Just a) (Just b) = a `item` b + cmp _ Nothing (Just _) = Just LT + cmp _ (Just _) Nothing = Just GT + item (File _) (File _) = Just EQ + item (SubTree s) (SubTree p) = s `cmpShape` p + item _ _ = Nothing + +cmpExpandedShape :: (Monad m) => Tree m -> Tree m -> m (Maybe Ordering) +cmpExpandedShape a b = do x <- expand a + y <- expand b + return $ x `cmpShape` y nondarcs (AnchoredPath (Name x:_)) _ | x == BS.pack "_darcs" = False | otherwise = True diff --git a/Storage/Hashed/Tree.hs b/Storage/Hashed/Tree.hs --- a/Storage/Hashed/Tree.hs +++ b/Storage/Hashed/Tree.hs @@ -25,7 +25,7 @@ , FilterTree(..), filter, restrict -- * Manipulating trees. - , modifyTree, updateTree, updateSubtrees ) where + , modifyTree, updateTree, updateSubtrees, overlay ) where import Prelude hiding( lookup, filter, all ) import Storage.Hashed.AnchoredPath @@ -379,3 +379,25 @@ return t where update (k, SubTree tree) = (\new -> (k, SubTree new)) <$> updateTree fun tree update (k, item) = (\new -> (k, new)) <$> fun item + +-- | Lay one tree over another. The resulting Tree will look like the base (1st +-- parameter) Tree, although any items also present in the overlay Tree will be +-- taken from the overlay. It is not allowed to overlay a different kind of an +-- object, nor it is allowed for the overlay to add new objects to base. This +-- means that the overlay Tree should be a subset of the base Tree (although +-- any extraneous items will be ignored by the implementation). +overlay :: (Functor m, Monad m) => Tree m -> Tree m -> Tree m +overlay base over = Tree { items = M.fromList immediate + , listImmediate = immediate + , treeHash = NoHash } + where immediate = [ (n, get n) | (n, _) <- listImmediate base ] + get n = case (M.lookup n $ items base, M.lookup n $ items over) of + (Just (File _), Just f@(File _)) -> f + (Just (SubTree b), Just (SubTree o)) -> SubTree $ overlay b o + (Just (Stub b _), Just (SubTree o)) -> Stub (flip overlay o `fmap` b) NoHash + (Just (SubTree b), Just (Stub o _)) -> Stub (overlay b `fmap` o) NoHash + (Just (Stub b _), Just (Stub o _)) -> Stub (do o' <- o + b' <- b + return $ overlay b' o') NoHash + (Just x, _) -> x + (_, _) -> error $ "Unexpected case in overlay at get " ++ show n ++ "." diff --git a/hashed-storage.cabal b/hashed-storage.cabal --- a/hashed-storage.cabal +++ b/hashed-storage.cabal @@ -1,5 +1,5 @@ name: hashed-storage -version: 0.4.0 +version: 0.4.1 synopsis: Hashed file storage support code. description: Support code for reading and manipulating hashed file storage