diff options
| -rw-r--r-- | Annex/Content.hs | 31 | ||||
| -rw-r--r-- | Command/Fsck.hs | 2 | ||||
| -rw-r--r-- | Command/Unlock.hs | 2 | ||||
| -rw-r--r-- | Logs/Transfer.hs | 20 | ||||
| -rw-r--r-- | Remote/Directory.hs | 11 | ||||
| -rw-r--r-- | debian/changelog | 2 |
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 |