implement annex.retry et al

Added annex.retry, annex.retry-delay, and per-remote versions to configure
transfer retries.

This commit was supported by the NSF-funded DataLad project.

Annex/Transfer.hs

@@ -1,6 +1,6 @@
 {- git-annex transfers
  -
- - Copyright 2012-2017 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2018 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -14,7 +14,7 @@ module Annex.Transfer (
 	runTransfer,
 	alwaysRunTransfer,
 	noRetry,
-	forwardRetry,
+	stdRetry,
 	pickRemote,
 ) where
 
@@ -25,6 +25,7 @@ import Types.Transfer as X
 import Annex.Notification as X
 import Annex.Perms
 import Utility.Metered
+import Utility.ThreadScheduler
 import Annex.LockPool
 import Types.Key
 import qualified Types.Remote as Remote
@@ -71,7 +72,8 @@ alwaysRunTransfer :: Observable v => Transfer -> AssociatedFile -> RetryDecider
 alwaysRunTransfer = runTransfer' True
 
 runTransfer' :: Observable v => Bool -> Transfer -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v
-runTransfer' ignorelock t afile shouldretry transferaction = checkSecureHashes t $ do
+runTransfer' ignorelock t afile retrydecider transferaction = checkSecureHashes t $ do
+	shouldretry <- retrydecider
 	info <- liftIO $ startTransferInfo afile
 	(meter, tfile, createtfile, metervar) <- mkProgressUpdater t info
 	mode <- annexFileMode
@@ -81,7 +83,7 @@ runTransfer' ignorelock t afile shouldretry transferaction = checkSecureHashes t
 			showNote "transfer already in progress, or unable to take transfer lock"
 			return observeFailure
 		else do
-			v <- retry info metervar $ transferaction meter
+			v <- retry shouldretry info metervar $ transferaction meter
 			liftIO $ cleanup tfile lck
 			if observeBool v
 				then removeFailedTransfer t
@@ -132,15 +134,16 @@ runTransfer' ignorelock t afile shouldretry transferaction = checkSecureHashes t
 		dropLock lockhandle
 		void $ tryIO $ removeFile lck
 #endif
-	retry oldinfo metervar run = tryNonAsync run >>= \case
+	retry shouldretry oldinfo metervar run = tryNonAsync run >>= \case
 		Right b -> return b
 		Left e -> do
 			warning (show e)
 			b <- getbytescomplete metervar
 			let newinfo = oldinfo { bytesComplete = Just b }
-			if shouldretry oldinfo newinfo
-				then retry newinfo metervar run
-				else return observeFailure
+			ifM (shouldretry oldinfo newinfo)
+				( retry shouldretry newinfo metervar run
+				, return observeFailure
+				)
 	getbytescomplete metervar
 		| transferDirection t == Upload =
 			liftIO $ readMVar metervar
@@ -172,15 +175,53 @@ checkSecureHashes t a
   where
 	variety = keyVariety (transferKey t)
 
-type RetryDecider = TransferInfo -> TransferInfo -> Bool
+type RetryDecider = Annex (TransferInfo -> TransferInfo -> Annex Bool)
+
+{- The first RetryDecider will be checked first; only if it says not to
+ - retry will the second one be checked. -}
+combineRetryDeciders :: RetryDecider -> RetryDecider -> RetryDecider
+combineRetryDeciders a b = do
+	ar <- a
+	br <- b
+	return $ \old new -> ar old new <||> br old new
 
 noRetry :: RetryDecider
-noRetry _ _ = False
+noRetry = pure $ \_ _ -> pure False
+
+stdRetry :: RetryDecider
+stdRetry = combineRetryDeciders forwardRetry configuredRetry
 
 {- 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
+forwardRetry = pure $ \old new -> pure $ bytesComplete old < bytesComplete new
+
+{- Retries a number of times with growing delays in between when enabled
+ - by git configuration. -}
+configuredRetry :: RetryDecider
+configuredRetry = do
+	retrycounter <- liftIO $ newMVar 0
+	return $ \_old new -> do
+		(maxretries, Seconds initretrydelay) <- getcfg $ 
+			Remote.gitconfig <$> transferRemote new
+		retries <- liftIO $ modifyMVar retrycounter $
+			\n -> return (n + 1, n + 1)
+		if retries < maxretries
+			then do
+				let retrydelay = Seconds (initretrydelay * 2^(retries-1))
+				showSideAction $ "Delaying " ++ show (fromSeconds retrydelay) ++ " before retrying."
+				liftIO $ threadDelaySeconds retrydelay
+				return True
+			else return False
+  where
+	globalretrycfg = fromMaybe 0 . annexRetry
+		<$> Annex.getGitConfig
+	globalretrydelaycfg = fromMaybe (Seconds 1) . annexRetryDelay
+		<$> Annex.getGitConfig
+	getcfg Nothing = (,) <$> globalretrycfg <*> globalretrydelaycfg
+	getcfg (Just gc) = (,)
+		<$> maybe globalretrycfg return (remoteAnnexRetry gc)
+		<*> maybe globalretrydelaycfg return (remoteAnnexRetryDelay gc)
 
 {- Picks a remote from the list and tries a transfer to it. If the transfer
  - does not succeed, goes on to try other remotes from the list.

CHANGELOG

@@ -4,6 +4,8 @@ git-annex (6.20180317) UNRELEASED; urgency=medium
   * Fix calculation of estimated completion for progress meter.
   * OSX app: Work around libz/libPng/ImageIO.framework version skew
     by not bundling libz, assuming OSX includes a suitable libz.1.dylib.
+  * Added annex.retry, annex.retry-delay, and per-remote versions
+    to configure transfer retries.
 
  -- Joey Hess <id@joeyh.name>  Mon, 19 Mar 2018 23:13:59 -0400
 

Command/AddUrl.hs

@@ -339,7 +339,7 @@ downloadWith' downloader dummykey u url afile =
 	checkDiskSpaceToGet dummykey Nothing $ do
 		tmp <- fromRepo $ gitAnnexTmpObjectLocation dummykey
 		ok <- Transfer.notifyTransfer Transfer.Download url $
-			Transfer.download u dummykey afile Transfer.forwardRetry $ \p -> do
+			Transfer.download u dummykey afile Transfer.stdRetry $ \p -> do
 				liftIO $ createDirectoryIfMissing True (parentDir tmp)
 				downloader tmp p
 		if ok

Command/Export.hs

@@ -216,6 +216,8 @@ performExport r ea db ek af contentsha loc = do
 	sent <- case ek of
 		AnnexKey k -> ifM (inAnnex k)
 			( notifyTransfer Upload af $
+				-- Using noRetry here because interrupted
+				-- exports cannot be resumed.
 				upload (uuid r) k af noRetry $ \pm -> do
 					let rollback = void $
 						performUnexport r ea db [ek] loc

Command/Get.hs

@@ -110,7 +110,7 @@ getKey' key afile = dispatch
 			either (const False) id <$> Remote.hasKey r key
 		| otherwise = return True
 	docopy r witness = getViaTmp (RemoteVerify r) key $ \dest ->
-		download (Remote.uuid r) key afile forwardRetry
+		download (Remote.uuid r) key afile stdRetry
 			(\p -> do
 				showAction $ "from " ++ Remote.name r
 				Remote.retrieveKeyFile r key afile dest p

Command/Move.hs

@@ -134,7 +134,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 forwardRetry $
+				upload (Remote.uuid dest) key afile stdRetry $
 					Remote.storeKey dest key afile
 			if ok
 				then finish $
@@ -199,7 +199,7 @@ fromPerform src move key afile = do
 		)
   where
 	go = notifyTransfer Download afile $ 
-		download (Remote.uuid src) key afile forwardRetry $ \p ->
+		download (Remote.uuid src) key afile stdRetry $ \p ->
 			getViaTmp (RemoteVerify src) key $ \t ->
 				Remote.retrieveKeyFile src key afile t p
 	dispatch _ False = stop -- failed

Command/TransferKey.hs

@@ -51,7 +51,7 @@ start o key = case fromToOptions o of
 
 toPerform :: Key -> AssociatedFile -> Remote -> CommandPerform
 toPerform key file remote = go Upload file $
-	upload (uuid remote) key file forwardRetry $ \p -> do
+	upload (uuid remote) key file stdRetry $ \p -> do
 		ok <- Remote.storeKey remote key file p
 		when ok $
 			Remote.logStatus remote key InfoPresent
@@ -59,7 +59,7 @@ toPerform key file remote = go Upload file $
 
 fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform
 fromPerform key file remote = go Upload file $
-	download (uuid remote) key file forwardRetry $ \p ->
+	download (uuid remote) key file stdRetry $ \p ->
 		getViaTmp (RemoteVerify remote) key $ 
 			\t -> Remote.retrieveKeyFile remote key file t p
 

Command/TransferKeys.hs

@@ -35,13 +35,13 @@ 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 stdRetry $ \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 stdRetry $ \p ->
 				getViaTmp (RemoteVerify remote) key $ \t -> do
 					r <- Remote.retrieveKeyFile remote key file t p
 					-- Make sure we get the current

P2P/Annex.hs

@@ -120,6 +120,7 @@ runLocal runst runner a = case a of
   where
 	transfer mk k af ta = case runst of
 		-- Update transfer logs when serving.
+		-- Using noRetry because we're the sender.
 		Serving theiruuid _ _ -> 
 			mk theiruuid k af noRetry ta noNotification
 		-- Transfer logs are updated higher in the stack when

Remote/Git.hs

@@ -467,7 +467,7 @@ copyFromRemote' forcersync r (State connpool _) key file dest meterupdate
 				Just (object, checksuccess) -> do
 					copier <- mkCopier hardlink params
 					runTransfer (Transfer Download u key)
-						file forwardRetry
+						file stdRetry
 						(\p -> copier object dest (combineMeterUpdate p meterupdate) checksuccess)
 	| Git.repoIsSsh (repo r) = if forcersync
 		then fallback meterupdate
@@ -595,7 +595,7 @@ copyToRemote r (State connpool duc) key file meterupdate
 				ensureInitialized
 				copier <- mkCopier hardlink params
 				let verify = Annex.Content.RemoteVerify r
-				runTransfer (Transfer Download u key) file forwardRetry $ \p ->
+				runTransfer (Transfer Download u key) file stdRetry $ \p ->
 					let p' = combineMeterUpdate meterupdate p
 					in Annex.Content.saveState True `after`
 						Annex.Content.getViaTmp verify key