split out modules from Annex.Content
This commit is contained in:
Joey Hess
parent
e9b2674281
commit
e094cf3377
4 changed files with 189 additions and 142 deletions
146
Annex/Content.hs
146
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
|
||||
|
|
|
|||
134
Annex/Content/LowLevel.hs
Normal file
134
Annex/Content/LowLevel.hs
Normal 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)"
|
||||
49
Annex/Content/PointerFile.hs
Normal file
49
Annex/Content/PointerFile.hs
Normal 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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue