Add copy subcommand.

1 files changed, 56 insertions, 51 deletions

diff --git a/Command/Move.hs b/Command/Move.hs
index c18054c90..cb6525919 100644
--- a/Command/Move.hs
+++ b/Command/Move.hs
@@ -7,7 +7,7 @@
 
 module Command.Move where
 
-import Control.Monad.State (liftIO, when)
+import Control.Monad.State (liftIO)
 
 import Command
 import qualified Command.Drop
@@ -22,43 +22,55 @@ import UUID
 import Messages
 
 seek :: [SubCmdSeek]
-seek = [withFilesInGit start]
+seek = [withFilesInGit $ start True]
 
-{- Move a file either --to or --from a repository.
+{- Move (or copy) a file either --to or --from a repository.
  -
  - This only operates on the cached file content; it does not involve
  - moving data in the key-value backend. -}
-start :: SubCmdStartString
-start file = do
+start :: Bool -> SubCmdStartString
+start move file = do
 	fromName <- Annex.flagGet "fromrepository"
 	toName <- Annex.flagGet "torepository"
 	case (fromName, toName) of
 		("", "") -> error "specify either --from or --to"
-		("",  _) -> moveToStart file
-		(_ , "") -> moveFromStart file
+		("",  _) -> toStart move file
+		(_ , "") -> fromStart move file
 		(_ ,  _) -> error "only one of --from or --to can be specified"
 
-{- Moves the content of an annexed file to another repository,
- - removing it from the current repository, and updates locationlog
- - information on both.
+showAction :: Bool -> FilePath -> Annex ()
+showAction True file = showStart "move" file
+showAction False file = showStart "copy" file
+
+remoteHasKey :: Git.Repo -> Key -> Bool -> Annex ()
+remoteHasKey remote key present	= do
+	g <- Annex.gitRepo
+	remoteuuid <- getUUID remote
+	logfile <- liftIO $ logChange g key remoteuuid status
+	Annex.queue "add" ["--"] logfile
+	where
+		status = if present then ValuePresent else ValueMissing
+
+{- Moves (or copies) the content of an annexed file to another repository,
+ - and updates locationlog information on both.
  -
- - If the destination already has the content, it is still removed
- - from the current repository.
+ - When moving, if the destination 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.
  -}
-moveToStart :: SubCmdStartString
-moveToStart file = isAnnexed file $ \(key, _) -> do
+toStart :: Bool -> SubCmdStartString
+toStart move file = isAnnexed file $ \(key, _) -> do
 	ishere <- inAnnex key
 	if not ishere
 		then return Nothing -- not here, so nothing to do
 		else do
-			showStart "move" file
-			return $ Just $ moveToPerform key
-moveToPerform :: Key -> SubCmdPerform
-moveToPerform key = do
+			showAction move file
+			return $ Just $ toPerform move key
+toPerform :: Bool -> Key -> SubCmdPerform
+toPerform move key = do
 	-- checking the remote is expensive, so not done in the start step
 	remote <- Remotes.commandLineRemote
 	isthere <- Remotes.inAnnex remote key
@@ -67,15 +79,15 @@ moveToPerform key = do
 			showNote $ show err
 			return Nothing
 		Right False -> do
-			showNote $ "moving to " ++ Git.repoDescribe remote ++ "..."
+			showNote $ "to " ++ Git.repoDescribe remote ++ "..."
 			let tmpfile = annexTmpLocation remote ++ keyFile key
 			ok <- Remotes.copyToRemote remote key tmpfile
 			if ok
-				then return $ Just $ moveToCleanup remote key tmpfile
+				then return $ Just $ toCleanup move remote key tmpfile
 				else return Nothing -- failed
 		Right True -> return $ Just $ Command.Drop.cleanup key
-moveToCleanup :: Git.Repo -> Key -> FilePath -> SubCmdCleanup
-moveToCleanup remote key tmpfile = do
+toCleanup :: Bool -> Git.Repo -> Key -> FilePath -> SubCmdCleanup
+toCleanup move remote key tmpfile = do
 	-- Tell remote to use the transferred content.
 	ok <- Remotes.runCmd remote "git-annex" ["setkey", "--quiet",
 		"--backend=" ++ backendName key,
@@ -83,52 +95,45 @@ moveToCleanup remote key tmpfile = do
 		tmpfile]
 	if ok
 		then do
-			-- Record that the key is present on the remote.
-			g <- Annex.gitRepo
-			remoteuuid <- getUUID remote
-			logfile <- liftIO $ logChange g key remoteuuid ValuePresent
-			Annex.queue "add" ["--"] logfile
-			-- Cleanup on the local side is the same as done for the
-			-- drop subcommand.
-			Command.Drop.cleanup key
+			remoteHasKey remote key True
+			if move
+				then Command.Drop.cleanup key
+				else return True
 		else return False
 
-{- Moves the content of an annexed file from another repository to the current
- - repository and updates locationlog information on both.
+{- Moves (or copies) the content of an annexed file from another repository
+ - to the current repository and updates locationlog information on both.
  -
  - If the current repository already has the content, it is still removed
- - from the other repository.
+ - from the other repository when moving.
  -}
-moveFromStart :: SubCmdStartString
-moveFromStart file = isAnnexed file $ \(key, _) -> do
+fromStart :: Bool -> SubCmdStartString
+fromStart move file = isAnnexed file $ \(key, _) -> do
 	remote <- Remotes.commandLineRemote
 	l <- Remotes.keyPossibilities key
 	if null $ filter (\r -> Remotes.same r remote) l
 		then return Nothing
 		else do
-			showStart "move" file
-			return $ Just $ moveFromPerform key
-moveFromPerform :: Key -> SubCmdPerform
-moveFromPerform key = do
+			showAction move file
+			return $ Just $ fromPerform move key
+fromPerform :: Bool -> Key -> SubCmdPerform
+fromPerform move key = do
 	remote <- Remotes.commandLineRemote
 	ishere <- inAnnex key
 	if ishere
-		then return $ Just $ moveFromCleanup remote key
+		then return $ Just $ fromCleanup move remote key
 		else do
-			showNote $ "moving from " ++ Git.repoDescribe remote ++ "..."
+			showNote $ "from " ++ Git.repoDescribe remote ++ "..."
 			ok <- getViaTmp key $ Remotes.copyFromRemote remote key
 			if ok
-				then return $ Just $ moveFromCleanup remote key
+				then return $ Just $ fromCleanup move remote key
 				else return Nothing -- fail
-moveFromCleanup :: Git.Repo -> Key -> SubCmdCleanup
-moveFromCleanup remote key = do
-	ok <- Remotes.runCmd remote "git-annex" ["dropkey", "--quiet", "--force",
+fromCleanup :: Bool -> Git.Repo -> Key -> SubCmdCleanup
+fromCleanup True remote key = do
+	ok <- Remotes.runCmd remote "git-annex" 
+		["dropkey", "--quiet", "--force",
 		"--backend=" ++ backendName key,
 		keyName key]
-	when ok $ do
-		-- Record locally that the key is not on the remote.
-		remoteuuid <- getUUID remote
-		g <- Annex.gitRepo
-		logfile <- liftIO $ logChange g key remoteuuid ValueMissing
-		Annex.queue "add" ["--"] logfile
+	remoteHasKey remote key False
 	return ok
+fromCleanup False _ _ = return True