split out modules from Annex.Content

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,14 +715,7 @@ 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
+		( depopulatePointerFile key file
-			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
 		-- 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
@@ -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

Annex/Content/LowLevel.hs

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

Annex/Content/PointerFile.hs

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

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