Take space that will be used by running downloads into account when checking annex.diskreserve.

6 files changed, 55 insertions, 13 deletions

diff --git a/Annex/Content.hs b/Annex/Content.hs
index dc60dfe1a..2b11f1baf 100644
--- a/Annex/Content.hs
+++ b/Annex/Content.hs
@@ -41,6 +41,7 @@ import System.IO.Unsafe (unsafeInterleaveIO)
 
 import Common.Annex
 import Logs.Location
+import Logs.Transfer
 import qualified Git
 import qualified Annex
 import qualified Annex.Queue
@@ -239,7 +240,7 @@ prepGetViaTmpChecked key unabletoget getkey = do
 	alreadythere <- liftIO $ if e
 		then getFileSize tmp
 		else return 0
-	ifM (checkDiskSpace Nothing key alreadythere)
+	ifM (checkDiskSpace Nothing key alreadythere True)
 		( do
 			-- The tmp file may not have been left writable
 			when e $ thawContent tmp
@@ -278,18 +279,34 @@ withTmp key action = do
 	return res
 
 {- Checks that there is disk space available to store a given key,
- - in a destination (or the annex) printing a warning if not. -}
-checkDiskSpace :: Maybe FilePath -> Key -> Integer -> Annex Bool
-checkDiskSpace destination key alreadythere = ifM (Annex.getState Annex.force)
+ - in a destination (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 destination key alreadythere samefilesystem = ifM (Annex.getState Annex.force)
 	( return True
 	, do
-		reserve <- annexDiskReserve <$> Annex.getGitConfig
+		-- 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
 		free <- liftIO . getDiskFree =<< dir
 		case (free, fromMaybe 1 (keySize key)) of
 			(Just have, need) -> do
-				let ok = (need + reserve <= have + alreadythere)
+				reserve <- annexDiskReserve <$> Annex.getGitConfig
+				let delta = need + reserve - have - alreadythere + inprogress
+				let ok = delta <= 0
 				unless ok $
-					needmorespace (need + reserve - have - alreadythere)
+					needmorespace delta
 				return ok
 			_ -> return True
 	)
diff --git a/Command/Fsck.hs b/Command/Fsck.hs
index 8414b5b26..26c788d56 100644
--- a/Command/Fsck.hs
+++ b/Command/Fsck.hs
@@ -135,7 +135,7 @@ performRemote key file backend numcopies remote =
 		let cleanup = liftIO $ catchIO (removeFile tmp) (const noop)
 		cleanup
 		cleanup `after` a tmp
-	getfile tmp = ifM (checkDiskSpace (Just tmp) key 0)
+	getfile tmp = ifM (checkDiskSpace (Just tmp) key 0 True)
 		( ifM (Remote.retrieveKeyFileCheap remote key (Just file) tmp)
 			( return (Just True)
 			, ifM (Annex.getState Annex.fast)
diff --git a/Command/Unlock.hs b/Command/Unlock.hs
index 208381930..a1b1ce411 100644
--- a/Command/Unlock.hs
+++ b/Command/Unlock.hs
@@ -43,7 +43,7 @@ start file key = do
 		)
 
 perform :: FilePath -> Key -> CommandPerform
-perform dest key = ifM (checkDiskSpace Nothing key 0)
+perform dest key = ifM (checkDiskSpace Nothing key 0 True)
 	( do
 		src <- calcRepo $ gitAnnexLocation key
 		tmpdest <- fromRepo $ gitAnnexTmpObjectLocation key
diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs
index 078157208..6d655033d 100644
--- a/Logs/Transfer.hs
+++ b/Logs/Transfer.hs
@@ -147,16 +147,32 @@ checkTransfer t = do
 
 {- Gets all currently running transfers. -}
 getTransfers :: Annex [(Transfer, TransferInfo)]
-getTransfers = do
+getTransfers = getTransfers' [Download, Upload]
+
+getTransfers' :: [Direction] -> Annex [(Transfer, TransferInfo)]
+getTransfers' dirs = do
 	transfers <- mapMaybe parseTransferFile . concat <$> findfiles
 	infos <- mapM checkTransfer transfers
 	return $ map (\(t, Just i) -> (t, i)) $
 		filter running $ zip transfers infos
   where
 	findfiles = liftIO . mapM dirContentsRecursive
-		=<< mapM (fromRepo . transferDir) [Download, Upload]
+		=<< mapM (fromRepo . transferDir) dirs
 	running (_, i) = isJust i
 
+{- Number of bytes remaining to download from matching downloads that are in
+ - progress. -}
+sizeOfDownloadsInProgress :: (Key -> Bool) -> Annex Integer
+sizeOfDownloadsInProgress match = sum . map remaining . filter wanted
+	<$> getTransfers' [Download]
+  where
+	wanted (t, _) = match (transferKey t)
+	remaining (t, info) =
+		case (keySize (transferKey t), bytesComplete info) of
+			(Just sz, Just done) -> sz - done
+			(Just sz, Nothing) -> sz
+			(Nothing, _) -> 0
+
 {- Gets failed transfers for a given remote UUID. -}
 getFailedTransfers :: UUID -> Annex [(Transfer, TransferInfo)]
 getFailedTransfers u = catMaybes <$> (liftIO . getpairs =<< concat <$> findfiles)
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index 8b727c77e..c0bbcf544 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -118,9 +118,16 @@ tmpDir d k = addTrailingPathSeparator $ d </> "tmp" </> keyFile k
 {- Check if there is enough free disk space in the remote's directory to
  - store the key. Note that the unencrypted key size is checked. -}
 prepareStore :: FilePath -> ChunkConfig -> Preparer Storer
-prepareStore d chunkconfig = checkPrepare
-	(\k -> checkDiskSpace (Just d) k 0)
+prepareStore d chunkconfig = checkPrepare checker
 	(byteStorer $ store d chunkconfig)
+  where
+	checker k = do
+		annexdir <- fromRepo gitAnnexObjectDir
+		samefilesystem <- liftIO $ catchDefaultIO False $ 
+			(\a b -> deviceID a == deviceID b)
+				<$> getFileStatus d
+				<*> getFileStatus annexdir
+		checkDiskSpace (Just d) k 0 samefilesystem
 
 store :: FilePath -> ChunkConfig -> Key -> L.ByteString -> MeterUpdate -> Annex Bool
 store d chunkconfig k b p = liftIO $ do
diff --git a/debian/changelog b/debian/changelog
index 980b856c0..a7c0d60d3 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -10,6 +10,8 @@ git-annex (5.20150508.2) UNRELEASED; urgency=medium
     However, progress bars are not yet displayed for concurrent transfers,
     pending an updated version of the ascii-progress library.
   * --quiet now makes progress output by rsync, wget, etc be quiet too.
+  * Take space that will be used by running downloads into account when
+    checking annex.diskreserve.
 
  -- Joey Hess <id@joeyh.name>  Mon, 11 May 2015 12:45:06 -0400