Avoid accumulating transfer failure log files unless the assistant is being used.

Only the assistant uses these, and only the assistant cleans them up, so
make only git annex transferkeys write them,

There is one behavior change from this. If glacier is being used, and a
manual git annex get --from glacier fails because the file isn't available
yet, the assistant will no longer later see that failed transfer file and
retry the get. Hope no-one depended on that old behavior.

9 files changed, 38 insertions, 23 deletions

diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs
index 2723b2351..cf04810da 100644
--- a/Annex/Transfer.hs
+++ b/Annex/Transfer.hs
@@ -9,6 +9,7 @@
 
 module Annex.Transfer (
 	module X,
+	noObserver,
 	upload,
 	download,
 	runTransfer,
@@ -28,11 +29,18 @@ import Utility.LockFile
 
 import Control.Concurrent
 
-upload :: UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex Bool) -> NotifyWitness -> Annex Bool
-upload u key f d a _witness = runTransfer (Transfer Upload u key) f d a
+type TransferAction = MeterUpdate -> Annex Bool
 
-download :: UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex Bool) -> NotifyWitness -> Annex Bool
-download u key f d a _witness = runTransfer (Transfer Download u key) f d a
+type TransferObserver = Bool -> Transfer -> TransferInfo -> Annex ()
+
+noObserver :: TransferObserver
+noObserver _ _ _ = noop
+
+upload :: UUID -> Key -> AssociatedFile -> RetryDecider -> TransferObserver -> TransferAction -> NotifyWitness -> Annex Bool
+upload u key f d o a _witness = runTransfer (Transfer Upload u key) f d o a
+
+download :: UUID -> Key -> AssociatedFile -> RetryDecider -> TransferObserver -> TransferAction -> NotifyWitness -> Annex Bool
+download u key f d o a _witness = runTransfer (Transfer Download u key) f d o a
 
 {- Runs a transfer action. Creates and locks the lock file while the
  - action is running, and stores info in the transfer information
@@ -46,7 +54,7 @@ download u key f d a _witness = runTransfer (Transfer Download u key) f d a
  - An upload can be run from a read-only filesystem, and in this case
  - no transfer information or lock file is used.
  -}
-runTransfer :: Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex Bool) -> Annex Bool
+runTransfer :: Transfer -> Maybe FilePath -> RetryDecider -> TransferObserver -> TransferAction -> Annex Bool
 runTransfer = runTransfer' False
 
 {- Like runTransfer, but ignores any existing transfer lock file for the
@@ -54,11 +62,11 @@ runTransfer = runTransfer' False
  -
  - Note that this may result in confusing progress meter display in the
  - webapp, if multiple processes are writing to the transfer info file. -}
-alwaysRunTransfer :: Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex Bool) -> Annex Bool
+alwaysRunTransfer :: Transfer -> Maybe FilePath -> RetryDecider -> TransferObserver -> TransferAction -> Annex Bool
 alwaysRunTransfer = runTransfer' True
 
-runTransfer' :: Bool -> Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex Bool) -> Annex Bool
-runTransfer' ignorelock t file shouldretry a = do
+runTransfer' :: Bool -> Transfer -> Maybe FilePath -> RetryDecider -> TransferObserver -> TransferAction -> Annex Bool
+runTransfer' ignorelock t file shouldretry transferobserver transferaction = do
 	info <- liftIO $ startTransferInfo file
 	(meter, tfile, metervar) <- mkProgressUpdater t info
 	mode <- annexFileMode
@@ -68,9 +76,11 @@ runTransfer' ignorelock t file shouldretry a = do
 			showNote "transfer already in progress"
 			return False
 		else do
-			ok <- retry info metervar $
-				bracketIO (return fd) (cleanup tfile) (const $ a meter)
-			unless ok $ recordFailedTransfer t info
+			ok <- retry info metervar $ bracketIO 
+				(return fd)
+				(cleanup tfile)
+				(const $ transferaction meter)
+			transferobserver ok t info
 			return ok
   where
 #ifndef mingw32_HOST_OS
diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs
index 6474f2614..96a966e8d 100644
--- a/Command/AddUrl.hs
+++ b/Command/AddUrl.hs
@@ -223,7 +223,7 @@ addUrlFileQuvi relaxed quviurl videourl file = do
 				tmp <- fromRepo $ gitAnnexTmpObjectLocation key
 				showOutput
 				ok <- Transfer.notifyTransfer Transfer.Download (Just file) $
-					Transfer.download webUUID key (Just file) Transfer.forwardRetry $ const $ do
+					Transfer.download webUUID key (Just file) Transfer.forwardRetry Transfer.noObserver $ const $ do
 						liftIO $ createDirectoryIfMissing True (parentDir tmp)
 						downloadUrl [videourl] tmp
 				if ok
@@ -297,7 +297,7 @@ downloadWith downloader dummykey u url file =
 			)
   where
 	runtransfer tmp =  Transfer.notifyTransfer Transfer.Download (Just file) $
-		Transfer.download u dummykey (Just file) Transfer.forwardRetry $ \p -> do
+		Transfer.download u dummykey (Just file) Transfer.forwardRetry Transfer.noObserver $ \p -> do
 			liftIO $ createDirectoryIfMissing True (parentDir tmp)
 			downloader tmp p
 
diff --git a/Command/Get.hs b/Command/Get.hs
index 380a68097..dcd7e367a 100644
--- a/Command/Get.hs
+++ b/Command/Get.hs
@@ -90,6 +90,6 @@ getKeyFile' key afile dest = dispatch
 		| Remote.hasKeyCheap r =
 			either (const False) id <$> Remote.hasKey r key
 		| otherwise = return True
