af8546990d
move: Added --safe option, which makes move honor numcopies settings. Also --unsafe enables the default behavior, anticipating that the default may one day change. This commit was sponsored by Ethan Aubin.
271 lines
8.5 KiB
Haskell
271 lines
8.5 KiB
Haskell
{- git-annex command
|
|
-
|
|
- Copyright 2010-2018 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU GPL 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 Annex.NumCopies
|
|
|
|
import System.Log.Logger (debugM)
|
|
|
|
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
|
|
, removeWhenOptions :: RemoveWhen
|
|
, keyOptions :: Maybe KeyOptions
|
|
, batchOption :: BatchMode
|
|
}
|
|
|
|
optParser :: CmdParamsDesc -> Parser MoveOptions
|
|
optParser desc = MoveOptions
|
|
<$> cmdParams desc
|
|
<*> parseFromToHereOptions
|
|
<*> parseRemoveWhenOptions
|
|
<*> optional (parseKeyOptions <|> parseFailedTransfersOption)
|
|
<*> parseBatchOption
|
|
|
|
instance DeferredParseClass MoveOptions where
|
|
finishParse v = MoveOptions
|
|
<$> pure (moveFiles v)
|
|
<*> finishParse (fromToOptions v)
|
|
<*> pure (removeWhenOptions v)
|
|
<*> pure (keyOptions v)
|
|
<*> pure (batchOption v)
|
|
|
|
data RemoveWhen = RemoveSafe | RemoveUnsafe | RemoveNever
|
|
deriving (Show, Eq)
|
|
|
|
parseRemoveWhenOptions :: Parser RemoveWhen
|
|
parseRemoveWhenOptions =
|
|
flag' RemoveSafe
|
|
( long "safe"
|
|
<> short 's'
|
|
<> help "preserve numcopies"
|
|
)
|
|
<|> flag' RemoveUnsafe
|
|
(long "unsafe"
|
|
<> short 'u'
|
|
<> help "do not preserve numcopies (default)"
|
|
)
|
|
<|> pure RemoveUnsafe
|
|
|
|
seek :: MoveOptions -> CommandSeek
|
|
seek o = allowConcurrentOutput $ do
|
|
let go = whenAnnexed $ start (fromToOptions o) (removeWhenOptions o)
|
|
case batchOption o of
|
|
Batch -> batchInput Right (batchCommandAction . go)
|
|
NoBatch -> withKeyOptions (keyOptions o) False
|
|
(startKey (fromToOptions o) (removeWhenOptions o))
|
|
(withFilesInGit go)
|
|
=<< workTreeItems (moveFiles o)
|
|
|
|
start :: FromToHereOptions -> RemoveWhen -> FilePath -> Key -> CommandStart
|
|
start fromto removewhen f k =
|
|
start' fromto removewhen afile k (mkActionItem afile)
|
|
where
|
|
afile = AssociatedFile (Just f)
|
|
|
|
startKey :: FromToHereOptions -> RemoveWhen -> Key -> ActionItem -> CommandStart
|
|
startKey fromto removewhen = start' fromto removewhen (AssociatedFile Nothing)
|
|
|
|
start' :: FromToHereOptions -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> CommandStart
|
|
start' fromto removewhen afile key ai = onlyActionOn key $
|
|
case fromto of
|
|
Right (FromRemote src) ->
|
|
checkFailedTransferDirection ai Download $
|
|
fromStart removewhen afile key ai =<< getParsed src
|
|
Right (ToRemote dest) ->
|
|
checkFailedTransferDirection ai Upload $
|
|
toStart removewhen afile key ai =<< getParsed dest
|
|
Left ToHere ->
|
|
checkFailedTransferDirection ai Download $
|
|
toHereStart removewhen afile key ai
|
|
|
|
showMoveAction :: RemoveWhen -> Key -> ActionItem -> Annex ()
|
|
showMoveAction RemoveNever = showStartKey "copy"
|
|
showMoveAction _ = showStartKey "move"
|
|
|
|
toStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> Remote -> CommandStart
|
|
toStart removewhen afile key ai dest = do
|
|
u <- getUUID
|
|
ishere <- inAnnex key
|
|
if not ishere || u == Remote.uuid dest
|
|
then stop -- not here, so nothing to do
|
|
else toStart' dest removewhen afile key ai
|
|
|
|
toStart' :: Remote -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> CommandStart
|
|
toStart' dest removewhen afile key ai = 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 = do
|
|
showMoveAction removewhen key ai
|
|
next $ 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 =
|
|
case isthere of
|
|
Left err -> do
|
|
showNote err
|
|
stop
|
|
Right False -> do
|
|
showAction $ "to " ++ Remote.name dest
|
|
ok <- notifyTransfer Upload afile $
|
|
upload (Remote.uuid dest) key afile stdRetry $
|
|
Remote.storeKey dest key afile
|
|
if ok
|
|
then finish $
|
|
Remote.logStatus dest key InfoPresent
|
|
else do
|
|
when fastcheck $
|
|
warning "This could have failed because --fast is enabled."
|
|
stop
|
|
Right True -> finish $
|
|
unlessM (expectedPresent dest key) $
|
|
Remote.logStatus dest key InfoPresent
|
|
where
|
|
finish :: Annex () -> CommandPerform
|
|
finish setpresentremote = case removewhen of
|
|
RemoveNever -> do
|
|
setpresentremote
|
|
next $ return True
|
|
_ -> lockContentForRemoval key $ \contentlock -> do
|
|
numcopies <- case removewhen of
|
|
RemoveUnsafe -> pure (NumCopies 1)
|
|
_ -> getAssociatedFileNumCopies afile
|
|
u <- getUUID
|
|
let drophere proof = do
|
|
liftIO $ debugM "drop" $ unwords
|
|
[ "Dropping from here"
|
|
, "proof:"
|
|
, show proof
|
|
]
|
|
-- 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
|
|
let faileddrophere = do
|
|
warning "Not enough copies exist to drop from here (use --unsafe to avoid this check)"
|
|
next $ do
|
|
setpresentremote
|
|
return True
|
|
(tocheck, verified) <- verifiableCopies key [u]
|
|
verifyEnoughCopiesToDrop "" key (Just contentlock)
|
|
numcopies [] verified
|
|
(UnVerifiedRemote dest : tocheck)
|
|
drophere faileddrophere
|
|
|
|
{- Moves (or copies) the content of an annexed file from a remote
|
|
- to the current repository.
|
|
-
|
|
- If the current repository already has the content, it is still removed
|
|
- from the remote.
|
|
-}
|
|
fromStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> Remote -> CommandStart
|
|
fromStart removewhen afile key ai src
|
|
| removewhen == RemoveNever = stopUnless (not <$> inAnnex key) go
|
|
| otherwise = go
|
|
where
|
|
go = stopUnless (fromOk src key) $ do
|
|
showMoveAction removewhen key ai
|
|
next $ fromPerform src removewhen key afile
|
|
|
|
fromOk :: Remote -> Key -> Annex Bool
|
|
fromOk src key = go =<< Annex.getState Annex.force
|
|
where
|
|
go True = either (const $ return True) return =<< haskey
|
|
go False
|
|
| Remote.hasKeyCheap src =
|
|
either (const expensive) return =<< haskey
|
|
| otherwise = expensive
|
|
haskey = Remote.hasKey src key
|
|
expensive = 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
|
|
ifM (inAnnex key)
|
|
( dispatch removewhen True
|
|
, dispatch removewhen =<< go
|
|
)
|
|
where
|
|
go = notifyTransfer Download afile $
|
|
download (Remote.uuid src) key afile stdRetry $ \p ->
|
|
getViaTmp (RemoteVerify src) key $ \t ->
|
|
Remote.retrieveKeyFile src key afile t p
|
|
dispatch _ False = stop -- failed
|
|
dispatch RemoveNever True = next $ return True -- copy complete
|
|
-- Finish move by dropping from remote, when verified
|
|
-- numcopies or RemoveUnsafe allows.
|
|
dispatch _ True = do
|
|
numcopies <- case removewhen of
|
|
RemoveUnsafe -> pure (NumCopies 1)
|
|
_ -> getAssociatedFileNumCopies afile
|
|
(tocheck, verified) <- verifiableCopies key [Remote.uuid src]
|
|
verifyEnoughCopiesToDrop "" key Nothing numcopies [] verified
|
|
tocheck dropremote faileddropremote
|
|
dropremote proof = do
|
|
liftIO $ debugM "drop" $ unwords
|
|
[ "Dropping from remote"
|
|
, show src
|
|
, "proof:"
|
|
, show proof
|
|
]
|
|
ok <- Remote.removeKey src key
|
|
next $ Command.Drop.cleanupRemote key src ok
|
|
faileddropremote = case removewhen of
|
|
RemoveUnsafe -> giveup "Unable to drop from remote."
|
|
RemoveSafe -> do
|
|
warning "Not enough copies exist to drop from remote (use --unsafe to avoid this check)"
|
|
next $ return True
|
|
RemoveNever -> next $ return True
|
|
|
|
{- 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. -}
|
|
toHereStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> CommandStart
|
|
toHereStart removewhen afile key ai
|
|
| removewhen == RemoveNever = stopUnless (not <$> inAnnex key) go
|
|
| otherwise = go
|
|
where
|
|
go = do
|
|
rs <- Remote.keyPossibilities key
|
|
forM_ rs $ \r ->
|
|
includeCommandAction $ do
|
|
showMoveAction removewhen key ai
|
|
next $ fromPerform r removewhen key afile
|
|
stop
|