diff options
author | Joey Hess <joey@kitenet.net> | 2011-10-04 00:40:47 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2011-10-04 00:59:08 -0400 |
commit | cfe21e85e7fba61ac588e210f2a9b75f8d081f42 (patch) | |
tree | 3237aa5460cb38254a44a6462c83db3c2276c229 /Content.hs | |
parent | ff21fd4a652cc6516d0e06ab885adf1c93eddced (diff) |
rename
Diffstat (limited to 'Content.hs')
-rw-r--r-- | Content.hs | 237 |
1 files changed, 0 insertions, 237 deletions
diff --git a/Content.hs b/Content.hs deleted file mode 100644 index 567e4caa5..000000000 --- a/Content.hs +++ /dev/null @@ -1,237 +0,0 @@ -{- git-annex file content managing - - - - Copyright 2010 Joey Hess <joey@kitenet.net> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Content ( - inAnnex, - calcGitLink, - logStatus, - getViaTmp, - getViaTmpUnchecked, - withTmp, - checkDiskSpace, - moveAnnex, - removeAnnex, - fromAnnex, - moveBad, - getKeysPresent, - saveState -) where - -import AnnexCommon -import LocationLog -import UUID -import qualified Git -import qualified Annex -import qualified AnnexQueue -import qualified 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 g - 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 - AnnexQueue.flush False - Branch.commit "update" |