From 46d4316954135bf47d6161c2a9d82c948aa62d71 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 29 Mar 2018 13:04:07 -0400 Subject: [PATCH] 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 | 63 ++++++++++++++++++++++++++++++++++------- CHANGELOG | 2 ++ Command/AddUrl.hs | 2 +- Command/Export.hs | 2 ++ Command/Get.hs | 2 +- Command/Move.hs | 4 +-- Command/TransferKey.hs | 4 +-- Command/TransferKeys.hs | 4 +-- P2P/Annex.hs | 1 + Remote/Git.hs | 4 +-- 10 files changed, 67 insertions(+), 21 deletions(-) diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs index b12b227f34..30d71afac7 100644 --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -1,6 +1,6 @@ {- git-annex transfers - - - Copyright 2012-2017 Joey Hess + - Copyright 2012-2018 Joey Hess - - 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. diff --git a/CHANGELOG b/CHANGELOG index d519e1abaf..58acca9ead 100644 --- a/CHANGELOG +++ b/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 Mon, 19 Mar 2018 23:13:59 -0400 diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 0e7201f123..1a032a13e2 100644 --- a/Command/AddUrl.hs +++ b/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 diff --git a/Command/Export.hs b/Command/Export.hs index cb3943e2e1..d4e2b4a55f 100644 --- a/Command/Export.hs +++ b/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 diff --git a/Command/Get.hs b/Command/Get.hs index a35246c374..4ebdc0cada 100644 --- a/Command/Get.hs +++ b/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 diff --git a/Command/Move.hs b/Command/Move.hs index 2f796cd937..f523a74e3c 100644 --- a/Command/Move.hs +++ b/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 diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs index aa6acbd554..1aa0a72771 100644 --- a/Command/TransferKey.hs +++ b/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 diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index 855ca46700..94582b2e07 100644 --- a/Command/TransferKeys.hs +++ b/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 diff --git a/P2P/Annex.hs b/P2P/Annex.hs index 8c6bebf887..05fa9e9ac0 100644 --- a/P2P/Annex.hs +++ b/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 diff --git a/Remote/Git.hs b/Remote/Git.hs index 526a0f4598..f1f7fdc9b1 100644 --- a/Remote/Git.hs +++ b/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