git-annex/Command/Move.hs

{- git-annex command
 -
 - Copyright 2010-2013 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.Move where

import Common.Annex
import Command
import qualified Command.Drop
import qualified Annex
import Annex.Content
import qualified Remote
import Annex.UUID
import qualified Option
import Logs.Presence
import Logs.Transfer
import GitAnnex.Options
import Types.Key

def :: [Command]
def = [withOptions moveOptions $ command "move" paramPaths seek
	SectionCommon "move content of files to/from another repository"]

fromOption :: Option
fromOption = Option.field ['f'] "from" paramRemote "source remote"

toOption :: Option
toOption = Option.field ['t'] "to" paramRemote "destination remote"

moveOptions :: [Option]
moveOptions = [fromOption, toOption] ++ keyOptions

seek :: [CommandSeek]
seek = 
	[ withField toOption Remote.byNameWithUUID $ \to ->
	  withField fromOption Remote.byNameWithUUID $ \from ->
	  withKeyOptions (startKey to from True) $
	  withFilesInGit $ whenAnnexed $ start to from True
	]

start :: Maybe Remote -> Maybe Remote -> Bool -> FilePath -> (Key, Backend) -> CommandStart
start to from move file (key, _) = start' to from move (Just file) key

startKey :: Maybe Remote -> Maybe Remote -> Bool -> Key -> CommandStart
startKey to from move key = start' to from move Nothing key

start' :: Maybe Remote -> Maybe Remote -> Bool -> AssociatedFile -> Key -> CommandStart
start' to from move afile key = do
	noAuto
	case (from, to) of
		(Nothing, Nothing) -> error "specify either --from or --to"
		(Nothing, Just dest) -> toStart dest move afile key
		(Just src, Nothing) -> fromStart src move afile key
		(_ ,  _) -> error "only one of --from or --to can be specified"
  where
	noAuto = when move $ whenM (Annex.getState Annex.auto) $ error
		"--auto is not supported for move"

showMoveAction :: Bool -> Key -> AssociatedFile -> Annex ()
showMoveAction True _ (Just file) = showStart "move" file
showMoveAction False _ (Just file) = showStart "copy" file
showMoveAction True key Nothing = showStart "move" (key2file key)
showMoveAction False key Nothing = showStart "copy" (key2file key)

{- Moves (or copies) the content of an annexed file to a remote.
 -
 - If the remote already has the content, it is still removed from
 - the current repository.
 -
 - Note that unlike drop, this does not honor annex.numcopies.
 - A file's content can be moved even if there are insufficient copies to
 - allow it to be dropped.
 -}
toStart :: Remote -> Bool -> AssociatedFile -> Key -> CommandStart
toStart dest move afile key = do
	u <- getUUID
	ishere <- inAnnex key
	if not ishere || u == Remote.uuid dest
		then stop -- not here, so nothing to do
		else do
			showMoveAction move key afile
			next $ toPerform dest move key afile
toPerform :: Remote -> Bool -> Key -> AssociatedFile -> CommandPerform
toPerform dest move key afile = moveLock move key $ do
	-- Checking the remote is expensive, so not done in the start step.
	-- In fast mode, location tracking is assumed to be correct,
	-- and an explicit check is not done, when copying. When moving,
	-- it has to be done, to avoid inaverdent data loss.
	fast <- Annex.getState Annex.fast
	let fastcheck = fast && not move && not (Remote.hasKeyCheap dest)
	isthere <- if fastcheck
		then Right <$> expectedpresent
		else Remote.hasKey dest key
	case isthere of
		Left err -> do
			showNote err
			stop
		Right False -> do
			showAction $ "to " ++ Remote.name dest
			ok <- upload (Remote.uuid dest) key afile noRetry $
				Remote.storeKey dest key afile
			if ok
				then do
					Remote.logStatus dest key InfoPresent
					finish
				else do
					when fastcheck $
						warning "This could have failed because --fast is enabled."
					stop
		Right True -> do
			unlessM expectedpresent $
				Remote.logStatus dest key InfoPresent
			finish
  where
	finish
		| move = do
			removeAnnex key
			next $ Command.Drop.cleanupLocal key
		| otherwise = next $ return True
	expectedpresent = do
		remotes <- Remote.keyPossibilities key
		return $ dest `elem` remotes

{- 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 :: Remote -> Bool -> AssociatedFile -> Key -> CommandStart
fromStart src move afile key
	| move = go
	| otherwise = stopUnless (not <$> inAnnex key) go
  where
	go = stopUnless (fromOk src key) $ do
		showMoveAction move key afile
		next $ fromPerform src move key afile

fromOk :: Remote -> Key -> Annex Bool
fromOk src key
	| Remote.hasKeyCheap src =
		either (const expensive) return =<< Remote.hasKey src key
	| otherwise = expensive
  where
	expensive = do
		u <- getUUID
		remotes <- Remote.keyPossibilities key
		return $ u /= Remote.uuid src && elem src remotes

fromPerform :: Remote -> Bool -> Key -> AssociatedFile -> CommandPerform
fromPerform src move key afile = moveLock move key $
	ifM (inAnnex key)
		( handle move True
		, handle move =<< go
		)
  where
	go = download (Remote.uuid src) key afile noRetry $ \p -> do
		showAction $ "from " ++ Remote.name src
		getViaTmp key $ \t -> Remote.retrieveKeyFile src key afile t p
	handle _ False = stop -- failed
	handle False True = next $ return True -- copy complete
	handle True True = do -- finish moving
		ok <- Remote.removeKey src key
		next $ Command.Drop.cleanupRemote key src ok

{- Locks a key in order for it to be moved.
 - No lock is needed when a key is being copied. -}
moveLock :: Bool -> Key -> Annex a -> Annex a
moveLock True key a = lockContent key a
moveLock False _ a = a