git-annex/Command/Move.hs

{- git-annex command
 -
 - Copyright 2010-2023 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE OverloadedStrings #-}

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 Logs.Location
import Annex.NumCopies

import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as L

cmd :: Command
cmd = withAnnexOptions [jobsOption, jsonOptions, jsonProgressOption, annexedMatchingOptions] $
	command "move" SectionCommon
		"move content of files to/from another repository"
		paramPaths (seek <--< optParser)

data MoveOptions = MoveOptions
	{ moveFiles :: CmdParams
	, fromToOptions :: Maybe FromToHereOptions
	, removeWhen :: RemoveWhen
	, keyOptions :: Maybe KeyOptions
	, batchOption :: BatchMode
	}

optParser :: CmdParamsDesc -> Parser MoveOptions
optParser desc = MoveOptions
	<$> cmdParams desc
	<*> parseFromToHereOptions
	<*> pure RemoveSafe
	<*> optional (parseKeyOptions <|> parseFailedTransfersOption)
	<*> parseBatchOption True

instance DeferredParseClass MoveOptions where
	finishParse v = MoveOptions
		<$> pure (moveFiles v)
		<*> maybe (pure Nothing) (Just <$$> finishParse)
			(fromToOptions v)
		<*> pure (removeWhen v)
		<*> pure (keyOptions v)
		<*> pure (batchOption v)

data RemoveWhen = RemoveSafe | RemoveNever
	deriving (Show, Eq)

seek :: MoveOptions -> CommandSeek
seek o = case fromToOptions o of
	Just fto -> seek' o fto
	Nothing -> giveup "Specify --from or --to"

seek' :: MoveOptions -> FromToHereOptions -> CommandSeek
seek' o fto = startConcurrency stages $ do
	case batchOption o of
		NoBatch -> withKeyOptions (keyOptions o) False seeker
			(commandAction . keyaction)
			(withFilesInGitAnnex ww seeker)
			=<< workTreeItems ww (moveFiles o)
		Batch fmt -> batchOnly (keyOptions o) (moveFiles o) $
			batchAnnexed fmt seeker keyaction
  where
	seeker = AnnexedFileSeeker
		{ startAction = start fto (removeWhen o)
		, checkContentPresent = case fto of
			FromOrToRemote (FromRemote _) -> Nothing
			FromOrToRemote (ToRemote _) -> Just True
			ToHere -> Nothing
			FromRemoteToRemote _ _ -> Nothing
		, usesLocationLog = True
		}
	stages = case fto of
		FromOrToRemote (FromRemote _) -> downloadStages
		FromOrToRemote (ToRemote _) -> commandStages
		ToHere -> downloadStages
		FromRemoteToRemote _ _ -> commandStages
	keyaction = startKey fto (removeWhen o)
	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
		FromOrToRemote (FromRemote src) ->
			checkFailedTransferDirection ai Download $
				fromStart removewhen afile key ai si =<< getParsed src
		FromOrToRemote (ToRemote dest) ->
			checkFailedTransferDirection ai Upload $
				toStart removewhen afile key ai si =<< getParsed dest
		ToHere ->
			checkFailedTransferDirection ai Download $
				toHereStart removewhen afile key ai si
		FromRemoteToRemote src dest -> do
			src' <- getParsed src
			dest' <- getParsed dest
			fromToStart removewhen afile key ai si src' dest'

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.getRead 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
					logMoveCleanup deststartedwithcopy
					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
			logMoveCleanup deststartedwithcopy
			next $ return True
		RemoveSafe -> lockContentForRemoval key lockfailed $ \contentlock -> do
			srcuuid <- getUUID
			r <- willDropMakeItWorse srcuuid destuuid deststartedwithcopy key afile >>= \case
				DropAllowed -> drophere setpresentremote contentlock "moved"
				DropCheckNumCopies -> do
					(numcopies, mincopies) <- getSafestNumMinCopies afile key
					(tocheck, verified) <- verifiableCopies key [srcuuid]
					verifyEnoughCopiesToDrop "" key (Just contentlock)
						 numcopies mincopies [srcuuid] verified
						 (UnVerifiedRemote dest : tocheck)
						 (drophere setpresentremote contentlock . showproof)
						 (faileddrophere setpresentremote)
				DropWorse -> faileddrophere setpresentremote
			logMoveCleanup deststartedwithcopy
			return r
	showproof proof = "proof: " ++ show proof
	drophere setpresentremote contentlock reason = do
		fastDebug "Command.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 (Command.Drop.DroppingUnused False)
	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 (Command.Drop.DroppingUnused False)

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
	-- check if the remote contains the key, when it can be done cheaply
	| Remote.hasKeyCheap src = 
		Remote.hasKey src key >>= \case
			Right True -> return True
			-- Don't skip getting the key just because the
			-- remote no longer contains it if the log
			-- says the remote is supposed to contain it;
			-- that would be surprising behavior.
			_ -> checklog
	| otherwise = checklog
  where
	checklog = 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
	present <- inAnnex key
	fromPerform' present src removewhen key afile

fromPerform' :: Bool -> Remote -> RemoveWhen -> Key -> AssociatedFile -> CommandPerform
fromPerform' present src removewhen key afile = do
	showAction $ "from " ++ Remote.name src
	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 $
		logStatusAfter key .
			download src key afile stdRetry
	
	dispatch _ deststartedwithcopy False = do
		logMoveCleanup deststartedwithcopy
		stop -- copy failed
	dispatch RemoveNever deststartedwithcopy True = do
		logMoveCleanup deststartedwithcopy
		next $ return True -- copy complete
	dispatch RemoveSafe deststartedwithcopy True = lockContentShared key $ \_lck -> do
		destuuid <- getUUID
		willDropMakeItWorse srcuuid destuuid deststartedwithcopy key afile >>= \case
			DropAllowed -> dropremote deststartedwithcopy "moved"
			DropCheckNumCopies -> do
				(numcopies, mincopies) <- getSafestNumMinCopies afile key
				(tocheck, verified) <- verifiableCopies key [Remote.uuid src]
				verifyEnoughCopiesToDrop "" key Nothing numcopies mincopies [Remote.uuid src] verified
					tocheck (dropremote deststartedwithcopy . showproof) (faileddropremote deststartedwithcopy)
			DropWorse -> faileddropremote deststartedwithcopy
	
	srcuuid = Remote.uuid src
	
	showproof proof = "proof: " ++ show proof
	
	dropremote deststartedwithcopy reason = do
		fastDebug "Command.Move" $ unwords
			[ "Dropping from remote"
			, show src
			, "(" ++ reason ++ ")"
			]
		ok <- Remote.action (Remote.removeKey src key)
		when ok $
			logMoveCleanup deststartedwithcopy
		next $ Command.Drop.cleanupRemote key src (Command.Drop.DroppingUnused False) ok
	
	faileddropremote deststartedwithcopy = do
		showLongNote "(Use --force to override this check, or adjust numcopies.)"
		showLongNote $ "Content not dropped from " ++ Remote.name src ++ "."
		logMoveCleanup deststartedwithcopy
		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

fromToStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> Remote -> CommandStart
fromToStart removewhen afile key ai si src dest = do
	if Remote.uuid src == Remote.uuid dest
		then stop
		else do
			u <- getUUID
			if u == Remote.uuid src
				then toStart removewhen afile key ai si dest
				else if u == Remote.uuid dest
					then fromStart removewhen afile key ai si src
					else stopUnless (fromOk src key) $
						starting (describeMoveAction removewhen) (OnlyActionOn key ai) si $
							fromToPerform src dest removewhen key afile

{- When there is a local copy, transfer it to the dest, and drop from the src.
 -
 - Otherwise, download a copy from the dest, populating the local annex
 - copy, but not updating location logs. Then transfer that to the dest,
 - drop the local copy, and finally drop from the src.
 -
 - Using a regular download of the local copy, rather than download to
 - some other file makes resuming an interruped download work as usual,
 - and simplifies implementation. It does mean that, if `git-annex get` of
 - the same content is being run at the same time, it will see that
 - the local copy exists, but then it would get deleted. To avoid that
 - unexpected behavior, check the location log before dropping the local
 - copy, and if it has been updated (by another process) to say that the
 - content is present locally, skip dropping the local copy. 
 - 
 - (That leaves a small race, where the other process updates the location
 - log after we check it. And another where the other process sees the
 - local copy exists just before we drop it. In either case the resulting
 - behavior is similar to `git-annex move --to` being run concurrently 
 - with `git-annex get`.)
 -
 - The other complication of this approach is that the temporary local
 - copy could be seen by another process that uses it as one of the
 - necessary copies when dropping from somewhere else. To avoid the number
 - of copies being reduced in such a situation (or the local copy not being
 - able to be safely dropped), lock the local copy for drop before
 - downloading it (v10) or immediately after download (v9 or older).
 -}
fromToPerform :: Remote -> Remote -> RemoveWhen -> Key -> AssociatedFile -> CommandPerform
fromToPerform src dest removewhen key afile = do
	present <- inAnnex key
	if present
		then gopresent
		else do
			showAction $ "from " ++ Remote.name src
			downloadsrctotemp
			sendtemptodest
			dropfromsrc
			showAction $ "to " ++ Remote.name dest
			error "TODO"
  where
	sendlocaltodest = error "TODO"
	downloadsrctotemp = error "TODO"
	sendtemptodest = error "TODO"
	dropfromsrc = error "TODO"

	gopresent = do
		haskey <- Remote.hasKey dest key
		toPerform dest RemoveNever key afile False haskey >>= \case
			Just cleanup -> fromPerform' True src removewhen key afile >>= \case
				Just cleanup' -> return $ Just $ do
					ok <- cleanup
					ok' <- cleanup'
					return (ok && ok')
				Nothing -> return $ Just cleanup
			Nothing -> return Nothing

{- 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 destination 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 (Command.Drop.PreferredContentChecked False) srcuuid key afile)
		( if deststartedwithcopy
			then unlessforced DropCheckNumCopies
			else ifM checktrustlevel
				( return DropAllowed
				, unlessforced DropCheckNumCopies
				)
		, unlessforced DropWorse
		)
  where
	unlessforced r = ifM (Annex.getRead Annex.force)
		( return DropAllowed
		, return r
		)
	checktrustlevel = do
		desttrust <- lookupTrust destuuid
		srctrust <- lookupTrust srcuuid
		return (desttrust > UnTrusted || desttrust >= srctrust)

data DropCheck = DropWorse | DropAllowed | DropCheckNumCopies

data DestStartedWithCopy = DestStartedWithCopy Bool (Annex ())

{- This should be called once the move has succeeded, or if it failed
 - without doing anything. It should not be called if the move transferred
 - the content but failed to drop due to eg a network error. In such a
 - case, the move can be restarted later, so the move log should be
 - preserved. -}
logMoveCleanup :: DestStartedWithCopy -> Annex ()
logMoveCleanup (DestStartedWithCopy _ a) = a

{- Runs an action that performs a move, and logs the move, allowing an
 - failed or interrupted move to be re-done 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 = go =<< setup
  where
	logline = L.fromStrict $ B8.unwords
		[ fromUUID srcuuid
		, fromUUID destuuid
		, serializeKey' key
		]

	setup = do
		logf <- fromRepo gitAnnexMoveLog
		lckf <- fromRepo gitAnnexMoveLock
		-- Only log when there was no copy.
		unless deststartedwithcopy $
			appendLogFile logf lckf logline
		return (logf, lckf)

	cleanup (logf, lckf) =
		-- 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 lckf
			(filter (/= logline) . reverse . take 100 . reverse)

	go fs@(logf, lckf)
		-- Only need to check log when there is a copy.
		| deststartedwithcopy = do
			wasnocopy <- checkLogFile logf lckf (== logline)
			if wasnocopy
				then go' fs False
				else go' fs deststartedwithcopy
		| otherwise = go' fs deststartedwithcopy

	go' fs deststartedwithcopy' = a $
		DestStartedWithCopy deststartedwithcopy' (cleanup fs)