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.
This commit is contained in:
Joey Hess
parent
a0e1650a15
commit
4c47568876
11 changed files with 58 additions and 46 deletions
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ->
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 $
|
||||
|
|
|
|||
16
Remote.hs
16
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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue