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.

diff --git a/Annex/Action.hs b/Annex/Action.hs
index 1902b0d89c96c4b318e1d454536e7cdc82a7bb98..fca7e14958a486ddce9030cf101a4d4ce3ac4394 100644 (file)
--- 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 57d7b5b2c11d2e8be529b8f71ea2c8b16aeb7b76..9a5eda2968375c389eae66a668b8d36f27d076be 100644 (file)
--- 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 cf190058e2ccb24a3684a1ae183b3986ccdc59d8..20358c6d8d6df5b0e9d186febef054ea9e80bf26 100644 (file)
--- 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 6217d3fc75c7f95ef480a8c0364c34fe7907e154..c54e2ecf1515065e3610569081461a242b5948d6 100644 (file)
--- 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 8635b93da795e3e55e9068a49f70fda0b64e3507..0ad856f0fc9e5e309d3bb674d4d68d6469f824f9 100644 (file)
--- 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 c31b2c0bd7b34abc1338337d97a8797be183a89e..433889f448b233496e631d90ea058587426091d4 100644 (file)
--- 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 114f2507afb3878ffdbcb5abd0aa2bc0f047bd55..71e29517008476dc9dad764e0bde8a073a60ba1a 100644 (file)
--- 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 b7f3cc917725e8c7f2c26d06b05c0f1d6a4d0592..d6d660a39c515a6ac056ce4120352a4d2ae1948c 100644 (file)
--- 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 be7b4be01de85dfc50bfdfd42d50b243c24afeee..6e2112b5f839687f03afc3414380be0236a8739e 100644 (file)
--- 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 d107f6ef3b2e194186e70d9bbdec1dbfc3fdd979..8cf858fead981b1ea168f5bd7235ded31cb95244 100644 (file)
--- 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 1989f9382c1a38e2588bac638b7089a3e6eb9de6..1d6250f9e2cf7966aa528bab0cc18be8b615d49f 100644 (file)
--- 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)