diff options
| -rw-r--r-- | Content.hs | 10 | ||||
| -rw-r--r-- | LocationLog.hs | 32 | ||||
| -rw-r--r-- | Locations.hs | 9 | ||||
| -rw-r--r-- | Utility.hs | 12 |
4 files changed, 50 insertions, 13 deletions
diff --git a/Content.hs b/Content.hs index 88e8dbc00..ba265c930 100644 --- a/Content.hs +++ b/Content.hs @@ -219,9 +219,9 @@ getKeysPresent' dir = do then return [] else do -- 2 levels of hashing - levela <- liftIO $ subdirContent dir - levelb <- liftIO $ mapM subdirContent levela - contents <- liftIO $ mapM subdirContent (concat levelb) + levela <- liftIO $ dirContents dir + levelb <- liftIO $ mapM dirContents levela + contents <- liftIO $ mapM dirContents (concat levelb) files <- liftIO $ filterM present (concat contents) return $ catMaybes $ map (fileKey . takeFileName) files where @@ -231,7 +231,3 @@ getKeysPresent' dir = do case result of Right s -> return $ isRegularFile s Left _ -> return False - subdirContent d = do - c <- getDirectoryContents d - return $ map (d </>) $ filter notcruft c - notcruft f = f /= "." && f /= ".." diff --git a/LocationLog.hs b/LocationLog.hs index 8a47db2da..c2d956a29 100644 --- a/LocationLog.hs +++ b/LocationLog.hs @@ -1,9 +1,7 @@ {- git-annex location log - - - git-annex keeps track of on which repository it last saw a value. - - This can be useful when using it for archiving with offline storage. - - When you indicate you --want a file, git-annex will tell you which - - repositories have the value. + - git-annex keeps track of which repositories have the contents of annexed + - files. - - Location tracking information is stored in `.git-annex/key.log`. - Repositories record their UUID and the date when they --get or --drop @@ -15,7 +13,7 @@ - Git is configured to use a union merge for this file, - so the lines may be in arbitrary order, but it will never conflict. - - - Copyright 2010 Joey Hess <joey@kitenet.net> + - Copyright 2010-2011 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -25,14 +23,19 @@ module LocationLog ( logChange, readLog, writeLog, - keyLocations + keyLocations, + loggedKeys, + logFile ) where import Data.Time.Clock.POSIX import Data.Time import System.Locale +import System.Directory +import System.FilePath import qualified Data.Map as Map import Control.Monad (when) +import Data.Maybe import qualified GitRepo as Git import Utility @@ -153,3 +156,20 @@ mapLog m l = Just l' -> (date l' <= date l) Nothing -> True u = uuid l + +{- Finds all keys that have location log information. -} +loggedKeys :: Git.Repo -> IO [Key] +loggedKeys repo = do + let dir = gitStateDir repo + exists <- doesDirectoryExist dir + if exists + then do + -- 2 levels of hashing + levela <- dirContents dir + levelb <- mapM tryDirContents levela + files <- mapM tryDirContents (concat levelb) + return $ catMaybes $ + map (logFileKey . takeFileName) (concat files) + else return [] + where + tryDirContents d = catch (dirContents d) (return . const []) diff --git a/Locations.hs b/Locations.hs index 6c413a218..f263ea526 100644 --- a/Locations.hs +++ b/Locations.hs @@ -21,6 +21,7 @@ module Locations ( isLinkToAnnex, logFile, logFileOld, + logFileKey, hashDirMixed, prop_idempotent_fileKey @@ -127,6 +128,14 @@ logFile' :: (Key -> FilePath) -> Git.Repo -> Key -> String logFile' hasher repo key = gitStateDir repo ++ hasher key ++ keyFile key ++ ".log" +{- Converts a log filename into a key. -} +logFileKey :: FilePath -> Maybe Key +logFileKey file + | end == ".log" = readKey beginning + | otherwise = Nothing + where + (beginning, end) = splitAt (length file - 4) file + {- Converts a key into a filename fragment. - - Escape "/" in the key name, to keep a flat tree of files and avoid diff --git a/Utility.hs b/Utility.hs index 8312335f8..72f5c5063 100644 --- a/Utility.hs +++ b/Utility.hs @@ -22,6 +22,7 @@ module Utility ( readMaybe, safeWriteFile, dirContains, + dirContents, prop_idempotent_shellEscape, prop_idempotent_shellEscape_multiword, @@ -235,3 +236,14 @@ safeWriteFile file content = do createDirectoryIfMissing True (parentDir file) writeFile tmpfile content renameFile tmpfile file + +{- Lists the contents of a directory. + - Unlike getDirectoryContents, paths are not relative to the directory. -} +dirContents :: FilePath -> IO [FilePath] +dirContents d = do + c <- getDirectoryContents d + return $ map (d </>) $ filter notcruft c + where + notcruft "." = False + notcruft ".." = False + notcruft _ = True |