move: Avoid drops that make bad situations worse, but otherwise allow
See the big comment at the bottom of Command.Drop for the full details. (The --safe/--unsafe options were never released.) This commit was sponsored by Jake Vosloo on Patreon.
This commit is contained in:
Joey Hess
parent
4b8c289154
commit
64980db7d9
4 changed files with 138 additions and 103 deletions
210
Command/Move.hs
210
Command/Move.hs
|
|
@ -15,6 +15,7 @@ import qualified Remote
|
|||
import Annex.UUID
|
||||
import Annex.Transfer
|
||||
import Logs.Presence
|
||||
import Logs.Trust
|
||||
import Annex.NumCopies
|
||||
|
||||
import System.Log.Logger (debugM)
|
||||
|
|
@ -28,7 +29,7 @@ cmd = withGlobalOptions [jobsOption, jsonOptions, jsonProgressOption, annexedMat
|
|||
data MoveOptions = MoveOptions
|
||||
{ moveFiles :: CmdParams
|
||||
, fromToOptions :: FromToHereOptions
|
||||
, removeWhenOptions :: RemoveWhen
|
||||
, removeWhen :: RemoveWhen
|
||||
, keyOptions :: Maybe KeyOptions
|
||||
, batchOption :: BatchMode
|
||||
}
|
||||
|
|
@ -37,7 +38,7 @@ optParser :: CmdParamsDesc -> Parser MoveOptions
|
|||
optParser desc = MoveOptions
|
||||
<$> cmdParams desc
|
||||
<*> parseFromToHereOptions
|
||||
<*> parseRemoveWhenOptions
|
||||
<*> pure RemoveSafe
|
||||
<*> optional (parseKeyOptions <|> parseFailedTransfersOption)
|
||||
<*> parseBatchOption
|
||||
|
||||
|
|
@ -45,34 +46,20 @@ instance DeferredParseClass MoveOptions where
|
|||
finishParse v = MoveOptions
|
||||
<$> pure (moveFiles v)
|
||||
<*> finishParse (fromToOptions v)
|
||||
<*> pure (removeWhenOptions v)
|
||||
<*> pure (removeWhen v)
|
||||
<*> pure (keyOptions v)
|
||||
<*> pure (batchOption v)
|
||||
|
||||
data RemoveWhen = RemoveSafe | RemoveUnsafe | RemoveNever
|
||||
data RemoveWhen = RemoveSafe | 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)
|
||||
let go = whenAnnexed $ start (fromToOptions o) (removeWhen o)
|
||||
case batchOption o of
|
||||
Batch -> batchInput Right (batchCommandAction . go)
|
||||
NoBatch -> withKeyOptions (keyOptions o) False
|
||||
(startKey (fromToOptions o) (removeWhenOptions o))
|
||||
(startKey (fromToOptions o) (removeWhen o))
|
||||
(withFilesInGit go)
|
||||
=<< workTreeItems (moveFiles o)
|
||||
|
||||
|
|
@ -141,60 +128,58 @@ toPerform dest removewhen key afile fastcheck isthere =
|
|||
upload (Remote.uuid dest) key afile stdRetry $
|
||||
Remote.storeKey dest key afile
|
||||
if ok
|
||||
then finish $
|
||||
then finish False $
|
||||
Remote.logStatus dest key InfoPresent
|
||||
else do
|
||||
when fastcheck $
|
||||
warning "This could have failed because --fast is enabled."
|
||||
stop
|
||||
Right True -> finish $
|
||||
Right True -> finish True $
|
||||
unlessM (expectedPresent dest key) $
|
||||
Remote.logStatus dest key InfoPresent
|
||||
where
|
||||
finish :: Annex () -> CommandPerform
|
||||
finish setpresentremote = case removewhen of
|
||||
finish deststartedwithcopy 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
|
||||
RemoveSafe -> lockContentForRemoval key $ \contentlock -> do
|
||||
srcuuid <- getUUID
|
||||
let destuuid = Remote.uuid dest
|
||||
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
|
||||
|
||||
{- 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
|
||||
fromStart removewhen afile key ai src = case removewhen of
|
||||
RemoveNever -> stopUnless (not <$> inAnnex key) go
|
||||
RemoveSafe -> go
|
||||
where
|
||||
go = stopUnless (fromOk src key) $ do
|
||||
showMoveAction removewhen key ai
|
||||
|
|
@ -218,49 +203,50 @@ 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
|
||||
( dispatch removewhen True True
|
||||
, dispatch removewhen False =<< 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
|
||||
dispatch _ _ False = stop -- failed
|
||||
dispatch RemoveNever _ True = next $ return True -- copy complete
|
||||
dispatch RemoveSafe deststartedwithcopy True = lockContentShared key $ \_lck -> do
|
||||
let srcuuid = Remote.uuid src
|
||||
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
|
||||
showproof proof = "proof: " ++ show proof
|
||||
dropremote reason = do
|
||||
liftIO $ debugM "move" $ unwords
|
||||
[ "Dropping from remote"
|
||||
, show src
|
||||
, "proof:"
|
||||
, show proof
|
||||
, "(" ++ reason ++ ")"
|
||||
]
|
||||
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
|
||||
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. -}
|
||||
- When moving, the content is removed from all the reachable remotes that
|
||||
- it can safely be removed from. -}
|
||||
toHereStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> CommandStart
|
||||
toHereStart removewhen afile key ai
|
||||
| removewhen == RemoveNever = stopUnless (not <$> inAnnex key) go
|
||||
| otherwise = go
|
||||
toHereStart removewhen afile key ai = case removewhen of
|
||||
RemoveNever -> stopUnless (not <$> inAnnex key) go
|
||||
RemoveSafe -> go
|
||||
where
|
||||
go = do
|
||||
rs <- Remote.keyPossibilities key
|
||||
|
|
@ -269,3 +255,51 @@ toHereStart removewhen afile key ai
|
|||
showMoveAction removewhen key ai
|
||||
next $ fromPerform r removewhen key afile
|
||||
stop
|
||||
|
||||
{- 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 -> Bool -> Key -> AssociatedFile -> Annex DropCheck
|
||||
willDropMakeItWorse srcuuid destuuid 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 <= srctrust || desttrust < UnTrusted)
|
||||
|
||||
data DropCheck = DropWorse | DropAllowed | DropCheckNumCopies
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue