diff --git a/Storage/Hashed/AnchoredPath.hs b/Storage/Hashed/AnchoredPath.hs --- a/Storage/Hashed/AnchoredPath.hs +++ b/Storage/Hashed/AnchoredPath.hs @@ -82,8 +82,9 @@ -- FilePaths before you declare them "good" by converting into AnchoredPath -- (using this function). floatPath :: FilePath -> AnchoredPath -floatPath = AnchoredPath . map (Name . BS.pack) . splitDirectories - . normalise . dropTrailingPathSeparator +floatPath = make . splitDirectories . normalise . dropTrailingPathSeparator + where make ["."] = AnchoredPath [] + make x = AnchoredPath $ map (Name . BS.pack) x anchoredRoot :: AnchoredPath diff --git a/Storage/Hashed/Darcs.hs b/Storage/Hashed/Darcs.hs --- a/Storage/Hashed/Darcs.hs +++ b/Storage/Hashed/Darcs.hs @@ -18,7 +18,7 @@ import Data.List( sortBy ) import Data.Char( chr, ord, isSpace ) -import Data.Maybe( fromJust ) +import Data.Maybe( fromJust, isJust ) import qualified Data.Set as S import Control.Monad.State.Strict @@ -78,10 +78,13 @@ _ -> Nothing darcsLocation :: FilePath -> (Maybe Int, Hash) -> FileSegment -darcsLocation dir (s,h) = (dir (prefix s ++ BS8.unpack (encodeBase16 h)), Nothing) +darcsLocation dir (s,h) = case hash of + "" -> error "darcsLocation: invalid hash" + _ -> (dir prefix s ++ hash, Nothing) where prefix Nothing = "" prefix (Just s') = formatSize s' ++ "-" formatSize s' = let n = show s' in replicate (10 - length n) '0' ++ n + hash = BS8.unpack (encodeBase16 h) ---------------------------------------------- -- Darcs directory format. @@ -94,8 +97,7 @@ string (Name name, item) = do header <- case item of File _ -> Just $ BS8.pack "file:\n" - SubTree _ -> Just $ BS8.pack "directory:\n" - Stub _ _ -> Nothing + _ -> Just $ BS8.pack "directory:\n" hash <- case itemHash item of NoHash -> Nothing x -> Just $ encodeBase16 x @@ -147,6 +149,7 @@ update (File blob@(Blob con NoHash)) = do hash <- sha256 <$> readBlob blob return $ File (Blob con hash) + update (Stub _ NoHash) = fail "NoHash Stub encountered in darcsAddMissingHashes" update x = return x ------------------------------------------- @@ -168,21 +171,26 @@ -- | Read in a darcs-style hashed tree. This is mainly useful for reading -- \"pristine.hashed\". You need to provide the root hash you are interested in -- (found in _darcs/hashed_inventory). -readDarcsHashed :: FilePath -> (Maybe Int, Hash) -> IO (Tree IO) -readDarcsHashed _ (_, NoHash) = fail "Cannot readDarcsHashed NoHash" -readDarcsHashed dir root@(_, hash) = do +readDarcsHashed' :: Bool -> FilePath -> (Maybe Int, Hash) -> IO (Tree IO) +readDarcsHashed' _ _ (_, NoHash) = fail "Cannot readDarcsHashed NoHash" +readDarcsHashed' sizefail dir root@(_, hash) = do items' <- readDarcsHashedDir dir root subs <- sequence [ - case tp of - BlobType -> return (d, File $ - Blob (readBlob' (s, h)) h) - TreeType -> - do let t = readDarcsHashed dir (s, h) - return (d, Stub t h) + do when (sizefail && isJust s) $ + fail ("Unexpectedly encountered size-prefixed hash in " ++ dir) + case tp of + BlobType -> return (d, File $ + Blob (readBlob' (s, h)) h) + TreeType -> + do let t = readDarcsHashed dir (s, h) + return (d, Stub t h) | (tp, d, s, h) <- items' ] return $ makeTreeWithHash subs hash where readBlob' = fmap decompress . readSegment . darcsLocation dir +readDarcsHashed = readDarcsHashed' False +readDarcsHashedNosize dir hash = readDarcsHashed' True dir (Nothing, hash) + ---------------------------------------------------- -- Writing darcs-style hashed trees. -- @@ -237,12 +245,10 @@ fsCreateHashedFile fn newcontent replaceItem path (Just nblob) updateSub path s = do - let !hash = darcsTreeHash s + let !hash = treeHash s Just dirdata = darcsFormatDir s fn = dir BS8.unpack (encodeBase16 hash) - ns = SubTree (s { treeHash = hash }) fsCreateHashedFile fn (compress dirdata) - replaceItem path (Just ns) -------------------------------------------------------------- -- Reading and writing packed pristine. EXPERIMENTAL. diff --git a/Storage/Hashed/Index.hs b/Storage/Hashed/Index.hs --- a/Storage/Hashed/Index.hs +++ b/Storage/Hashed/Index.hs @@ -202,7 +202,8 @@ iHash' i = SHA256 (iHash i) -- | Gives a ForeignPtr to mmapped index, which can be used for reading and --- updates. +-- updates. The req_size parameter, if non-0, expresses the requested size of +-- the index file. mmapIndex will grow the index if it is smaller than this. mmapIndex :: forall a. FilePath -> Int -> IO (ForeignPtr a, Int) mmapIndex indexpath req_size = do exist <- doesFileExist indexpath @@ -214,8 +215,8 @@ | otherwise -> 0 case size of 0 -> return (castForeignPtr nullForeignPtr, size) - _ -> do (x, _) <- mmapFileForeignPtr indexpath - ReadWrite (Just (0, size + size_magic)) + _ -> do (x, _, _) <- mmapFileForeignPtr indexpath + ReadWriteEx (Just (0, size + size_magic)) return (x, size) data IndexM m = Index { mmap :: (ForeignPtr ()) diff --git a/Storage/Hashed/Monad.hs b/Storage/Hashed/Monad.hs --- a/Storage/Hashed/Monad.hs +++ b/Storage/Hashed/Monad.hs @@ -54,7 +54,7 @@ class (Functor m, Monad m) => TreeRO m where currentDirectory :: m AnchoredPath withDirectory :: (MonadError e m) => AnchoredPath -> m a -> m a - expandTo :: (MonadError e m) => AnchoredPath -> m () + expandTo :: (MonadError e m) => AnchoredPath -> m AnchoredPath -- | Grab content of a file in the current Tree at the given path. readFile :: (MonadError e m) => AnchoredPath -> m BL.ByteString -- | Check for existence of a node (file or directory, doesn't matter). @@ -147,33 +147,39 @@ instance (Monad m, MonadError e m) => TreeRO (TreeMonad m) where expandTo p = do t <- gets tree - case find t p of - Nothing -> do t' <- lift $ expandPath t p `catchError` \_ -> return t - modify $ \st -> st { tree = t' } + p' <- (`catPaths` p) `fmap` ask + let amend = do t' <- lift $ expandPath t p' + modify $ \st -> st { tree = t' } + case find t p' of + Nothing -> amend + Just (Stub _ _) -> amend _ -> return () + return p' fileExists p = - do expandTo p - (isJust . (flip findFile p)) `fmap` gets tree + do p' <- expandTo p + (isJust . (flip findFile p')) `fmap` gets tree directoryExists p = - do expandTo p - (isJust . (flip findTree p)) `fmap` gets tree + do p' <- expandTo p + (isJust . (flip findTree p')) `fmap` gets tree exists p = - do expandTo p - (isJust . (flip find p)) `fmap` gets tree + do p' <- expandTo p + (isJust . (flip find p')) `fmap` gets tree readFile p = - do expandTo p + do p' <- expandTo p t <- gets tree - let f = findFile t p + let f = findFile t p' case f of - Nothing -> fail $ "No such file " ++ show p + Nothing -> fail $ "No such file " ++ show p' Just x -> lift (readBlob x) currentDirectory = ask - withDirectory dir = local (\old -> old `catPaths` dir) + withDirectory dir act = do + dir' <- expandTo dir + local (\old -> dir') act instance (Functor m, Monad m, MonadError e m) => TreeRW (TreeMonad m) where writeFile p con = @@ -196,12 +202,13 @@ modifyItem p Nothing rename from to = - do expandTo from + do from' <- expandTo from + to' <- expandTo to tr <- gets tree - let item = find tr from - found_to = find tr to + let item = find tr from' + found_to = find tr to' unless (isNothing found_to) $ fail $ "Error renaming: destination " ++ show to ++ " exists." unless (isNothing item) $ do - modifyItem to item modifyItem from Nothing + modifyItem to item diff --git a/Storage/Hashed/Test.hs b/Storage/Hashed/Test.hs --- a/Storage/Hashed/Test.hs +++ b/Storage/Hashed/Test.hs @@ -171,8 +171,10 @@ , testCase "modifyTree removal" check_modify_remove , testCase "expand" check_expand , testCase "expandPath" check_expand_path + , testCase "expandPath of sub" check_expand_path_sub , testCase "diffTrees" check_diffTrees , testCase "diffTrees identical" check_diffTrees_ident + , testProperty "expandPath" prop_expandPath , testProperty "shapeEq" prop_shape_eq , testProperty "expandedShapeEq" prop_expanded_shape_eq , testProperty "expand is identity" prop_expand_id @@ -253,6 +255,16 @@ assertBool "badpath not reachable in t'" $ badpath `notElem` (map fst $ list t') + check_expand_path_sub = do + t <- expandPath testTree $ floatPath "substub" + t' <- expandPath testTree $ floatPath "substub/stub" + t'' <- expandPath testTree $ floatPath "subtree/stub" + assertBool "leaf is not a Stub" $ + isNothing (findTree testTree $ floatPath "substub") + assertBool "leaf is not a Stub" $ isJust (findTree t $ floatPath "substub") + assertBool "leaf is not a Stub (2)" $ isJust (findTree t' $ floatPath "substub/stub") + assertBool "leaf is not a Stub (3)" $ isJust (findTree t'' $ floatPath "subtree/stub") + check_diffTrees = flip finally (Prelude.writeFile "foo_dir/foo_a" "a\n") $ do Prelude.writeFile "foo_dir/foo_a" "b\n" @@ -307,7 +319,11 @@ prop_overlay_super (t1 :: Tree Identity, t2) = (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) ==> Just EQ == (runIdentity $ restrict t2 (t1 `overlay` t2) `cmpTree` t2) - + prop_expandPath (TreeWithPath t p) = + notStub $ find (runIdentity $ expandPath t p) p + where notStub (Just (Stub _ _)) = False + notStub Nothing = error "Did not exist." + notStub _ = True packed = [ testCase "loose pristine tree" check_loose , testCase "load" check_load @@ -416,12 +432,18 @@ where prop_base16 x = (decodeBase16 . encodeBase16) x == x prop_base64u x = (decodeBase64u . encodeBase64u) x == x -monad = [ testCase "path expansion" check_virtual ] +monad = [ testCase "path expansion" check_virtual + , testCase "rename" check_rename ] where check_virtual = virtualTreeMonad run testTree >> return () where run = do file <- readFile (floatPath "substub/substub/file") file2 <- readFile (floatPath "substub/substub/file2") lift $ BL.unpack file @?= "" lift $ BL.unpack file2 @?= "foo" + check_rename = do (_, t) <- virtualTreeMonad run testTree + t' <- darcsAddMissingHashes =<< expand t + forM_ [ (p, i) | (p, i) <- list t' ] $ \(p,i) -> + assertBool ("have hash: " ++ show p) $ itemHash i /= NoHash + where run = do rename (floatPath "substub/substub/file") (floatPath "substub/file2") posix = [ testCase "getFileStatus" $ check_stat Posix.getFileStatus , testCase "getSymbolicLinkStatus" $ check_stat Posix.getSymbolicLinkStatus ] @@ -497,6 +519,14 @@ File _ -> arbitrary Stub _ _ -> arbitrary SubTree t -> return t + +data TreeWithPath = TreeWithPath (Tree Identity) AnchoredPath deriving (Show) + +instance Arbitrary TreeWithPath where + arbitrary = do t <- arbitrary + p <- oneof $ return (AnchoredPath []) : + (map (return . fst) $ list (runIdentity $ expand t)) + return $ TreeWithPath t p --------------------------- -- Other instances diff --git a/Storage/Hashed/Tree.hs b/Storage/Hashed/Tree.hs --- a/Storage/Hashed/Tree.hs +++ b/Storage/Hashed/Tree.hs @@ -35,7 +35,7 @@ import qualified Data.ByteString.Char8 as BS import qualified Data.Map as M -import Data.Maybe( catMaybes ) +import Data.Maybe( catMaybes, isNothing ) import Data.List( union, sort ) import Control.Applicative( (<$>) ) @@ -158,10 +158,6 @@ expanded_map = M.fromList expanded tree = t { items = M.union orig_map expanded_map } update path tree - unstub (Stub s _) = s - unstub (SubTree t) = return t - isSub (File _) = False - isSub _ = True -- | Expand a stubbed Tree into a one with no stubs in it. You might want to -- filter the tree before expanding to save IO. This is the basic @@ -171,21 +167,18 @@ expand = expandUpdate $ \_ -> return -- | Unfold a path in a (stubbed) Tree, such that the leaf node of the path is --- reachable without crossing any stubs. +-- reachable without crossing any stubs. Moreover, the leaf ought not be a Stub +-- in the resulting Tree. A non-existent path is expanded as far as it can be. expandPath :: (Monad m) => Tree m -> AnchoredPath -> m (Tree m) -expandPath t_ path_ = do expand' t_ path_ - where expand' t (AnchoredPath [_]) = return t - expand' t (AnchoredPath (n:rest)) = do +expandPath t_ path_ = expand' t_ path_ + where expand' t (AnchoredPath []) = return t + expand' t (AnchoredPath (n:rest)) = 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_ + (Just item) | isSub item -> amend t n rest =<< unstub item + _ -> return 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) } + let tree = t { items = M.insert name (SubTree sub') (items t) } return tree class (Monad m) => FilterTree a m where @@ -322,37 +315,40 @@ -- | Modify a Tree (by replacing, or removing or adding items). modifyTree :: (Monad m) => Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m +modifyTree t_ p_ i_ = snd $ go t_ p_ i_ + where fix t unmod items' = (unmod, t { items = countmap items' `seq` items' + , treeHash = if unmod then treeHash t else NoHash }) -modifyTree _ (AnchoredPath []) (Just (SubTree sub)) = sub + go t (AnchoredPath []) (Just (SubTree sub)) = (treeHash t `match` treeHash sub, sub) -modifyTree t (AnchoredPath [n]) (Just item) = - t { items = countmap items' `seq` items' - , treeHash = NoHash } - where !items' = M.insert n item (items t) + go t (AnchoredPath [n]) (Just item) = fix t unmod items' + where !items' = M.insert n item (items t) + !unmod = itemHash item `match` case lookup t n of + Nothing -> NoHash + Just i -> itemHash i -modifyTree t (AnchoredPath [n]) Nothing = - t { items = countmap items' `seq` items' - , treeHash = NoHash } - where !items' = M.delete n (items t) + go t (AnchoredPath [n]) Nothing = fix t unmod items' + where !items' = M.delete n (items t) + !unmod = isNothing $ lookup t n -modifyTree t path@(AnchoredPath (n:r)) item = - t { items = countmap items' `seq` items' - , treeHash = NoHash } - where subtree s = modifyTree s (AnchoredPath r) item - !items' = M.insert n sub (items t) - !sub = case lookup t n of - Just (SubTree s) -> SubTree $! subtree s - Just (Stub s _) -> Stub (do x <- s - return $! subtree x) NoHash - Nothing -> SubTree $! subtree emptyTree - _ -> error $ "Modify tree at " ++ show path + go t path@(AnchoredPath (n:r)) item = fix t unmod items' + where subtree s = go s (AnchoredPath r) item + !items' = M.insert n sub (items t) + !sub = snd sub' + !unmod = fst sub' + !sub' = case lookup t n of + Just (SubTree s) -> let (mod, sub) = subtree s in (mod, SubTree sub) + Just (Stub s _) -> (False, Stub (do x <- s + return $! snd $! subtree x) NoHash) + Nothing -> (False, SubTree $! snd $! subtree 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." + go _ (AnchoredPath []) (Just (Stub _ _)) = + error "Bug in descent in modifyTree." + go _ (AnchoredPath []) (Just (File _)) = + error "Bug in descent in modifyTree." + go _ (AnchoredPath []) Nothing = + error "Bug in descent in modifyTree." countmap = M.fold (\_ i -> i + 1) 0 @@ -394,3 +390,15 @@ return $ overlay b' o') NoHash (Just x, _) -> x (_, _) -> error $ "Unexpected case in overlay at get " ++ show n ++ "." + + +------ Private utilities shared among multiple functions. -------- + +unstub :: (Monad m) => TreeItem m -> m (Tree m) +unstub (Stub s _) = s +unstub (SubTree s) = return s + +isSub :: TreeItem m -> Bool +isSub (File _) = False +isSub _ = True + 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.13 +version: 0.5 synopsis: Hashed file storage support code. description: Support code for reading and manipulating hashed file storage @@ -73,7 +73,7 @@ dataenc, binary, zlib, - mmap >= 0.4 && < 0.5 + mmap >= 0.5 && < 0.6 c-sources: Bundled/sha2.c