diff options
| -rw-r--r-- | Annex/Transfer.hs | 32 | ||||
| -rw-r--r-- | Command/AddUrl.hs | 4 | ||||
| -rw-r--r-- | Command/Get.hs | 2 | ||||
| -rw-r--r-- | Command/Move.hs | 4 | ||||
| -rw-r--r-- | Command/SendKey.hs | 2 | ||||
| -rw-r--r-- | Command/TransferKey.hs | 4 | ||||
| -rw-r--r-- | Command/TransferKeys.hs | 7 | ||||
| -rw-r--r-- | Remote/Git.hs | 4 | ||||
| -rw-r--r-- | debian/changelog | 2 |
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 |