diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index b7f1b71e56..6221e42568 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -190,11 +190,7 @@ downloadRemoteFile addunlockedmatcher r o uri file sz = checkCanAdd file $ do -- should use to download it. setTempUrl urlkey loguri let downloader = \dest p -> - tryNonAsync (Remote.retrieveKeyFile r urlkey af dest p) >>= \case - Right _ -> return True - Left e -> do - warning (show e) - return False + fst <$> Remote.verifiedAction (Remote.retrieveKeyFile r urlkey af dest p) ret <- downloadWith addunlockedmatcher downloader urlkey (Remote.uuid r) loguri file removeTempUrl urlkey return ret diff --git a/Command/Drop.hs b/Command/Drop.hs index 8768c8c255..785b491ad5 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -131,11 +131,7 @@ performRemote key afile numcopies remote = do , "proof:" , show proof ] - ok <- tryNonAsync (Remote.removeKey remote key) >>= \case - Right () -> return True - Left e -> do - warning (show e) - return False + ok <- Remote.action (Remote.removeKey remote key) next $ cleanupRemote key remote ok , stop ) diff --git a/Command/Get.hs b/Command/Get.hs index 7c9e8cfe2e..16d369371d 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -112,9 +112,5 @@ getKey' key afile = dispatch download (Remote.uuid r) key afile stdRetry (\p -> do showAction $ "from " ++ Remote.name r - tryNonAsync (Remote.retrieveKeyFile r key afile dest p) >>= \case - Right v -> return (True, v) - Left e -> do - warning (show e) - return (False, UnVerified) + Remote.verifiedAction (Remote.retrieveKeyFile r key afile dest p) ) witness diff --git a/Command/Move.hs b/Command/Move.hs index cc0d797c50..c33f92de74 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -126,12 +126,8 @@ toPerform dest removewhen key afile fastcheck isthere = Right False -> do showAction $ "to " ++ Remote.name dest ok <- notifyTransfer Upload afile $ - upload (Remote.uuid dest) key afile stdRetry $ \p -> - tryNonAsync (Remote.storeKey dest key afile p) >>= \case - Left e -> do - warning (show e) - return False - Right () -> return True + upload (Remote.uuid dest) key afile stdRetry $ + Remote.action . Remote.storeKey dest key afile if ok then finish False $ Remote.logStatus dest key InfoPresent @@ -207,11 +203,7 @@ fromPerform src removewhen key afile = do go = notifyTransfer Download afile $ download (Remote.uuid src) key afile stdRetry $ \p -> getViaTmp (Remote.retrievalSecurityPolicy src) (RemoteVerify src) key $ \t -> - tryNonAsync (Remote.retrieveKeyFile src key afile t p) >>= \case - Right v -> return (True, v) - Left e -> do - warning (show e) - return (False, UnVerified) + Remote.verifiedAction $ Remote.retrieveKeyFile src key afile t p dispatch _ _ False = stop -- failed dispatch RemoveNever _ True = next $ return True -- copy complete dispatch RemoveSafe deststartedwithcopy True = lockContentShared key $ \_lck -> do @@ -232,11 +224,7 @@ fromPerform src removewhen key afile = do , show src , "(" ++ reason ++ ")" ] - ok <- tryNonAsync (Remote.removeKey src key) >>= \case - Right () -> return True - Left e -> do - warning (show e) - return False + ok <- Remote.action (Remote.removeKey src key) next $ Command.Drop.cleanupRemote key src ok faileddropremote = do showLongNote "(Use --force to override this check, or adjust numcopies.)" diff --git a/Remote.hs b/Remote.hs index a1a07f95dc..6670925df0 100644 --- a/Remote.hs +++ b/Remote.hs @@ -11,6 +11,8 @@ module Remote ( Remote, uuid, name, + action, + verifiedAction, storeKey, retrieveKeyFile, retrieveKeyFileCheap, @@ -77,6 +79,21 @@ import Config.DynamicConfig import Git.Types (RemoteName, ConfigKey(..), fromConfigValue) import Utility.Aeson +{- Runs an action that may throw exceptions, catching and displaying them. -} +action :: Annex () -> Annex Bool +action a = tryNonAsync a >>= \case + Right () -> return True + Left e -> do + warning (show e) + return False + +verifiedAction :: Annex Verification -> Annex (Bool, Verification) +verifiedAction a = tryNonAsync a >>= \case + Right v -> return (True, v) + Left e -> do + warning (show e) + return (False, UnVerified) + {- Map from UUIDs of Remotes to a calculated value. -} remoteMap :: (Remote -> v) -> Annex (M.Map UUID v) remoteMap mkv = remoteMap' mkv (pure . mkk)