{- git-annex file content managing - - Copyright 2010 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} module Annex.Content ( inAnnex, calcGitLink, logStatus, getViaTmp, getViaTmpUnchecked, withTmp, checkDiskSpace, moveAnnex, removeAnnex, fromAnnex, moveBad, getKeysPresent, saveState ) where import Common.Annex import LocationLog import UUID import qualified Git import qualified Annex import qualified Annex.Queue import qualified Annex.Branch import Utility.StatFS import Utility.FileMode import Types.Key import Utility.DataUnits import Config {- Checks if a given key is currently present in the gitAnnexLocation. -} inAnnex :: Key -> Annex Bool inAnnex key = do g <- gitRepo when (Git.repoIsUrl g) $ error "inAnnex cannot check remote repo" liftIO $ doesFileExist $ gitAnnexLocation g key {- Calculates the relative path to use to link a file to a key. -} calcGitLink :: FilePath -> Key -> Annex FilePath calcGitLink file key = do g <- gitRepo cwd <- liftIO getCurrentDirectory let absfile = fromMaybe whoops $ absNormPath cwd file return $ relPathDirToFile (parentDir absfile) (Git.workTree g) ".git" annexLocation key where whoops = error $ "unable to normalize " ++ file {- Updates the LocationLog when a key's presence changes in the current - repository. -} logStatus :: Key -> LogStatus -> Annex () logStatus key status = do g <- gitRepo u <- getUUID logChange g key u status {- Runs an action, passing it a temporary filename to download, - and if the action succeeds, moves the temp file into - the annex as a key's content. -} getViaTmp :: Key -> (FilePath -> Annex Bool) -> Annex Bool getViaTmp key action = do g <- gitRepo let tmp = gitAnnexTmpLocation g key -- Check that there is enough free disk space. -- When the temp file already exists, count the space -- it is using as free. e <- liftIO $ doesFileExist tmp if e then do stat <- liftIO $ getFileStatus tmp checkDiskSpace' (fromIntegral $ fileSize stat) key else checkDiskSpace key when e $ liftIO $ allowWrite tmp getViaTmpUnchecked key action prepTmp :: Key -> Annex FilePath prepTmp key = do g <- gitRepo let tmp = gitAnnexTmpLocation g key liftIO $ createDirectoryIfMissing True (parentDir tmp) return tmp {- Like getViaTmp, but does not check that there is enough disk space - for the incoming key. For use when the key content is already on disk - and not being copied into place. -} getViaTmpUnchecked :: Key -> (FilePath -> Annex Bool) -> Annex Bool getViaTmpUnchecked key action = do tmp <- prepTmp key success <- action tmp if success then do moveAnnex key tmp logStatus key InfoPresent return True else do -- the tmp file is left behind, in case caller wants -- to resume its transfer return False {- Creates a temp file, runs an action on it, and cleans up the temp file. -} withTmp :: Key -> (FilePath -> Annex a) -> Annex a withTmp key action = do tmp <- prepTmp key res <- action tmp liftIO $ whenM (doesFileExist tmp) $ liftIO $ removeFile tmp return res {- Checks that there is disk space available to store a given key, - throwing an error if not. -} checkDiskSpace :: Key -> Annex () checkDiskSpace = checkDiskSpace' 0 checkDiskSpace' :: Integer -> Key -> Annex () checkDiskSpace' adjustment key = do g <- gitRepo r <- getConfig g "diskreserve" "" let reserve = fromMaybe megabyte $ readSize dataUnits r stats <- liftIO $ getFileSystemStats (gitAnnexDir g) case (stats, keySize key) of (Nothing, _) -> return () (_, Nothing) -> return () (Just (FileSystemStats { fsStatBytesAvailable = have }), Just need) -> when (need + reserve > have + adjustment) $ needmorespace (need + reserve - have - adjustment) where megabyte :: Integer megabyte = 1000000 needmorespace n = unlessM (Annex.getState Annex.force) $ error $ "not enough free space, need " ++ roughSize storageUnits True n ++ " more (use --force to override this check or adjust annex.diskreserve)" {- Moves a file into .git/annex/objects/ - - What if the key there already has content? This could happen for - various reasons; perhaps the same content is being annexed again. - Perhaps there has been a hash collision generating the keys. - - The current strategy is to assume that in this case it's safe to delete - one of the two copies of the content; and the one already in the annex - is left there, assuming it's the original, canonical copy. - - I considered being more paranoid, and checking that both files had - the same content. Decided against it because A) users explicitly choose - a backend based on its hashing properties and so if they're dealing - with colliding files it's their own fault and B) adding such a check - would not catch all cases of colliding keys. For example, perhaps - a remote has a key; if it's then added again with different content then - the overall system now has two different peices of content for that - key, and one of them will probably get deleted later. So, adding the - check here would only raise expectations that git-annex cannot truely - meet. -} moveAnnex :: Key -> FilePath -> Annex () moveAnnex key src = do g <- gitRepo let dest = gitAnnexLocation g key let dir = parentDir dest e <- liftIO $ doesFileExist dest if e then liftIO $ removeFile src else liftIO $ do createDirectoryIfMissing True dir allowWrite dir -- in case the directory already exists renameFile src dest preventWrite dest preventWrite dir withObjectLoc :: Key -> ((FilePath, FilePath) -> Annex a) -> Annex a withObjectLoc key a = do g <- gitRepo let file = gitAnnexLocation g key let dir = parentDir file a (dir, file) {- Removes a key's file from .git/annex/objects/ -} removeAnnex :: Key -> Annex () removeAnnex key = withObjectLoc key $ \(dir, file) -> liftIO $ do allowWrite dir removeFile file removeDirectory dir {- Moves a key's file out of .git/annex/objects/ -} fromAnnex :: Key -> FilePath -> Annex () fromAnnex key dest = withObjectLoc key $ \(dir, file) -> liftIO $ do allowWrite dir allowWrite file renameFile file dest removeDirectory dir {- Moves a key out of .git/annex/objects/ into .git/annex/bad, and - returns the file it was moved to. -} moveBad :: Key -> Annex FilePath moveBad key = do g <- gitRepo let src = gitAnnexLocation g key let dest = gitAnnexBadDir g takeFileName src liftIO $ do createDirectoryIfMissing True (parentDir dest) allowWrite (parentDir src) renameFile src dest removeDirectory (parentDir src) logStatus key InfoMissing return dest {- List of keys whose content exists in .git/annex/objects/ -} getKeysPresent :: Annex [Key] getKeysPresent = do g <- gitRepo getKeysPresent' $ gitAnnexObjectDir g getKeysPresent' :: FilePath -> Annex [Key] getKeysPresent' dir = do exists <- liftIO $ doesDirectoryExist dir if not exists then return [] else liftIO $ do -- 2 levels of hashing levela <- dirContents dir levelb <- mapM dirContents levela contents <- mapM dirContents (concat levelb) let files = concat contents return $ mapMaybe (fileKey . takeFileName) files {- Things to do to record changes to content. -} saveState :: Annex () saveState = do Annex.Queue.flush False Annex.Branch.commit "update"