split out modules from Annex.Content

This commit is contained in:
Joey Hess 2018-08-22 14:41:09 -04:00
parent e9b2674281
commit e094cf3377
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
4 changed files with 189 additions and 142 deletions

View file

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

134
Annex/Content/LowLevel.hs Normal file
View file

@ -0,0 +1,134 @@
{- git-annex low-level content functions
-
- Copyright 2010-2018 Joey Hess <id@joeyh.name>
-
- 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)"

View file

@ -0,0 +1,49 @@
{- git-annex pointer files
-
- Copyright 2010-2018 Joey Hess <id@joeyh.name>
-
- 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

View file

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