hashed-storage 0.4.0 → 0.4.1
raw patch · 5 files changed
+81/−28 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Storage.Hashed.Tree: overlay :: (Functor m, Monad m) => Tree m -> Tree m -> Tree m
Files
- Storage/Hashed/Darcs.hs +4/−2
- Storage/Hashed/Index.hs +1/−1
- Storage/Hashed/Test.hs +52/−23
- Storage/Hashed/Tree.hs +23/−1
- hashed-storage.cabal +1/−1
Storage/Hashed/Darcs.hs view
@@ -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
Storage/Hashed/Index.hs view
@@ -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
Storage/Hashed/Test.hs view
@@ -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
Storage/Hashed/Tree.hs view
@@ -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 ++ "."
hashed-storage.cabal view
@@ -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