Direct.hs

{- 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,
	goodContent,
	changedFileStatus,
	updateCache,
	recordedCache,
	compareCache,
	writeCache,
	removeCache,
	genCache,
	toCache,
	Cache(..),
	prop_read_show_direct
) where

import Common.Annex
import qualified Git
import Utility.TempFile
import Logs.Location

import System.Posix.Types

{- Absolute FilePaths of 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 [] $ do
		h <- openFile mapping ReadMode
		fileEncoding h
		lines <$> hGetContents h

{- Changes the associated files information for a key, applying a
 - transformation to the list. Returns new associatedFiles value. -}
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 write mapping $ unlines files'
	top <- fromRepo Git.repoPath
	return $ map (top </>) files'
  where
	write file content = do
		h <- openFile file WriteMode
		fileEncoding h
 		hPutStr h content
		hClose h

{- Removes an associated file. Returns new associatedFiles value. -}
removeAssociatedFile :: Key -> FilePath -> Annex [FilePath]
removeAssociatedFile key file = do
	file' <- normaliseAssociatedFile file
	fs <- changeAssociatedFiles key $ filter (/= file')
	when (null fs) $
		logStatus key InfoMissing
	return fs

{- Adds an associated file. Returns new associatedFiles value. -}
addAssociatedFile :: Key -> FilePath -> Annex [FilePath]
addAssociatedFile key file = do
	file' <- normaliseAssociatedFile file
	changeAssociatedFiles key $ \files -> do
		if file' `elem` files
			then files
			else file':files

{- Associated files are always stored relative to the top of the repository.
 - The input FilePath is relative to the CWD. -}
normaliseAssociatedFile :: FilePath -> Annex FilePath
normaliseAssociatedFile file = do
	top <- fromRepo Git.repoPath
	liftIO $ relPathDirToFile top <$> absPath file

{- 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

changedFileStatus :: Key -> FileStatus -> Annex Bool
changedFileStatus key status = do
	old <- recordedCache key
	let curr = toCache status
	return $ curr /= 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

-- for quickcheck
prop_read_show_direct :: Cache -> Bool
prop_read_show_direct c = readCache (showCache c) == Just c

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)