free space checking

Free space checking is now done, for transfers of data for keys that have free space metadata.
(Notably, not for SHA* keys generated with git-annex 0.24 or earlier.)

The code is believed to work on Linux, FreeBSD, and OSX; check compile-time
messages to see if it is not enabled for your OS.

Command/Migrate.hs

@@ -55,7 +55,7 @@ perform file oldkey newbackend = do
 	case stored of
 		Nothing -> return Nothing
 		Just (newkey, _) -> do
-			ok <- getViaTmp newkey $ \t -> do
+			ok <- getViaTmpUnchecked newkey $ \t -> do
 				-- Make a hard link to the old backend's
 				-- cached key, to avoid wasting disk space.
 				liftIO $ createLink src t

Command/SetKey.hs

@@ -32,7 +32,8 @@ perform :: FilePath -> CommandPerform
 perform file = do
 	key <- cmdlineKey
 	-- the file might be on a different filesystem, so mv is used
-	-- rather than simply calling moveToObjectDir
+	-- rather than simply calling moveToObjectDir; disk space is also
+	-- checked this way.
 	ok <- getViaTmp key $ \dest -> do
 		if dest /= file
 			then liftIO $

Command/Unlock.hs

@@ -41,6 +41,8 @@ perform dest key = do
 	inbackend <- Backend.hasKey key
 	when (not inbackend) $
 		error "content not present"
+	
+	checkDiskSpace key
 
 	g <- Annex.gitRepo
 	let src = gitAnnexLocation g key

Content.hs

@@ -10,6 +10,8 @@ module Content (
 	calcGitLink,
 	logStatus,
 	getViaTmp,
+	getViaTmpUnchecked,
+	checkDiskSpace,
 	preventWrite,
 	allowWrite,
 	moveAnnex,
@@ -35,6 +37,8 @@ import UUID
 import qualified GitRepo as Git
 import qualified Annex
 import Utility
+import StatFS
+import Key
 
 {- Checks if a given key is currently present in the gitAnnexLocation. -}
 inAnnex :: Key -> Annex Bool
@@ -75,6 +79,27 @@ getViaTmp :: Key -> (FilePath -> Annex Bool) -> Annex Bool
 getViaTmp key action = do
 	g <- Annex.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
+
+	getViaTmpUnchecked key action
+
+{- 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
+	g <- Annex.gitRepo
+	let tmp = gitAnnexTmpLocation g key
+
 	liftIO $ createDirectoryIfMissing True (parentDir tmp)
 	success <- action tmp
 	if success
@@ -87,6 +112,32 @@ getViaTmp key action = do
 			-- to resume its transfer
 			return False
 
+{- 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
+	liftIO $ putStrLn $ "adjust " ++ show adjustment
+	g <- Annex.gitRepo
+	stats <- liftIO $ getFileSystemStats (gitAnnexDir g)
+	case (stats, keySize key) of
+		(Nothing, _) -> return ()
+		(_, Nothing) -> return ()
+		(Just (FileSystemStats { fsStatBytesAvailable = have }), Just need) ->
+			if (need + overhead >= have + adjustment)
+				then error $ "not enough free space (have " ++ 
+					showsize (have + adjustment) ++ "; need " ++
+					showsize (need + overhead) ++ ")"
+				else return ()
+	where
+		showsize i = show i
+		-- Adding a file to the annex requires some overhead beyond
+		-- just the file size; the git index must be updated, etc. 
+		-- This is an arbitrary value.
+		overhead = 1024 * 1024 -- 1 mb
+
 {- Removes the write bits from a file. -}
 preventWrite :: FilePath -> IO ()
 preventWrite f = unsetFileMode f writebits

debian/changelog

@@ -1,3 +1,13 @@
+git-annex (0.20110321) UNRELEASED; urgency=low
+
+  * Free space checking is now done, for transfers of data for keys
+    that have free space metadata. (Notably, not for SHA* keys generated
+    with git-annex 0.24 or earlier.) The code is believed to work on
+    Linux, FreeBSD, and OSX; check compile-time messages to see if it
+    is not enabled for your OS.
+
+ -- Joey Hess <joeyh@debian.org>  Tue, 22 Mar 2011 16:52:00 -0400
+
 git-annex (0.20110320) experimental; urgency=low
 
   * Fix dropping of files using the URL backend.

doc/bugs/free_space_checking.mdwn

@@ -16,3 +16,6 @@ file around.
   find files that lack size info, and rename their keys to add the size
   info. Users with old repos can run this on them, to get the missing
   info recorded.
+
+> [[done]]; no migtation process for old SHA1 keys from v1 repo though.
+> --[[Joey]]