From 4c475688763e459bb357d9ec8d519afda8366a37 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 7 Dec 2020 14:44:21 -0400 Subject: [PATCH] refactoring This is groundwork for using git-annex transferkeys to run transfers, in order to allow stalled transfers to be interrupted and retried. The new upload and download are closer to what git-annex transferkeys does, so the plan is to make them use it. Then things that were left using upload' and download' won't recover from stalls. Notably, that includes import and export. But at least get/move/copy will be able to. (Also the assistant hopefully, but not yet.) This commit was sponsored by Jake Vosloo on Patreon. --- Annex/Action.hs | 18 ++++++++++++++++++ Annex/Import.hs | 4 ++-- Annex/Transfer.hs | 30 +++++++++++++++++++++++------- Command/AddUrl.hs | 4 ++-- Command/Export.hs | 2 +- Command/Get.hs | 11 +++-------- Command/Move.hs | 9 +++------ Command/TransferKey.hs | 4 ++-- Command/TransferKeys.hs | 4 ++-- P2P/Annex.hs | 2 +- Remote.hs | 16 +--------------- 11 files changed, 58 insertions(+), 46 deletions(-) diff --git a/Annex/Action.hs b/Annex/Action.hs index 1902b0d89c..fca7e14958 100644 --- a/Annex/Action.hs +++ b/Annex/Action.hs @@ -6,6 +6,8 @@ -} module Annex.Action ( + action, + verifiedAction, startup, shutdown, stopCoProcesses, @@ -21,6 +23,22 @@ import Annex.CheckAttr import Annex.HashObject import Annex.CheckIgnore +{- 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) + + {- Actions to perform each time ran. -} startup :: Annex () startup = return () diff --git a/Annex/Import.hs b/Annex/Import.hs index 57d7b5b2c1..9a5eda2968 100644 --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -466,7 +466,7 @@ importKeys remote importtreeconfig importcontent importablecontents = do return (Just (k', ok)) checkDiskSpaceToGet k Nothing $ notifyTransfer Download af $ - download (Remote.uuid remote) k af stdRetry $ \p' -> + download' (Remote.uuid remote) k af stdRetry $ \p' -> withTmp k $ downloader p' -- The file is small, so is added to git, so while importing @@ -520,7 +520,7 @@ importKeys remote importtreeconfig importcontent importablecontents = do return Nothing checkDiskSpaceToGet tmpkey Nothing $ notifyTransfer Download af $ - download (Remote.uuid remote) tmpkey af stdRetry $ \p -> + download' (Remote.uuid remote) tmpkey af stdRetry $ \p -> withTmp tmpkey $ \tmpfile -> metered (Just p) tmpkey $ const (rundownload tmpfile) diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs index cf190058e2..20358c6d8d 100644 --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -10,8 +10,10 @@ module Annex.Transfer ( module X, upload, + upload', alwaysUpload, download, + download', runTransfer, alwaysRunTransfer, noRetry, @@ -24,7 +26,9 @@ import qualified Annex import Logs.Transfer as X import Types.Transfer as X import Annex.Notification as X +import Annex.Content import Annex.Perms +import Annex.Action import Utility.Metered import Utility.ThreadScheduler import Annex.LockPool @@ -42,16 +46,28 @@ import qualified Data.Map.Strict as M import qualified System.FilePath.ByteString as P import Data.Ord -upload :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v -upload u key f d a _witness = guardHaveUUID u $ +upload :: Remote -> Key -> AssociatedFile -> RetryDecider -> NotifyWitness -> Annex Bool +upload r key f d = upload' (Remote.uuid r) key f d $ + action . Remote.storeKey r key f + +upload' :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v +upload' u key f d a _witness = guardHaveUUID u $ runTransfer (Transfer Upload u (fromKey id key)) f d a alwaysUpload :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v alwaysUpload u key f d a _witness = guardHaveUUID u $ alwaysRunTransfer (Transfer Upload u (fromKey id key)) f d a -download :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v -download u key f d a _witness = guardHaveUUID u $ +download :: Remote -> Key -> AssociatedFile -> RetryDecider -> NotifyWitness -> Annex Bool +download r key f d witness = + getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) key f $ \dest -> + download' (Remote.uuid r) key f d (go dest) witness + where + go dest p = verifiedAction $ + Remote.retrieveKeyFile r key f (fromRawFilePath dest) p + +download' :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v +download' u key f d a _witness = guardHaveUUID u $ runTransfer (Transfer Download u (fromKey id key)) f d a guardHaveUUID :: Observable v => UUID -> Annex v -> Annex v @@ -81,7 +97,7 @@ 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 retrydecider transferaction = enteringStage TransferStage $ debugLocks $ checkSecureHashes t $ do +runTransfer' ignorelock t afile retrydecider transferaction = enteringStage TransferStage $ debugLocks $ preCheckSecureHashes t $ do info <- liftIO $ startTransferInfo afile (meter, tfile, createtfile, metervar) <- mkProgressUpdater t info mode <- annexFileMode @@ -180,8 +196,8 @@ runTransfer' ignorelock t afile retrydecider transferaction = enteringStage Tran - still contains content using an insecure hash, remotes will likewise - tend to be configured to reject it, so Upload is also prevented. -} -checkSecureHashes :: Observable v => Transfer -> Annex v -> Annex v -checkSecureHashes t a = ifM (isCryptographicallySecure (transferKey t)) +preCheckSecureHashes :: Observable v => Transfer -> Annex v -> Annex v +preCheckSecureHashes t a = ifM (isCryptographicallySecure (transferKey t)) ( a , ifM (annexSecureHashesOnly <$> Annex.getGitConfig) ( do diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 6217d3fc75..c54e2ecf15 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -332,7 +332,7 @@ downloadWeb addunlockedmatcher o url urlinfo file = let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink) showNote "using youtube-dl" Transfer.notifyTransfer Transfer.Download url $ - Transfer.download webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \p -> + Transfer.download' webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \p -> youtubeDl url (fromRawFilePath workdir) p >>= \case Right (Just mediafile) -> do cleanuptmp @@ -396,7 +396,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.stdRetry $ \p -> do + Transfer.download' u dummykey afile Transfer.stdRetry $ \p -> do createAnnexDirectory (parentDir tmp) downloader (fromRawFilePath tmp) p if ok diff --git a/Command/Export.hs b/Command/Export.hs index 8635b93da7..0ad856f0fc 100644 --- a/Command/Export.hs +++ b/Command/Export.hs @@ -283,7 +283,7 @@ performExport r db ek af contentsha loc allfilledvar = do sent <- tryNonAsync $ case ek of AnnexKey k -> ifM (inAnnex k) ( notifyTransfer Upload af $ - upload (uuid r) k af stdRetry $ \pm -> do + upload' (uuid r) k af stdRetry $ \pm -> do let rollback = void $ performUnexport r db [ek] loc sendAnnex k rollback $ \f -> diff --git a/Command/Get.hs b/Command/Get.hs index c31b2c0bd7..433889f448 100644 --- a/Command/Get.hs +++ b/Command/Get.hs @@ -9,7 +9,6 @@ module Command.Get where import Command import qualified Remote -import Annex.Content import Annex.Transfer import Annex.NumCopies import Annex.Wanted @@ -114,10 +113,6 @@ getKey' key afile = dispatch | Remote.hasKeyCheap r = either (const False) id <$> Remote.hasKey r key | otherwise = return True - docopy r witness = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) key afile $ \dest -> - download (Remote.uuid r) key afile stdRetry - (\p -> do - showAction $ "from " ++ Remote.name r - Remote.verifiedAction $ - Remote.retrieveKeyFile r key afile (fromRawFilePath dest) p - ) witness + docopy r witness = do + showAction $ "from " ++ Remote.name r + download r key afile stdRetry witness diff --git a/Command/Move.hs b/Command/Move.hs index 114f2507af..71e2951700 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -142,8 +142,7 @@ toPerform dest removewhen key afile fastcheck isthere = do Right False -> logMove srcuuid destuuid False key $ \deststartedwithcopy -> do showAction $ "to " ++ Remote.name dest ok <- notifyTransfer Upload afile $ - upload (Remote.uuid dest) key afile stdRetry $ - Remote.action . Remote.storeKey dest key afile + upload dest key afile stdRetry if ok then finish deststartedwithcopy $ Remote.logStatus dest key InfoPresent @@ -223,10 +222,8 @@ fromPerform src removewhen key afile = do then dispatch removewhen deststartedwithcopy True else dispatch removewhen deststartedwithcopy =<< get where - get = notifyTransfer Download afile $ - download (Remote.uuid src) key afile stdRetry $ \p -> - getViaTmp (Remote.retrievalSecurityPolicy src) (RemoteVerify src) key afile $ \t -> - Remote.verifiedAction $ Remote.retrieveKeyFile src key afile (fromRawFilePath t) p + get = notifyTransfer Download afile $ + download src key afile stdRetry dispatch _ _ False = stop -- failed dispatch RemoveNever _ True = next $ return True -- copy complete diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs index b7f3cc9177..d6d660a39c 100644 --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -51,7 +51,7 @@ start o (_, key) = startingCustomOutput key $ case fromToOptions o of toPerform :: Key -> AssociatedFile -> Remote -> CommandPerform toPerform key file remote = go Upload file $ - upload (uuid remote) key file stdRetry $ \p -> do + upload' (uuid remote) key file stdRetry $ \p -> do tryNonAsync (Remote.storeKey remote key file p) >>= \case Right () -> do Remote.logStatus remote key InfoPresent @@ -62,7 +62,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 stdRetry $ \p -> + download' (uuid remote) key file stdRetry $ \p -> getViaTmp (retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case Right v -> return (True, v) diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index be7b4be01d..6e2112b5f8 100644 --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -49,7 +49,7 @@ start = do where runner (TransferRequest direction _ keydata file) remote | direction == Upload = notifyTransfer direction file $ - upload (Remote.uuid remote) key file stdRetry $ \p -> do + upload' (Remote.uuid remote) key file stdRetry $ \p -> do tryNonAsync (Remote.storeKey remote key file p) >>= \case Left e -> do warning (show e) @@ -58,7 +58,7 @@ start = do Remote.logStatus remote key InfoPresent return True | otherwise = notifyTransfer direction file $ - download (Remote.uuid remote) key file stdRetry $ \p -> + download' (Remote.uuid remote) key file stdRetry $ \p -> getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case Left e -> do diff --git a/P2P/Annex.hs b/P2P/Annex.hs index d107f6ef3b..8cf858fead 100644 --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -75,7 +75,7 @@ runLocal runst runner a = case a of let rsp = RetrievalAllKeysSecure v <- tryNonAsync $ do let runtransfer ti = - Right <$> transfer download k af (\p -> + Right <$> transfer download' k af (\p -> getViaTmp rsp DefaultVerify k af $ \tmp -> storefile (fromRawFilePath tmp) o l getb validitycheck p ti) let fallback = return $ Left $ diff --git a/Remote.hs b/Remote.hs index 1989f9382c..1d6250f9e2 100644 --- a/Remote.hs +++ b/Remote.hs @@ -70,6 +70,7 @@ import Annex.Common import Types.Remote import qualified Annex import Annex.UUID +import Annex.Action import Logs.UUID import Logs.Trust import Logs.Location hiding (logStatus) @@ -82,21 +83,6 @@ 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)