make the assistant retry failed transfers

When a transfer fails, the progress info can be used to intelligently
retry it. If the transfer managed to make some progress, but did not
fully complete, then there's a good chance that a retry will finish it
(or at least make more progress).

6 files changed, 37 insertions, 17 deletions

diff --git a/Command/Get.hs b/Command/Get.hs
index 18153ce88..ab0e60b41 100644
--- a/Command/Get.hs
+++ b/Command/Get.hs
@@ -66,7 +66,7 @@ getKeyFile key file dest = dispatch =<< Remote.keyPossibilities key
 				either (const False) id <$> Remote.hasKey r key
 			| otherwise = return True
 		docopy r continue = do
-			ok <- download (Remote.uuid r) key (Just file) $ do
+			ok <- download (Remote.uuid r) key (Just file) noRetry $ do
 				showAction $ "from " ++ Remote.name r
 				Remote.retrieveKeyFile r key (Just file) dest
 			if ok then return ok else continue
diff --git a/Command/Move.hs b/Command/Move.hs
index 7955cecd3..36242f45c 100644
--- a/Command/Move.hs
+++ b/Command/Move.hs
@@ -89,7 +89,7 @@ toPerform dest move key file = moveLock move key $ do
 			stop
 		Right False -> do
 			showAction $ "to " ++ Remote.name dest
-			ok <- upload (Remote.uuid dest) key (Just file) $
+			ok <- upload (Remote.uuid dest) key (Just file) noRetry $
 				Remote.storeKey dest key (Just file)
 			if ok
 				then finish
@@ -138,7 +138,7 @@ fromPerform src move key file = moveLock move key $
 		, handle move =<< go
 		)
 	where
-		go = download (Remote.uuid src) key (Just file) $ do
+		go = download (Remote.uuid src) key (Just file) noRetry $ do
 			showAction $ "from " ++ Remote.name src
 			getViaTmp key $ Remote.retrieveKeyFile src key (Just file)
 		handle _ False = stop -- failed
diff --git a/Command/SendKey.hs b/Command/SendKey.hs
index e5d4c7e6e..2aae1ab90 100644
--- a/Command/SendKey.hs
+++ b/Command/SendKey.hs
@@ -24,7 +24,7 @@ seek = [withKeys start]
 
 start :: Key -> CommandStart
 start key = ifM (inAnnex key)
