158 lines
4.7 KiB
Haskell
158 lines
4.7 KiB
Haskell
{- git-annex file content managing for direct mode
|
|
-
|
|
- Copyright 2010,2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Annex.Content.Direct (
|
|
associatedFiles,
|
|
removeAssociatedFile,
|
|
addAssociatedFile,
|
|
updateAssociatedFiles,
|
|
goodContent,
|
|
updateCache,
|
|
recordedCache,
|
|
compareCache,
|
|
writeCache,
|
|
removeCache,
|
|
genCache,
|
|
toCache,
|
|
Cache
|
|
) where
|
|
|
|
import Common.Annex
|
|
import qualified Git
|
|
import qualified Git.DiffTree as DiffTree
|
|
import Git.Sha
|
|
import Annex.CatFile
|
|
import Utility.TempFile
|
|
import Utility.FileMode
|
|
import Logs.Location
|
|
|
|
import System.Posix.Types
|
|
|
|
{- Files in the tree that are associated with a key. -}
|
|
associatedFiles :: Key -> Annex [FilePath]
|
|
associatedFiles key = do
|
|
files <- associatedFilesRelative key
|
|
top <- fromRepo Git.repoPath
|
|
return $ map (top </>) files
|
|
|
|
{- List of files in the tree that are associated with a key, relative to
|
|
- the top of the repo. -}
|
|
associatedFilesRelative :: Key -> Annex [FilePath]
|
|
associatedFilesRelative key = do
|
|
mapping <- inRepo $ gitAnnexMapping key
|
|
liftIO $ catchDefaultIO [] $ lines <$> readFile mapping
|
|
|
|
{- Changes the associated files information for a key, applying a
|
|
- transformation to the list. Returns a copy of the new info. -}
|
|
changeAssociatedFiles :: Key -> ([FilePath] -> [FilePath]) -> Annex [FilePath]
|
|
changeAssociatedFiles key transform = do
|
|
mapping <- inRepo $ gitAnnexMapping key
|
|
files <- associatedFilesRelative key
|
|
let files' = transform files
|
|
when (files /= files') $
|
|
liftIO $ viaTmp writeFile mapping $ unlines files'
|
|
return files'
|
|
|
|
removeAssociatedFile :: Key -> FilePath -> Annex [FilePath]
|
|
removeAssociatedFile key file = do
|
|
fs <- changeAssociatedFiles key $ filter (/= file)
|
|
when (null fs) $
|
|
logStatus key InfoMissing
|
|
return fs
|
|
|
|
addAssociatedFile :: Key -> FilePath -> Annex [FilePath]
|
|
addAssociatedFile key file = changeAssociatedFiles key $ \files ->
|
|
if file `elem` files
|
|
then files
|
|
else file:files
|
|
|
|
{- Uses git diff-tree to find files changed between two tree Shas, and
|
|
- updates the associated file mappings, efficiently. -}
|
|
updateAssociatedFiles :: Git.Sha -> Git.Sha -> Annex ()
|
|
updateAssociatedFiles oldsha newsha = do
|
|
(items, cleanup) <- inRepo $ DiffTree.diffTree oldsha newsha
|
|
forM_ items update
|
|
void $ liftIO $ cleanup
|
|
where
|
|
update item = do
|
|
go DiffTree.dstsha DiffTree.dstmode addAssociatedFile
|
|
go DiffTree.srcsha DiffTree.srcmode removeAssociatedFile
|
|
where
|
|
go getsha getmode a =
|
|
when (getsha item /= nullSha && isSymLink (getmode item)) $ do
|
|
key <- catKey (getsha item)
|
|
maybe noop (\k -> void $ a k $ DiffTree.file item) key
|
|
|
|
{- Checks if a file in the tree, associated with a key, has not been modified.
|
|
-
|
|
- To avoid needing to fsck the file's content, which can involve an
|
|
- expensive checksum, this relies on a cache that contains the file's
|
|
- expected mtime and inode.
|
|
-}
|
|
goodContent :: Key -> FilePath -> Annex Bool
|
|
goodContent key file = do
|
|
old <- recordedCache key
|
|
compareCache file old
|
|
|
|
{- Gets the recorded cache for a key. -}
|
|
recordedCache :: Key -> Annex (Maybe Cache)
|
|
recordedCache key = withCacheFile key $ \cachefile ->
|
|
catchDefaultIO Nothing $ readCache <$> readFile cachefile
|
|
|
|
{- Compares a cache with the current cache for a file. -}
|
|
compareCache :: FilePath -> Maybe Cache -> Annex Bool
|
|
compareCache file old = do
|
|
curr <- liftIO $ genCache file
|
|
return $ isJust curr && curr == old
|
|
|
|
{- Stores a cache of attributes for a file that is associated with a key. -}
|
|
updateCache :: Key -> FilePath -> Annex ()
|
|
updateCache key file = maybe noop (writeCache key) =<< liftIO (genCache file)
|
|
|
|
{- Writes a cache for a key. -}
|
|
writeCache :: Key -> Cache -> Annex ()
|
|
writeCache key cache = withCacheFile key $ \cachefile -> do
|
|
createDirectoryIfMissing True (parentDir cachefile)
|
|
writeFile cachefile $ showCache cache
|
|
|
|
{- Removes a cache. -}
|
|
removeCache :: Key -> Annex ()
|
|
removeCache key = withCacheFile key nukeFile
|
|
|
|
{- Cache a file's inode, size, and modification time to determine if it's
|
|
- been changed. -}
|
|
data Cache = Cache FileID FileOffset EpochTime
|
|
deriving (Eq, Show)
|
|
|
|
showCache :: Cache -> String
|
|
showCache (Cache inode size mtime) = unwords
|
|
[ show inode
|
|
, show size
|
|
, show mtime
|
|
]
|
|
|
|
readCache :: String -> Maybe Cache
|
|
readCache s = case words s of
|
|
(inode:size:mtime:_) -> Cache
|
|
<$> readish inode
|
|
<*> readish size
|
|
<*> readish mtime
|
|
_ -> Nothing
|
|
|
|
genCache :: FilePath -> IO (Maybe Cache)
|
|
genCache f = catchDefaultIO Nothing $ toCache <$> getFileStatus f
|
|
|
|
toCache :: FileStatus -> Maybe Cache
|
|
toCache s
|
|
| isRegularFile s = Just $ Cache
|
|
(fileID s)
|
|
(fileSize s)
|
|
(modificationTime s)
|
|
| otherwise = Nothing
|
|
|
|
withCacheFile :: Key -> (FilePath -> IO a) -> Annex a
|
|
withCacheFile key a = liftIO . a =<< inRepo (gitAnnexCache key)
|