From 7ca8bf3321d1b62ea4e817e28914ed2fa56afe30 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Tue, 12 May 2015 15:50:03 -0400
Subject: 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.
---
 Annex/Transfer.hs | 32 +++++++++++++++++++++-----------
 1 file changed, 21 insertions(+), 11 deletions(-)

(limited to 'Annex/Transfer.hs')

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
-- 
cgit v1.2.3