-	( fieldTransfer Upload key $ \p -> do
+	( fieldTransfer Upload key $ \_p -> do
 		file <- inRepo $ gitAnnexLocation key
 		liftIO $ rsyncServerSend file
 	, do
@@ -36,7 +36,7 @@ fieldTransfer :: Direction -> Key -> (MeterUpdate -> Annex Bool) -> CommandStart
 fieldTransfer direction key a = do
 	afile <- Fields.getField Fields.associatedFile
 	ok <- maybe (a $ const noop)
-		(\u -> runTransfer (Transfer direction (toUUID u) key) afile a)
+		(\u -> runTransfer (Transfer direction (toUUID u) key) afile noRetry a)
 		=<< Fields.getField Fields.remoteUUID
 	if ok
 		then liftIO exitSuccess
diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs
index 793dbeb56..a308e0175 100644
--- a/Command/TransferKey.hs
+++ b/Command/TransferKey.hs
@@ -43,7 +43,7 @@ start to from file key =
 
 toPerform :: Remote -> Key -> AssociatedFile -> CommandPerform
 toPerform remote key file = next $
-	upload (uuid remote) key file $ \p -> do
+	upload (uuid remote) key file forwardRetry $ \p -> do
 		ok <- Remote.storeKey remote key file p
 		when ok $
 			Remote.logStatus remote key InfoPresent
@@ -51,5 +51,5 @@ toPerform remote key file = next $
 
 fromPerform :: Remote -> Key -> AssociatedFile -> CommandPerform
 fromPerform remote key file = next $
-	download (uuid remote) key file $
+	download (uuid remote) key file forwardRetry $
 		getViaTmp key $ Remote.retrieveKeyFile remote key file
diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs
index 7188143d6..016571d23 100644
--- a/Logs/Transfer.hs
+++ b/Logs/Transfer.hs
@@ -74,11 +74,21 @@ percentComplete :: Transfer -> TransferInfo -> Maybe Percentage
 percentComplete (Transfer { transferKey = key }) info =
 	percentage <$> keySize key <*> Just (fromMaybe 0 $ bytesComplete info)
 
-upload :: UUID -> Key -> AssociatedFile -> (MeterUpdate -> Annex Bool) -> Annex Bool
-upload u key file a = runTransfer (Transfer Upload u key) file a
+type RetryDecider = TransferInfo -> TransferInfo -> Bool
 
-download :: UUID -> Key -> AssociatedFile -> Annex Bool -> Annex Bool
-download u key file a = runTransfer (Transfer Download u key) file (const a)
+noRetry :: RetryDecider
+noRetry _ _ = False
+
+{- Retries a transfer when it fails, as long as the failed transfer managed
+ - to send some data. -}
+forwardRetry :: RetryDecider
+forwardRetry old new = bytesComplete old < bytesComplete new
+
+upload :: UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex Bool) -> Annex Bool
+upload u key = runTransfer (Transfer Upload u key)
+
+download :: UUID -> Key -> AssociatedFile -> RetryDecider -> Annex Bool -> Annex Bool
+download u key file shouldretry a = runTransfer (Transfer Download u key) file shouldretry (const a)
 
 {- Runs a transfer action. Creates and locks the lock file while the
  - action is running, and stores info in the transfer information
@@ -87,12 +97,12 @@ download u key file a = runTransfer (Transfer Download u key) file (const a)
  - If the transfer action returns False, the transfer info is 
  - left in the failedTransferDir.
  -}
-runTransfer :: Transfer -> Maybe FilePath -> (MeterUpdate -> Annex Bool) -> Annex Bool
-runTransfer t file a = do
+runTransfer :: Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex Bool) -> Annex Bool
+runTransfer t file shouldretry a = do
 	info <- liftIO $ startTransferInfo file
 	(meter, tfile) <- mkProgressUpdater t info
 	mode <- annexFileMode
-	ok <- bracketIO (prep tfile mode info) (cleanup tfile) (a meter)
+	ok <- retry tfile info $ bracketIO (prep tfile mode info) (cleanup tfile) (a meter)
 	unless ok $ failed info
 	return ok
 	where
@@ -113,7 +123,17 @@ runTransfer t file a = do
 			failedtfile <- fromRepo $ failedTransferFile t
 			createAnnexDirectory $ takeDirectory failedtfile
 			liftIO $ writeTransferInfoFile info failedtfile
-
+		retry tfile oldinfo run = do
+			ok <- run
+			if ok
+				then return ok
+				else do
+					v <- liftIO $ readTransferInfoFile Nothing tfile
+					case v of
+						Nothing -> return ok
+						Just newinfo -> if shouldretry oldinfo newinfo
+							then retry tfile newinfo run
+							else return ok
 
 {- Generates a callback that can be called as transfer progresses to update
  - the transfer info file. Also returns the file it'll be updating. -}
diff --git a/Remote/Git.hs b/Remote/Git.hs
index a1c5b24b4..e7b1ca0e8 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -247,7 +247,7 @@ copyFromRemote r key file dest
 		liftIO $ onLocal r $ do
 			ensureInitialized
 			loc <- inRepo $ gitAnnexLocation key
-			upload u key file $
+			upload u key file noRetry $
 				rsyncOrCopyFile params loc dest
 	| Git.repoIsSsh r = feedprogressback $ \feeder -> 
 		rsyncHelper (Just feeder) 
@@ -317,7 +317,7 @@ copyToRemote r key file p
 			( return False
 			, do
 				ensureInitialized
-				download u key file $
+				download u key file noRetry $
 					Annex.Content.saveState True `after`
 						Annex.Content.getViaTmp key
 							(\d -> rsyncOrCopyFile params keysrc d p)