summaryrefslogtreecommitdiff
path: root/Annex/Content.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2011-10-04 00:40:47 -0400
committerGravatar Joey Hess <joey@kitenet.net>2011-10-04 00:59:08 -0400
commitcfe21e85e7fba61ac588e210f2a9b75f8d081f42 (patch)
tree3237aa5460cb38254a44a6462c83db3c2276c229 /Annex/Content.hs
parentff21fd4a652cc6516d0e06ab885adf1c93eddced (diff)
rename
Diffstat (limited to 'Annex/Content.hs')
-rw-r--r--Annex/Content.hs237
1 files changed, 237 insertions, 0 deletions
diff --git a/Annex/Content.hs b/Annex/Content.hs
new file mode 100644
index 000000000..a3fa79da8
--- /dev/null
+++ b/Annex/Content.hs
@@ -0,0 +1,237 @@
+{- git-annex file content managing
+ -
+ - Copyright 2010 Joey Hess <joey@kitenet.net>
+ -
+ - 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 Annex.Common
+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 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
+ Annex.Queue.flush False
+ Annex.Branch.commit "update"