diff --git a/Annex/Content.hs b/Annex/Content.hs index e4f47ee4f5..ee453dc348 100644 --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -54,7 +54,6 @@ module Annex.Content ( ) where import System.IO.Unsafe (unsafeInterleaveIO) -import System.PosixCompat.Files import qualified Data.Set as S import Annex.Common @@ -65,10 +64,8 @@ import qualified Git import qualified Annex import qualified Annex.Queue import qualified Annex.Branch -import Utility.DiskFree import Utility.FileMode import qualified Annex.Url as Url -import Utility.DataUnits import Utility.CopyFile import Utility.Metered import Config @@ -89,6 +86,8 @@ import Types.Key import Annex.UUID import Annex.InodeSentinal import Utility.InodeCache +import Annex.Content.LowLevel +import Annex.Content.PointerFile {- Checks if a given key's content is currently present. -} inAnnex :: Key -> Annex Bool @@ -453,51 +452,6 @@ withTmp key action = do pruneTmpWorkDirBefore tmp (liftIO . nukeFile) return res -{- Checks that there is disk space available to store a given key, - - in a destination directory (or the annex) printing a warning if not. - - - - If the destination is on the same filesystem as the annex, - - checks for any other running downloads, removing the amount of data still - - to be downloaded from the free space. This way, we avoid overcommitting - - when doing concurrent downloads. - -} -checkDiskSpace :: Maybe FilePath -> Key -> Integer -> Bool -> Annex Bool -checkDiskSpace destdir key = checkDiskSpace' (fromMaybe 1 (keySize key)) destdir key - -{- Allows specifying the size of the key, if it's known, which is useful - - as not all keys know their size. -} -checkDiskSpace' :: Integer -> Maybe FilePath -> Key -> Integer -> Bool -> Annex Bool -checkDiskSpace' need destdir key alreadythere samefilesystem = ifM (Annex.getState Annex.force) - ( return True - , do - -- We can't get inprogress and free at the same - -- time, and both can be changing, so there's a - -- small race here. Err on the side of caution - -- by getting inprogress first, so if it takes - -- a while, we'll see any decrease in the free - -- disk space. - inprogress <- if samefilesystem - then sizeOfDownloadsInProgress (/= key) - else pure 0 - dir >>= liftIO . getDiskFree >>= \case - Just have -> do - reserve <- annexDiskReserve <$> Annex.getGitConfig - let delta = need + reserve - have - alreadythere + inprogress - let ok = delta <= 0 - unless ok $ - warning $ needMoreDiskSpace delta - return ok - _ -> return True - ) - where - dir = maybe (fromRepo gitAnnexDir) return destdir - -needMoreDiskSpace :: Integer -> String -needMoreDiskSpace n = "not enough free space, need " ++ - roughSize storageUnits True n ++ " more" ++ forcemsg - where - forcemsg = " (use --force to override this check or adjust annex.diskreserve)" - {- Moves a key's content into .git/annex/objects/ - - When a key has associated pointer files, the object is hard @@ -586,22 +540,6 @@ checkSecureHashes key , return True ) -{- Populates a pointer file with the content of a key. -} -populatePointerFile :: Restage -> Key -> FilePath -> FilePath -> Annex () -populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f) - where - go (Just k') | k == k' = do - destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f - liftIO $ nukeFile f - ic <- replaceFile f $ \tmp -> do - ifM (linkOrCopy k obj tmp destmode) - ( thawContent tmp - , liftIO $ writePointerFile tmp k destmode - ) - withTSDelta (liftIO . genInodeCache tmp) - maybe noop (restagePointerFile restage f) ic - go _ = return () - data LinkAnnexResult = LinkAnnexOk | LinkAnnexFailed | LinkAnnexNoop {- Populates the annex object file by hard linking or copying a source @@ -666,40 +604,6 @@ linkAnnex fromto key src (Just srcic) dest destmode = liftIO $ nukeFile dest failed -{- Hard links or copies src to dest, which must not already exists. - - - - Only uses a hard link when annex.thin is enabled and when src is - - not already hardlinked to elsewhere. - - - - Checks disk reserve before copying against the size of the key, - - and will fail if not enough space, or if the dest file already exists. - - - - The FileMode, if provided, influences the mode of the dest file. - - In particular, if it has an execute bit set, the dest file's - - execute bit will be set. The mode is not fully copied over because - - git doesn't support file modes beyond execute. - -} -linkOrCopy :: Key -> FilePath -> FilePath -> Maybe FileMode -> Annex Bool -linkOrCopy = linkOrCopy' (annexThin <$> Annex.getGitConfig) - -linkOrCopy' :: Annex Bool -> Key -> FilePath -> FilePath -> Maybe FileMode -> Annex Bool -linkOrCopy' canhardlink key src dest destmode - | maybe False isExecutable destmode = copy =<< getstat - | otherwise = catchBoolIO $ - ifM canhardlink - ( hardlink - , copy =<< getstat - ) - where - hardlink = do - s <- getstat - if linkCount s > 1 - then copy s - else liftIO (createLink src dest >> preserveGitMode dest destmode >> return True) - `catchIO` const (copy s) - copy = checkedCopyFile' key src dest destmode - getstat = liftIO $ getFileStatus src - {- Removes the annex object file for a key. Lowlevel. -} unlinkAnnex :: Key -> Annex () unlinkAnnex key = do @@ -708,31 +612,6 @@ unlinkAnnex key = do secureErase obj liftIO $ nukeFile obj -{- Checks disk space before copying. -} -checkedCopyFile :: Key -> FilePath -> FilePath -> Maybe FileMode -> Annex Bool -checkedCopyFile key src dest destmode = catchBoolIO $ - checkedCopyFile' key src dest destmode - =<< liftIO (getFileStatus src) - -checkedCopyFile' :: Key -> FilePath -> FilePath -> Maybe FileMode -> FileStatus -> Annex Bool -checkedCopyFile' key src dest destmode s = catchBoolIO $ - ifM (checkDiskSpace' (fromIntegral $ fileSize s) (Just $ takeDirectory dest) key 0 True) - ( liftIO $ - copyFileExternal CopyAllMetaData src dest - <&&> preserveGitMode dest destmode - , return False - ) - -preserveGitMode :: FilePath -> Maybe FileMode -> IO Bool -preserveGitMode f (Just mode) - | isExecutable mode = catchBoolIO $ do - modifyFileMode f $ addModes executeModes - return True - | otherwise = catchBoolIO $ do - modifyFileMode f $ removeModes executeModes - return True -preserveGitMode _ _ = return True - {- Runs an action to transfer an object's content. - - In some cases, it's possible for the file to change as it's being sent. @@ -836,21 +715,14 @@ removeAnnex (ContentRemovalLock key) = withObjectLoc key remove removedirect -- Check associated pointer file for modifications, and reset if -- it's unmodified. resetpointer file = ifM (isUnmodified key file) - ( do - mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file - secureErase file - liftIO $ nukeFile file - ic <- replaceFile file $ \tmp -> do - liftIO $ writePointerFile tmp key mode - withTSDelta (liftIO . genInodeCache tmp) - maybe noop (restagePointerFile (Restage True) file) ic + ( depopulatePointerFile key file -- Modified file, so leave it alone. -- If it was a hard link to the annex object, -- that object might have been frozen as part of the -- removal process, so thaw it. , void $ tryIO $ thawContent file ) - + -- In direct mode, deletes the associated files or files, and replaces -- them with symlinks. removedirect fs = do @@ -883,16 +755,6 @@ isUnmodified key f = go =<< geti ) geti = withTSDelta (liftIO . genInodeCache f) -{- Runs the secure erase command if set, otherwise does nothing. - - File may or may not be deleted at the end; caller is responsible for - - making sure it's deleted. -} -secureErase :: FilePath -> Annex () -secureErase file = maybe noop go =<< annexSecureEraseCommand <$> Annex.getGitConfig - where - go basecmd = void $ liftIO $ - boolSystem "sh" [Param "-c", Param $ gencmd basecmd] - gencmd = massReplace [ ("%file", shellEscape file) ] - {- Moves a key out of .git/annex/objects/ into .git/annex/bad, and - returns the file it was moved to. -} moveBad :: Key -> Annex FilePath diff --git a/Annex/Content/LowLevel.hs b/Annex/Content/LowLevel.hs new file mode 100644 index 0000000000..07a5d67a64 --- /dev/null +++ b/Annex/Content/LowLevel.hs @@ -0,0 +1,134 @@ +{- git-annex low-level content functions + - + - Copyright 2010-2018 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Annex.Content.LowLevel where + +import System.PosixCompat.Files + +import Annex.Common +import Logs.Transfer +import qualified Annex +import Utility.DiskFree +import Utility.FileMode +import Utility.DataUnits +import Utility.CopyFile + +{- Runs the secure erase command if set, otherwise does nothing. + - File may or may not be deleted at the end; caller is responsible for + - making sure it's deleted. -} +secureErase :: FilePath -> Annex () +secureErase file = maybe noop go =<< annexSecureEraseCommand <$> Annex.getGitConfig + where + go basecmd = void $ liftIO $ + boolSystem "sh" [Param "-c", Param $ gencmd basecmd] + gencmd = massReplace [ ("%file", shellEscape file) ] + +{- Hard links or copies src to dest, which must not already exist. + - + - Only uses a hard link when annex.thin is enabled and when src is + - not already hardlinked to elsewhere. + - + - Checks disk reserve before copying against the size of the key, + - and will fail if not enough space, or if the dest file already exists. + - + - The FileMode, if provided, influences the mode of the dest file. + - In particular, if it has an execute bit set, the dest file's + - execute bit will be set. The mode is not fully copied over because + - git doesn't support file modes beyond execute. + -} +linkOrCopy :: Key -> FilePath -> FilePath -> Maybe FileMode -> Annex Bool +linkOrCopy = linkOrCopy' (annexThin <$> Annex.getGitConfig) + +linkOrCopy' :: Annex Bool -> Key -> FilePath -> FilePath -> Maybe FileMode -> Annex Bool +linkOrCopy' canhardlink key src dest destmode + | maybe False isExecutable destmode = copy =<< getstat + | otherwise = catchBoolIO $ + ifM canhardlink + ( hardlink + , copy =<< getstat + ) + where + hardlink = do + s <- getstat + if linkCount s > 1 + then copy s + else liftIO (createLink src dest >> preserveGitMode dest destmode >> return True) + `catchIO` const (copy s) + copy = checkedCopyFile' key src dest destmode + getstat = liftIO $ getFileStatus src + +{- Checks disk space before copying. -} +checkedCopyFile :: Key -> FilePath -> FilePath -> Maybe FileMode -> Annex Bool +checkedCopyFile key src dest destmode = catchBoolIO $ + checkedCopyFile' key src dest destmode + =<< liftIO (getFileStatus src) + +checkedCopyFile' :: Key -> FilePath -> FilePath -> Maybe FileMode -> FileStatus -> Annex Bool +checkedCopyFile' key src dest destmode s = catchBoolIO $ + ifM (checkDiskSpace' (fromIntegral $ fileSize s) (Just $ takeDirectory dest) key 0 True) + ( liftIO $ + copyFileExternal CopyAllMetaData src dest + <&&> preserveGitMode dest destmode + , return False + ) + +preserveGitMode :: FilePath -> Maybe FileMode -> IO Bool +preserveGitMode f (Just mode) + | isExecutable mode = catchBoolIO $ do + modifyFileMode f $ addModes executeModes + return True + | otherwise = catchBoolIO $ do + modifyFileMode f $ removeModes executeModes + return True +preserveGitMode _ _ = return True + +{- Checks that there is disk space available to store a given key, + - in a destination directory (or the annex) printing a warning if not. + - + - If the destination is on the same filesystem as the annex, + - checks for any other running downloads, removing the amount of data still + - to be downloaded from the free space. This way, we avoid overcommitting + - when doing concurrent downloads. + -} +checkDiskSpace :: Maybe FilePath -> Key -> Integer -> Bool -> Annex Bool +checkDiskSpace destdir key = checkDiskSpace' (fromMaybe 1 (keySize key)) destdir key + +{- Allows specifying the size of the key, if it's known, which is useful + - as not all keys know their size. -} +checkDiskSpace' :: Integer -> Maybe FilePath -> Key -> Integer -> Bool -> Annex Bool +checkDiskSpace' need destdir key alreadythere samefilesystem = ifM (Annex.getState Annex.force) + ( return True + , do + -- We can't get inprogress and free at the same + -- time, and both can be changing, so there's a + -- small race here. Err on the side of caution + -- by getting inprogress first, so if it takes + -- a while, we'll see any decrease in the free + -- disk space. + inprogress <- if samefilesystem + then sizeOfDownloadsInProgress (/= key) + else pure 0 + dir >>= liftIO . getDiskFree >>= \case + Just have -> do + reserve <- annexDiskReserve <$> Annex.getGitConfig + let delta = need + reserve - have - alreadythere + inprogress + let ok = delta <= 0 + unless ok $ + warning $ needMoreDiskSpace delta + return ok + _ -> return True + ) + where + dir = maybe (fromRepo gitAnnexDir) return destdir + +needMoreDiskSpace :: Integer -> String +needMoreDiskSpace n = "not enough free space, need " ++ + roughSize storageUnits True n ++ " more" ++ forcemsg + where + forcemsg = " (use --force to override this check or adjust annex.diskreserve)" diff --git a/Annex/Content/PointerFile.hs b/Annex/Content/PointerFile.hs new file mode 100644 index 0000000000..fb69214481 --- /dev/null +++ b/Annex/Content/PointerFile.hs @@ -0,0 +1,49 @@ +{- git-annex pointer files + - + - Copyright 2010-2018 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Annex.Content.PointerFile where + +import System.PosixCompat.Files + +import Annex.Common +import Annex.Perms +import Annex.Link +import Annex.ReplaceFile +import Annex.InodeSentinal +import Utility.InodeCache +import Annex.Content.LowLevel + +{- Populates a pointer file with the content of a key. -} +populatePointerFile :: Restage -> Key -> FilePath -> FilePath -> Annex () +populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f) + where + go (Just k') | k == k' = do + destmode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus f + liftIO $ nukeFile f + ic <- replaceFile f $ \tmp -> do + ifM (linkOrCopy k obj tmp destmode) + ( thawContent tmp + , liftIO $ writePointerFile tmp k destmode + ) + withTSDelta (liftIO . genInodeCache tmp) + maybe noop (restagePointerFile restage f) ic + go _ = return () + +{- Removes the content from a pointer file, replacing it with a pointer. + - + - Does not check if the pointer file is modified. -} +depopulatePointerFile :: Key -> FilePath -> Annex () +depopulatePointerFile key file = do + mode <- liftIO $ catchMaybeIO $ fileMode <$> getFileStatus file + secureErase file + liftIO $ nukeFile file + ic <- replaceFile file $ \tmp -> do + liftIO $ writePointerFile tmp key mode + withTSDelta (liftIO . genInodeCache tmp) + maybe noop (restagePointerFile (Restage True) file) ic diff --git a/git-annex.cabal b/git-annex.cabal index 86f626a438..49d09a27c9 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -551,6 +551,8 @@ Executable git-annex Annex.Concurrent Annex.Content Annex.Content.Direct + Annex.Content.LowLevel + Annex.Content.PointerFile Annex.Difference Annex.DirHashes Annex.Direct