4c47568876
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.
370 lines
13 KiB
Haskell
370 lines
13 KiB
Haskell
{- git-annex command
|
|
-
|
|
- Copyright 2010-2020 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Command.Move where
|
|
|
|
import Command
|
|
import qualified Command.Drop
|
|
import qualified Annex
|
|
import Annex.Content
|
|
import qualified Remote
|
|
import Annex.UUID
|
|
import Annex.Transfer
|
|
import Logs.Presence
|
|
import Logs.Trust
|
|
import Logs.File
|
|
import Annex.NumCopies
|
|
|
|
import System.Log.Logger (debugM)
|
|
import qualified Data.ByteString.Char8 as B8
|
|
import qualified Data.ByteString.Lazy as L
|
|
|
|
cmd :: Command
|
|
cmd = withGlobalOptions [jobsOption, jsonOptions, jsonProgressOption, annexedMatchingOptions] $
|
|
command "move" SectionCommon
|
|
"move content of files to/from another repository"
|
|
paramPaths (seek <--< optParser)
|
|
|
|
data MoveOptions = MoveOptions
|
|
{ moveFiles :: CmdParams
|
|
, fromToOptions :: FromToHereOptions
|
|
, removeWhen :: RemoveWhen
|
|
, keyOptions :: Maybe KeyOptions
|
|
, batchOption :: BatchMode
|
|
}
|
|
|
|
optParser :: CmdParamsDesc -> Parser MoveOptions
|
|
optParser desc = MoveOptions
|
|
<$> cmdParams desc
|
|
<*> parseFromToHereOptions
|
|
<*> pure RemoveSafe
|
|
<*> optional (parseKeyOptions <|> parseFailedTransfersOption)
|
|
<*> parseBatchOption
|
|
|
|
instance DeferredParseClass MoveOptions where
|
|
finishParse v = MoveOptions
|
|
<$> pure (moveFiles v)
|
|
<*> finishParse (fromToOptions v)
|
|
<*> pure (removeWhen v)
|
|
<*> pure (keyOptions v)
|
|
<*> pure (batchOption v)
|
|
|
|
data RemoveWhen = RemoveSafe | RemoveNever
|
|
deriving (Show, Eq)
|
|
|
|
seek :: MoveOptions -> CommandSeek
|
|
seek o = startConcurrency stages $ do
|
|
case batchOption o of
|
|
NoBatch -> withKeyOptions (keyOptions o) False seeker
|
|
(commandAction . startKey (fromToOptions o) (removeWhen o))
|
|
(withFilesInGitAnnex ww seeker)
|
|
=<< workTreeItems ww (moveFiles o)
|
|
Batch fmt -> batchAnnexedFilesMatching fmt seeker
|
|
where
|
|
seeker = AnnexedFileSeeker
|
|
{ startAction = start (fromToOptions o) (removeWhen o)
|
|
, checkContentPresent = case fromToOptions o of
|
|
Right (FromRemote _) -> Nothing
|
|
Right (ToRemote _) -> Just True
|
|
Left ToHere -> Nothing
|
|
, usesLocationLog = True
|
|
}
|
|
stages = case fromToOptions o of
|
|
Right (FromRemote _) -> downloadStages
|
|
Right (ToRemote _) -> commandStages
|
|
Left ToHere -> downloadStages
|
|
ww = WarnUnmatchLsFiles
|
|
|
|
start :: FromToHereOptions -> RemoveWhen -> SeekInput -> RawFilePath -> Key -> CommandStart
|
|
start fromto removewhen si f k = start' fromto removewhen afile si k ai
|
|
where
|
|
afile = AssociatedFile (Just f)
|
|
ai = mkActionItem (k, afile)
|
|
|
|
startKey :: FromToHereOptions -> RemoveWhen -> (SeekInput, Key, ActionItem) -> CommandStart
|
|
startKey fromto removewhen (si, k, ai) =
|
|
start' fromto removewhen (AssociatedFile Nothing) si k ai
|
|
|
|
start' :: FromToHereOptions -> RemoveWhen -> AssociatedFile -> SeekInput -> Key -> ActionItem -> CommandStart
|
|
start' fromto removewhen afile si key ai =
|
|
case fromto of
|
|
Right (FromRemote src) ->
|
|
checkFailedTransferDirection ai Download $
|
|
fromStart removewhen afile key ai si =<< getParsed src
|
|
Right (ToRemote dest) ->
|
|
checkFailedTransferDirection ai Upload $
|
|
toStart removewhen afile key ai si =<< getParsed dest
|
|
Left ToHere ->
|
|
checkFailedTransferDirection ai Download $
|
|
toHereStart removewhen afile key ai si
|
|
|
|
describeMoveAction :: RemoveWhen -> String
|
|
describeMoveAction RemoveNever = "copy"
|
|
describeMoveAction _ = "move"
|
|
|
|
toStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> CommandStart
|
|
toStart removewhen afile key ai si dest = do
|
|
u <- getUUID
|
|
if u == Remote.uuid dest
|
|
then stop
|
|
else toStart' dest removewhen afile key ai si
|
|
|
|
toStart' :: Remote -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> CommandStart
|
|
toStart' dest removewhen afile key ai si = do
|
|
fast <- Annex.getState Annex.fast
|
|
if fast && removewhen == RemoveNever
|
|
then ifM (expectedPresent dest key)
|
|
( stop
|
|
, go True (pure $ Right False)
|
|
)
|
|
else go False (Remote.hasKey dest key)
|
|
where
|
|
go fastcheck isthere =
|
|
starting (describeMoveAction removewhen) (OnlyActionOn key ai) si $
|
|
toPerform dest removewhen key afile fastcheck =<< isthere
|
|
|
|
expectedPresent :: Remote -> Key -> Annex Bool
|
|
expectedPresent dest key = do
|
|
remotes <- Remote.keyPossibilities key
|
|
return $ dest `elem` remotes
|
|
|
|
toPerform :: Remote -> RemoveWhen -> Key -> AssociatedFile -> Bool -> Either String Bool -> CommandPerform
|
|
toPerform dest removewhen key afile fastcheck isthere = do
|
|
srcuuid <- getUUID
|
|
case isthere of
|
|
Left err -> do
|
|
showNote err
|
|
stop
|
|
Right False -> logMove srcuuid destuuid False key $ \deststartedwithcopy -> do
|
|
showAction $ "to " ++ Remote.name dest
|
|
ok <- notifyTransfer Upload afile $
|
|
upload dest key afile stdRetry
|
|
if ok
|
|
then finish deststartedwithcopy $
|
|
Remote.logStatus dest key InfoPresent
|
|
else do
|
|
when fastcheck $
|
|
warning "This could have failed because --fast is enabled."
|
|
stop
|
|
Right True -> logMove srcuuid destuuid True key $ \deststartedwithcopy ->
|
|
finish deststartedwithcopy $
|
|
unlessM (expectedPresent dest key) $
|
|
Remote.logStatus dest key InfoPresent
|
|
where
|
|
destuuid = Remote.uuid dest
|
|
finish deststartedwithcopy setpresentremote = case removewhen of
|
|
RemoveNever -> do
|
|
setpresentremote
|
|
next $ return True
|
|
RemoveSafe -> lockContentForRemoval key lockfailed $ \contentlock -> do
|
|
srcuuid <- getUUID
|
|
willDropMakeItWorse srcuuid destuuid deststartedwithcopy key afile >>= \case
|
|
DropAllowed -> drophere setpresentremote contentlock "moved"
|
|
DropCheckNumCopies -> do
|
|
numcopies <- getAssociatedFileNumCopies afile
|
|
(tocheck, verified) <- verifiableCopies key [srcuuid]
|
|
verifyEnoughCopiesToDrop "" key (Just contentlock)
|
|
numcopies [srcuuid] verified
|
|
(UnVerifiedRemote dest : tocheck)
|
|
(drophere setpresentremote contentlock . showproof)
|
|
(faileddrophere setpresentremote)
|
|
DropWorse -> faileddrophere setpresentremote
|
|
showproof proof = "proof: " ++ show proof
|
|
drophere setpresentremote contentlock reason = do
|
|
liftIO $ debugM "move" $ unwords
|
|
[ "Dropping from here"
|
|
, "(" ++ reason ++ ")"
|
|
]
|
|
-- Drop content before updating location logs,
|
|
-- in case disk space is very low this frees
|
|
-- up space before writing data to disk.
|
|
removeAnnex contentlock
|
|
next $ do
|
|
() <- setpresentremote
|
|
Command.Drop.cleanupLocal key
|
|
faileddrophere setpresentremote = do
|
|
showLongNote "(Use --force to override this check, or adjust numcopies.)"
|
|
showLongNote "Content not dropped from here."
|
|
next $ do
|
|
() <- setpresentremote
|
|
return False
|
|
|
|
-- This occurs when, for example, two files are being dropped
|
|
-- and have the same content. The seek stage checks if the content
|
|
-- is present, but due to buffering, may find it present for the
|
|
-- second file before the first is dropped. If so, nothing remains
|
|
-- to be done except for cleaning up.
|
|
lockfailed = next $ Command.Drop.cleanupLocal key
|
|
|
|
fromStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> CommandStart
|
|
fromStart removewhen afile key ai si src =
|
|
stopUnless (fromOk src key) $
|
|
starting (describeMoveAction removewhen) (OnlyActionOn key ai) si $
|
|
fromPerform src removewhen key afile
|
|
|
|
fromOk :: Remote -> Key -> Annex Bool
|
|
fromOk src key = do
|
|
u <- getUUID
|
|
remotes <- Remote.keyPossibilities key
|
|
return $ u /= Remote.uuid src && elem src remotes
|
|
|
|
fromPerform :: Remote -> RemoveWhen -> Key -> AssociatedFile -> CommandPerform
|
|
fromPerform src removewhen key afile = do
|
|
showAction $ "from " ++ Remote.name src
|
|
present <- inAnnex key
|
|
destuuid <- getUUID
|
|
logMove srcuuid destuuid present key $ \deststartedwithcopy ->
|
|
if present
|
|
then dispatch removewhen deststartedwithcopy True
|
|
else dispatch removewhen deststartedwithcopy =<< get
|
|
where
|
|
get = notifyTransfer Download afile $
|
|
download src key afile stdRetry
|
|
|
|
dispatch _ _ False = stop -- failed
|
|
dispatch RemoveNever _ True = next $ return True -- copy complete
|
|
dispatch RemoveSafe deststartedwithcopy True = lockContentShared key $ \_lck -> do
|
|
destuuid <- getUUID
|
|
willDropMakeItWorse srcuuid destuuid deststartedwithcopy key afile >>= \case
|
|
DropAllowed -> dropremote "moved"
|
|
DropCheckNumCopies -> do
|
|
numcopies <- getAssociatedFileNumCopies afile
|
|
(tocheck, verified) <- verifiableCopies key [Remote.uuid src]
|
|
verifyEnoughCopiesToDrop "" key Nothing numcopies [Remote.uuid src] verified
|
|
tocheck (dropremote . showproof) faileddropremote
|
|
DropWorse -> faileddropremote
|
|
|
|
srcuuid = Remote.uuid src
|
|
|
|
showproof proof = "proof: " ++ show proof
|
|
|
|
dropremote reason = do
|
|
liftIO $ debugM "move" $ unwords
|
|
[ "Dropping from remote"
|
|
, show src
|
|
, "(" ++ reason ++ ")"
|
|
]
|
|
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.)"
|
|
showLongNote $ "Content not dropped from " ++ Remote.name src ++ "."
|
|
next $ return False
|
|
|
|
{- Moves (or copies) the content of an annexed file from reachable remotes
|
|
- to the current repository.
|
|
-
|
|
- When moving, the content is removed from all the reachable remotes that
|
|
- it can safely be removed from. -}
|
|
toHereStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> CommandStart
|
|
toHereStart removewhen afile key ai si =
|
|
startingNoMessage (OnlyActionOn key ai) $ do
|
|
rs <- Remote.keyPossibilities key
|
|
forM_ rs $ \r ->
|
|
includeCommandAction $
|
|
starting (describeMoveAction removewhen) ai si $
|
|
fromPerform r removewhen key afile
|
|
next $ return True
|
|
|
|
{- The goal of this command is to allow the user maximum freedom to move
|
|
- files as they like, while avoiding making bad situations any worse
|
|
- than they already were.
|
|
-
|
|
- When the destination repository already had a copy of a file
|
|
- before the move operation began, dropping it from the source
|
|
- repository reduces the number of copies, and should fail if
|
|
- that would violate numcopies settings.
|
|
-
|
|
- On the other hand, when the destiation repository does not already
|
|
- have a copy of a file, it can be dropped without making numcopies
|
|
- worse, so the move is allowed even if numcopies is not met.
|
|
-
|
|
- Similarly, a file can move from an untrusted repository to another
|
|
- untrusted repository, even if that is the only copy of the file.
|
|
-
|
|
- But, moving a file from a repository with higher trust to an untrusted
|
|
- repository must still check that there are enough other copies to be
|
|
- safe.
|
|
-
|
|
- Also, required content settings should not be violated.
|
|
-
|
|
- This function checks all that. It needs to know if the destination
|
|
- repository already had a copy of the file before the move began.
|
|
-}
|
|
willDropMakeItWorse :: UUID -> UUID -> DestStartedWithCopy -> Key -> AssociatedFile -> Annex DropCheck
|
|
willDropMakeItWorse srcuuid destuuid (DestStartedWithCopy deststartedwithcopy) key afile =
|
|
ifM (Command.Drop.checkRequiredContent srcuuid key afile)
|
|
( if deststartedwithcopy
|
|
then unlessforced DropCheckNumCopies
|
|
else ifM checktrustlevel
|
|
( return DropAllowed
|
|
, unlessforced DropCheckNumCopies
|
|
)
|
|
, unlessforced DropWorse
|
|
)
|
|
where
|
|
unlessforced r = ifM (Annex.getState Annex.force)
|
|
( return DropAllowed
|
|
, return r
|
|
)
|
|
checktrustlevel = do
|
|
desttrust <- lookupTrust destuuid
|
|
srctrust <- lookupTrust srcuuid
|
|
return (desttrust > UnTrusted || desttrust >= srctrust)
|
|
|
|
data DropCheck = DropWorse | DropAllowed | DropCheckNumCopies
|
|
|
|
newtype DestStartedWithCopy = DestStartedWithCopy Bool
|
|
|
|
{- Runs an action that performs a move, and logs the move, allowing an
|
|
- interrupted move to be restarted later.
|
|
-
|
|
- This deals with the situation where dest did not start with a copy,
|
|
- but the move downloaded it, and was then interrupted before dropping
|
|
- it from the source. Re-running the move would see dest has a
|
|
- copy, and so could refuse to allow the drop. By providing the logged
|
|
- DestStartedWithCopy, this avoids that annoyance.
|
|
-}
|
|
logMove :: UUID -> UUID -> Bool -> Key -> (DestStartedWithCopy -> Annex a) -> Annex a
|
|
logMove srcuuid destuuid deststartedwithcopy key a = bracket setup cleanup go
|
|
where
|
|
logline = L.fromStrict $ B8.unwords
|
|
[ fromUUID srcuuid
|
|
, fromUUID destuuid
|
|
, serializeKey' key
|
|
]
|
|
|
|
setup = do
|
|
logf <- fromRepo gitAnnexMoveLog
|
|
-- Only log when there was no copy.
|
|
unless deststartedwithcopy $
|
|
appendLogFile logf gitAnnexMoveLock logline
|
|
return logf
|
|
|
|
cleanup logf = do
|
|
-- This buffers the log file content in memory.
|
|
-- The log file length is limited to the number of
|
|
-- concurrent jobs, times the number of times a move
|
|
-- (of different files) has been interrupted.
|
|
-- That could grow without bounds given enough time,
|
|
-- so the log is also truncated to the most recent
|
|
-- 100 items.
|
|
modifyLogFile logf gitAnnexMoveLock
|
|
(filter (/= logline) . reverse . take 100 . reverse)
|
|
|
|
go logf
|
|
-- Only need to check log when there is a copy.
|
|
| deststartedwithcopy = do
|
|
wasnocopy <- checkLogFile (fromRawFilePath logf) gitAnnexMoveLock
|
|
(== logline)
|
|
if wasnocopy
|
|
then go' False
|
|
else go' deststartedwithcopy
|
|
| otherwise = go' deststartedwithcopy
|
|
|
|
go' = a . DestStartedWithCopy
|