-	docopy r = download (Remote.uuid r) key afile noRetry $ \p -> do
+	docopy r = download (Remote.uuid r) key afile noRetry noObserver $ \p -> do
 		showAction $ "from " ++ Remote.name r
 		Remote.retrieveKeyFile r key afile dest p
diff --git a/Command/Move.hs b/Command/Move.hs
index 91f7c8ea7..6867052de 100644
--- a/Command/Move.hs
+++ b/Command/Move.hs
@@ -95,7 +95,7 @@ toPerform dest move key afile fastcheck isthere =
 		Right False -> do
 			showAction $ "to " ++ Remote.name dest
 			ok <- notifyTransfer Upload afile $
-				upload (Remote.uuid dest) key afile noRetry $
+				upload (Remote.uuid dest) key afile noRetry noObserver $
 					Remote.storeKey dest key afile
 			if ok
 				then do
@@ -152,7 +152,7 @@ fromPerform src move key afile = ifM (inAnnex key)
 	)
   where
 	go = notifyTransfer Download afile $ 
-		download (Remote.uuid src) key afile noRetry $ \p -> do
+		download (Remote.uuid src) key afile noRetry noObserver $ \p -> do
 			showAction $ "from " ++ Remote.name src
 			getViaTmp key $ \t -> Remote.retrieveKeyFile src key afile t p
 	dispatch _ False = stop -- failed
diff --git a/Command/SendKey.hs b/Command/SendKey.hs
index 62b4edcba..011785582 100644
--- a/Command/SendKey.hs
+++ b/Command/SendKey.hs
@@ -44,7 +44,7 @@ fieldTransfer :: Direction -> Key -> (MeterUpdate -> Annex Bool) -> CommandStart
 fieldTransfer direction key a = do
 	afile <- Fields.getField Fields.associatedFile
 	ok <- maybe (a $ const noop)
-		(\u -> runner (Transfer direction (toUUID u) key) afile noRetry a)
+		(\u -> runner (Transfer direction (toUUID u) key) afile noRetry noObserver a)
 		=<< Fields.getField Fields.remoteUUID
 	liftIO $ exitBool ok
   where
diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs
index 55d6b95a1..14e788893 100644
--- a/Command/TransferKey.hs
+++ b/Command/TransferKey.hs
@@ -42,7 +42,7 @@ start to from file key =
 
 toPerform :: Remote -> Key -> AssociatedFile -> CommandPerform
 toPerform remote key file = go Upload file $
-	upload (uuid remote) key file forwardRetry $ \p -> do
+	upload (uuid remote) key file forwardRetry noObserver $ \p -> do
 		ok <- Remote.storeKey remote key file p
 		when ok $
 			Remote.logStatus remote key InfoPresent
@@ -50,7 +50,7 @@ toPerform remote key file = go Upload file $
 
 fromPerform :: Remote -> Key -> AssociatedFile -> CommandPerform
 fromPerform remote key file = go Upload file $
-	download (uuid remote) key file forwardRetry $ \p ->
+	download (uuid remote) key file forwardRetry noObserver $ \p ->
 		getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p
 
 go :: Direction -> AssociatedFile -> (NotifyWitness -> Annex Bool) -> CommandPerform
diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs
index b787fe9be..d490d9be4 100644
--- a/Command/TransferKeys.hs
+++ b/Command/TransferKeys.hs
@@ -36,14 +36,17 @@ start = do
   where
 	runner (TransferRequest direction remote key file)
 		| direction == Upload = notifyTransfer direction file $
-			upload (Remote.uuid remote) key file forwardRetry $ \p -> do
+			upload (Remote.uuid remote) key file forwardRetry observer $ \p -> do
 				ok <- Remote.storeKey remote key file p
 				when ok $
 					Remote.logStatus remote key InfoPresent
 				return ok
 		| otherwise = notifyTransfer direction file $
-			download (Remote.uuid remote) key file forwardRetry $ \p ->
+			download (Remote.uuid remote) key file forwardRetry observer $ \p ->
 				getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p
+	
+	observer False t info = recordFailedTransfer t info
+	observer True _ _ = noop
 
 runRequests
 	:: Handle
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 170c6fbf6..5ac79df6d 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -386,7 +386,7 @@ copyFromRemote' r key file dest meterupdate
 					let go = copier
 #endif
 					runTransfer (Transfer Download u key)
-						file noRetry go
+						file noRetry noObserver go
 						<&&> checksuccess
 	| Git.repoIsSsh (repo r) = feedprogressback $ \feeder -> do
 		direct <- isDirect
@@ -502,7 +502,7 @@ copyToRemote' r key file p
 			( return True
 			, do
 				ensureInitialized
-				runTransfer (Transfer Download u key) file noRetry $ const $
+				runTransfer (Transfer Download u key) file noRetry noObserver $ const $
 					Annex.Content.saveState True `after`
 						Annex.Content.getViaTmpChecked (liftIO checksuccessio) key
 							(\d -> rsyncOrCopyFile params object d p)
diff --git a/debian/changelog b/debian/changelog
index a7c0d60d3..ef62eaf25 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -12,6 +12,8 @@ git-annex (5.20150508.2) UNRELEASED; urgency=medium
   * --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.
+  * Avoid accumulating transfer failure log files unless the assistant is
+    being used.
 
  -- Joey Hess <id@joeyh.name>  Mon, 11 May 2015 12:45:06 -0400