From 009d7172cf29aabac762c6e8afccdb04aa3c5a49 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Sat, 4 Jan 2014 15:08:06 -0400
Subject: addurl, importfeed: Honor annex.diskreserve as long as the size of
 the url can be checked.

This adds a http HEAD before the download is done. That was already the
case when the assistant was running, and it seems worth it to avoid filling
up the whole disk, like happened to my server today.
---
 Annex/Content.hs  | 23 ++++++++++++++++++-----
 Command/AddUrl.hs | 49 ++++++++++++++++++++++---------------------------
 debian/changelog  |  2 ++
 3 files changed, 42 insertions(+), 32 deletions(-)

diff --git a/Annex/Content.hs b/Annex/Content.hs
index 62f1b1ccb..99a2f6c28 100644
--- a/Annex/Content.hs
+++ b/Annex/Content.hs
@@ -15,6 +15,7 @@ module Annex.Content (
 	getViaTmp,
 	getViaTmpChecked,
 	getViaTmpUnchecked,
+	prepGetViaTmpChecked,
 	withTmp,
 	checkDiskSpace,
 	moveAnnex,
@@ -158,20 +159,31 @@ getViaTmpUnchecked :: Key -> (FilePath -> Annex Bool) -> Annex Bool
 getViaTmpUnchecked = finishGetViaTmp (return True)
 
 getViaTmpChecked :: Annex Bool -> Key -> (FilePath -> Annex Bool) -> Annex Bool
-getViaTmpChecked check key action = do
+getViaTmpChecked check key action = 
+	prepGetViaTmpChecked key $
+		finishGetViaTmp check key action
+
+{- Prepares to download a key via a tmp file, and checks that there is
+ - enough free disk space.
+ -
+ - When the temp file already exists, count the space it is using as
+ - free, since the download will overwrite it or resume.
+ -
+ - Wen there's enough free space, runs the download action.
+ -}
+prepGetViaTmpChecked :: Key -> Annex Bool -> Annex Bool
+prepGetViaTmpChecked key getkey = do
 	tmp <- fromRepo $ gitAnnexTmpLocation 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
 	alreadythere <- if e
 		then fromIntegral . fileSize <$> liftIO (getFileStatus tmp)
 		else return 0
 	ifM (checkDiskSpace Nothing key alreadythere)
 		( do
+			-- The tmp file may not have been left writable
 			when e $ thawContent tmp
-			finishGetViaTmp check key action
+			getkey
 		, return False
 		)
 
@@ -210,6 +222,7 @@ checkDiskSpace destination key alreadythere = do
 	reserve <- annexDiskReserve <$> Annex.getGitConfig
 	free <- liftIO . getDiskFree =<< dir
 	force <- Annex.getState Annex.force
+	liftIO $ print (free, keySize key)
 	case (free, keySize key) of
 		(Just have, Just need) -> do
 			let ok = (need + reserve <= have + alreadythere) || force
diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs
index 28f6ff741..043bda3fd 100644
--- a/Command/AddUrl.hs
+++ b/Command/AddUrl.hs
@@ -28,7 +28,6 @@ import Config
 import Annex.Content.Direct
 import Logs.Location
 import qualified Logs.Transfer as Transfer
-import Utility.Daemon (checkDaemon)
 #ifdef WITH_QUVI
 import Annex.Quvi
 import qualified Utility.Quvi as Quvi
@@ -153,44 +152,40 @@ addUrlFile relaxed url file = do
 download :: URLString -> FilePath -> Annex Bool
 download url file = do
 	dummykey <- genkey
-	tmp <- fromRepo $ gitAnnexTmpLocation dummykey
-	showOutput
-	ifM (runtransfer dummykey tmp)
-		( do
-			backend <- chooseBackend file
-			let source = KeySource
-				{ keyFilename = file
-				, contentLocation = tmp
-				, inodeCache = Nothing
-				}
-			k <- genKey source backend
-			case k of
-				Nothing -> return False
-				Just (key, _) -> cleanup url file key (Just tmp)
-		, return False
-		)
+	prepGetViaTmpChecked dummykey $ do
+		tmp <- fromRepo $ gitAnnexTmpLocation dummykey
+		showOutput
+		ifM (runtransfer dummykey tmp)
+			( do
+				backend <- chooseBackend file
+				let source = KeySource
+					{ keyFilename = file
+					, contentLocation = tmp
+					, inodeCache = Nothing
+					}
+				k <- genKey source backend
+				case k of
+					Nothing -> return False
+					Just (key, _) -> cleanup url file key (Just tmp)
+			, return False
+			)
   where
 	{- Generate a dummy key to use for this download, before we can
 	 - examine the file and find its real key. This allows resuming
 	 - downloads, as the dummy key for a given url is stable.
 	 -
-	 - If the assistant is running, actually hits the url here,
-	 - to get the size, so it can display a pretty progress bar.
+	 - Actually hits the url here, to get the size. This is needed to
+	 - avoid exceeding the diskreserve, and so the assistant can 
+	 - display a pretty progress bar.
 	 -}
 	genkey = do
-		pidfile <- fromRepo gitAnnexPidFile
-		size <- ifM (liftIO $ isJust <$> checkDaemon pidfile)
-			( do
-				headers <- getHttpHeaders
-				snd <$> Url.withUserAgent (Url.exists url headers)
-			, return Nothing
-			)
+		headers <- getHttpHeaders
+		size <- snd <$> Url.withUserAgent (Url.exists url headers)
 		Backend.URL.fromUrl url size
   	runtransfer dummykey tmp = 
 		Transfer.download webUUID dummykey (Just file) Transfer.forwardRetry $ const $ do
 			liftIO $ createDirectoryIfMissing True (parentDir tmp)
 			downloadUrl [url] tmp
-		
 
 cleanup :: URLString -> FilePath -> Key -> Maybe FilePath -> Annex Bool
 cleanup url file key mtmp = do
diff --git a/debian/changelog b/debian/changelog
index bd5b459bc..28a11900b 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -15,6 +15,8 @@ git-annex (5.20131231) UNRELEASED; urgency=medium
   * assistant: Ensure that .ssh/config and .ssh/authorized_keys are not
     group or world writable when writing to those files, as that can make
     ssh refuse to use them, if it allows another user to write to them.
+  * addurl, importfeed: Honor annex.diskreserve as long as the size of the
+    url can be checked.
 
  -- Joey Hess <joeyh@debian.org>  Tue, 31 Dec 2013 13:41:18 -0400
 
-- 
cgit v1.2.3