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

diff --git a/Annex/Content.hs b/Annex/Content.hs
index dc60dfe1a9ac6cb6ee8fc13ca142ef9a82ba898d..2b11f1baf02a2ea352118bf0e446a12c39710ec4 100644 (file)
--- 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 8414b5b261802a5b6277682f78c7221b373d001c..26c788d566ad00e3003689c69d3ea229ebdc0df5 100644 (file)
--- 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 20838193006eaa3c5fcd9b5658121d909d692bd9..a1b1ce41120b9c545f769b81a5b066be813f51cb 100644 (file)
--- 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 0781572089f7edff767c3689831165885a67ef8a..6d655033d60f89b621bd76e65c90d8c79efe82e5 100644 (file)
--- 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 8b727c77e0162c01187e88c0a85bd500e724adef..c0bbcf544a41a9abbcd94051315ec6f1c929aeb6 100644 (file)
--- 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 980b856c087ca04be21fb2d319d3b441fd7f5f13..a7c0d60d353959b2ffda8b1d5d575d8635e39d9f 100644 (file)
--- 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