git-annex/Commands.hs

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

module Commands (parseCmd) where

import System.Console.GetOpt
import Control.Monad.State (liftIO)
import System.Posix.Files
import System.Directory
import System.Path
import Data.String.Utils
import Control.Monad (filterM)
import Monad (when, unless)
import List
import IO

import qualified GitRepo as Git
import qualified Annex
import Utility
import Locations
import qualified Backend
import UUID
import LocationLog
import Types
import Core
import qualified Remotes
import qualified TypeInternals

{- A subcommand runs in three stages. Each stage can return the next stage
 - to run.
 -
 - 1. The start stage is run before anything is printed about the
 -   subcommand, and can early abort it if the input does not make sense.
 -   It should run quickly and should not modify Annex state.
 -
 - 2. The perform stage is run after a message is printed about the subcommand
 -    being run, and it should be where the bulk of the work happens.
 -
 - 3. The cleanup stage is run only if the perform stage succeeds, and it
 -    returns the overall success/fail of the subcommand.
 -}
type SubCmdStart = String -> Annex (Maybe SubCmdPerform)
type SubCmdPerform = Annex (Maybe SubCmdCleanup)
type SubCmdCleanup = Annex Bool

{- Runs a subcommand through its three stages. -}
doSubCmd :: String -> SubCmdStart -> String -> Annex Bool
doSubCmd cmdname start param = do
	res <- start param :: Annex (Maybe SubCmdPerform)
	case (res) of
		Nothing -> return True
		Just perform -> do
			showStart cmdname param
			res <- perform :: Annex (Maybe SubCmdCleanup)
			case (res) of
				Nothing -> do
					showEndFail
					return False
				Just cleanup -> do
					res <- cleanup
					if (res)
						then do
							showEndOk
							return True
						else do
							showEndFail
							return False


{- A subcommand can broadly want one of several kinds of input parameters.
 - This allows a first stage of filtering before starting a subcommand. -}
data SubCmdWants = FilesInGit | FilesNotInGit | FilesMissing
	| Description | Keys | Tempfile | FilesToBeCommitted

data SubCommand = Command {
	subcmdname :: String,
	subcmdaction :: SubCmdStart,
	subcmdwants :: SubCmdWants,
	subcmddesc :: String
}
subCmds :: [SubCommand]
subCmds =  [
	  (Command "add"	addStart	FilesNotInGit
		"add files to annex")
	, (Command "get"	getStart	FilesInGit
		"make content of annexed files available")
	, (Command "drop"	dropStart	FilesInGit
		"indicate content of files not currently wanted")
	, (Command "move"	moveStart	FilesInGit
		"transfer content of files to/from another repository")
	, (Command "init"	initStart	Description
		"initialize git-annex with repository description")
	, (Command "unannex"	unannexStart	FilesInGit
		"undo accidential add command")
	, (Command "fix"	fixStart	FilesInGit
		"fix up symlinks to point to annexed content")
	, (Command "pre-commit"	fixStart	FilesToBeCommitted
		"fix up symlinks before they are committed")
	, (Command "fromkey"	fromKeyStart	FilesMissing
		"adds a file using a specific key")
	, (Command "dropkey"	dropKeyStart	Keys
		"drops annexed content for specified keys")
	, (Command "setkey"	setKeyStart	Tempfile
		"sets annexed content for a key using a temp file")
	]

-- Each dashed command-line option results in generation of an action
-- in the Annex monad that performs the necessary setting.
options :: [OptDescr (Annex ())]
options = [
	    Option ['f'] ["force"] (NoArg (storebool "force" True))
		"allow actions that may lose annexed data"
	  , Option ['q'] ["quiet"] (NoArg (storebool "quiet" True))
		"avoid verbose output"
	  , Option ['v'] ["verbose"] (NoArg (storebool "quiet" False))
		"allow verbose output"
	  , Option ['b'] ["backend"] (ReqArg (storestring "backend") "NAME")
		"specify default key-value backend to use"
	  , Option ['k'] ["key"] (ReqArg (storestring "key") "KEY")
		"specify a key to use"
	  , Option ['t'] ["to"] (ReqArg (storestring "torepository") "REPOSITORY")
		"specify to where to transfer content"
	  , Option ['f'] ["from"] (ReqArg (storestring "fromrepository") "REPOSITORY")
		"specify from where to transfer content"
	  ]
	where
		storebool n b = Annex.flagChange n $ FlagBool b
		storestring n s = Annex.flagChange n $ FlagString s

header = "Usage: git-annex " ++ (join "|" $ map subcmdname subCmds)

{- Usage message with lists of options and subcommands. -}
usage :: String
usage = usageInfo header options ++ "\nSubcommands:\n" ++ cmddescs
	where
		cmddescs = unlines $ map (\c -> indent $ showcmd c) subCmds
		showcmd c =
			(subcmdname c) ++
			(pad 11 (subcmdname c)) ++
			(descWanted (subcmdwants c)) ++
			(pad 13 (descWanted (subcmdwants c))) ++
			(subcmddesc c)
		indent l = "  " ++ l
		pad n s = take (n - (length s)) $ repeat ' '

{- Generate descriptions of wanted parameters for subcommands. -}
descWanted :: SubCmdWants -> String
descWanted Description = "DESCRIPTION"
descWanted Keys = "KEY ..."
descWanted _ = "PATH ..."

{- Finds the type of parameters a subcommand wants, from among the passed
 - parameter list. -}
findWanted :: SubCmdWants -> [String] -> Git.Repo -> IO [String]
findWanted FilesNotInGit params repo = do
	files <- mapM (Git.notInRepo repo) params
	return $ foldl (++) [] files
findWanted FilesInGit params repo = do
	files <- mapM (Git.inRepo repo) params
	return $ foldl (++) [] files
findWanted FilesMissing params repo = do
	files <- liftIO $ filterM missing params
	return $ files
	where
		missing f = do
			e <- doesFileExist f
			return $ not e
findWanted Description params _ = do
	return $ [unwords params]
findWanted FilesToBeCommitted params repo = do
	files <- mapM (Git.stagedFiles repo) params
	return $ foldl (++) [] files
findWanted _ params _ = return params

{- Parses command line and returns two lists of actions to be 
 - run in the Annex monad. The first actions configure it
 - according to command line options, while the second actions
 - handle subcommands. -}
parseCmd :: [String] -> AnnexState -> IO ([Annex Bool], [Annex Bool])
parseCmd argv state = do
	(flags, params) <- getopt
	when (null params) $ error usage
	case lookupCmd (params !! 0) of
		[] -> error usage
		[Command name action want _] -> do
			f <- findWanted want (drop 1 params)
				(TypeInternals.repo state)
			let actions = map (doSubCmd name action) $
				filter notstate f
			let configactions = map (\f -> do
				f
				return True) flags
			return (configactions, actions)
	where
		-- never include files from the state directory
		notstate f = stateLoc /= take (length stateLoc) f
		getopt = case getOpt Permute options argv of
			(flags, params, []) -> return (flags, params)
			(_, _, errs) -> ioError (userError (concat errs ++ usage))
		lookupCmd cmd = filter (\c -> cmd  == subcmdname c) subCmds

{- The add subcommand annexes a file, storing it in a backend, and then
 - moving it into the annex directory and setting up the symlink pointing
 - to its content. -}
addStart :: FilePath -> Annex (Maybe SubCmdPerform)
addStart file = notAnnexed file $ do
	s <- liftIO $ getSymbolicLinkStatus file
	if ((isSymbolicLink s) || (not $ isRegularFile s))
		then return Nothing
		else return $ Just $ addPerform file
addPerform :: FilePath -> Annex (Maybe SubCmdCleanup)
addPerform file = do
	g <- Annex.gitRepo
	stored <- Backend.storeFileKey file
	case (stored) of
		Nothing -> return Nothing
		Just (key, backend) -> return $ Just $ addCleanup file key
addCleanup :: FilePath -> Key -> Annex Bool
addCleanup file key = do
	logStatus key ValuePresent
	g <- Annex.gitRepo
	let dest = annexLocation g key
	liftIO $ createDirectoryIfMissing True (parentDir dest)
	liftIO $ renameFile file dest
	link <- calcGitLink file key
	liftIO $ createSymbolicLink link file
	Annex.queue "add" [] file
	return True

{- The unannex subcommand undoes an add. -}
unannexStart :: FilePath -> Annex (Maybe SubCmdPerform)
unannexStart file = isAnnexed file $ \(key, backend) -> do
	return $ Just $ unannexPerform file key backend
unannexPerform :: FilePath -> Key -> Backend -> Annex (Maybe SubCmdCleanup)
unannexPerform file key backend = do
	-- force backend to always remove
	Annex.flagChange "force" $ FlagBool True
	Backend.removeKey backend key
	return $ Just $ unannexCleanup file key
unannexCleanup :: FilePath -> Key -> Annex Bool
unannexCleanup file key = do
	logStatus key ValueMissing
	g <- Annex.gitRepo
	let src = annexLocation g key
	liftIO $ removeFile file
	liftIO $ Git.run g ["rm", "--quiet", file]
	-- git rm deletes empty directories; put them back
	liftIO $ createDirectoryIfMissing True (parentDir file)
	liftIO $ renameFile src file
	return True

{- Gets an annexed file from one of the backends. -}
getStart :: FilePath -> Annex (Maybe SubCmdPerform)
getStart file = isAnnexed file $ \(key, backend) -> do
	inannex <- inAnnex key
	if (inannex)
		then return Nothing
		else return $ Just $ getPerform file key backend
getPerform :: FilePath -> Key -> Backend -> Annex (Maybe SubCmdCleanup)
getPerform file key backend = do
	ok <- getViaTmp key (Backend.retrieveKeyFile backend key)
	if (ok)
		then return $ Just $ return True -- no cleanup needed
		else return Nothing

{- Indicates a file's content is not wanted anymore, and should be removed
 - if it's safe to do so. -}
dropStart :: FilePath -> Annex (Maybe SubCmdPerform)
dropStart file = isAnnexed file $ \(key, backend) -> do
	inbackend <- Backend.hasKey key
	if (not inbackend)
		then return Nothing
		else return $ Just $ dropPerform key backend
dropPerform :: Key -> Backend -> Annex (Maybe SubCmdCleanup)
dropPerform key backend = do
	success <- Backend.removeKey backend key
	if (success)
		then return $ Just $ dropCleanup key
		else return Nothing
dropCleanup :: Key -> Annex Bool
dropCleanup key = do
	logStatus key ValueMissing
	inannex <- inAnnex key
	if (inannex)
		then do
			g <- Annex.gitRepo
			let loc = annexLocation g key
			liftIO $ removeFile loc
			return True
		else return True

{- Drops cached content for a key. -}
dropKeyStart :: String -> Annex (Maybe SubCmdPerform)
dropKeyStart keyname = do
	backends <- Backend.list
	let key = genKey (backends !! 0) keyname
	present <- inAnnex key
	force <- Annex.flagIsSet "force"
	if (not present)
		then return Nothing
		else if (not force)
			then error "dropkey is can cause data loss; use --force if you're sure you want to do this"
			else return $ Just $ dropKeyPerform key
dropKeyPerform :: Key -> Annex (Maybe SubCmdCleanup)
dropKeyPerform key = do
	g <- Annex.gitRepo
	let loc = annexLocation g key
	liftIO $ removeFile loc
	return $ Just $ dropKeyCleanup key
dropKeyCleanup :: Key -> Annex Bool
dropKeyCleanup key = do
	logStatus key ValueMissing
	return True

{- Sets cached content for a key. -}
setKeyStart :: FilePath -> Annex (Maybe SubCmdPerform)
setKeyStart tmpfile = do
	keyname <- Annex.flagGet "key"
	when (null keyname) $ error "please specify the key with --key"
	backends <- Backend.list
	let key = genKey (backends !! 0) keyname
	return $ Just $ setKeyPerform tmpfile key
setKeyPerform :: FilePath -> Key -> Annex (Maybe SubCmdCleanup)
setKeyPerform tmpfile key = do
	g <- Annex.gitRepo
	let loc = annexLocation g key
	ok <- liftIO $ boolSystem "mv" [tmpfile, loc]
	if (not ok)
		then error "mv failed!"
		else return $ Just $ setKeyCleanup tmpfile key
setKeyCleanup :: FilePath -> Key -> Annex Bool
setKeyCleanup tmpfile key = do
	logStatus key ValuePresent
	return True

{- Fixes the symlink to an annexed file. -}
fixStart :: FilePath -> Annex (Maybe SubCmdPerform)
fixStart file = isAnnexed file $ \(key, backend) -> do
	link <- calcGitLink file key
	l <- liftIO $ readSymbolicLink file
	if (link == l)
		then return Nothing
		else return $ Just $ fixPerform file link
fixPerform :: FilePath -> FilePath -> Annex (Maybe SubCmdCleanup)
fixPerform file link = do
	liftIO $ createDirectoryIfMissing True (parentDir file)
	liftIO $ removeFile file
	liftIO $ createSymbolicLink link file
	return $ Just $ fixCleanup file
fixCleanup :: FilePath -> Annex Bool
fixCleanup file = do
	Annex.queue "add" [] file
	return True

{- Stores description for the repository etc. -}
initStart :: String -> Annex (Maybe SubCmdPerform)
initStart description = do
	when (null description) $ error $
		"please specify a description of this repository\n" ++ usage
	return $ Just $ initPerform description
initPerform :: String -> Annex (Maybe SubCmdCleanup)
initPerform description = do
	g <- Annex.gitRepo
	u <- getUUID g
	describeUUID u description
	liftIO $ gitAttributes g
	liftIO $ gitPreCommitHook g
	return $ Just $ initCleanup
initCleanup :: Annex Bool
initCleanup = do
	g <- Annex.gitRepo
	log <- uuidLog
	liftIO $ Git.run g ["add", log]
	liftIO $ Git.run g ["commit", "-m", "git annex init", log]
	return True

{- Adds a file pointing at a manually-specified key -}
fromKeyStart :: FilePath -> Annex (Maybe SubCmdPerform)
fromKeyStart file = do
	keyname <- Annex.flagGet "key"
	when (null keyname) $ error "please specify the key with --key"
	backends <- Backend.list
	let key = genKey (backends !! 0) keyname

	inbackend <- Backend.hasKey key
	unless (inbackend) $ error $
		"key ("++keyname++") is not present in backend"
	return $ Just $ fromKeyPerform file key
fromKeyPerform :: FilePath -> Key -> Annex (Maybe SubCmdCleanup)
fromKeyPerform file key = do
	link <- calcGitLink file key
	liftIO $ createDirectoryIfMissing True (parentDir file)
	liftIO $ createSymbolicLink link file
	return $ Just $ fromKeyCleanup file
fromKeyCleanup :: FilePath -> Annex Bool
fromKeyCleanup file = do
	Annex.queue "add" [] file
	return True

{- Move 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. -}
moveStart :: FilePath -> Annex (Maybe SubCmdPerform)
moveStart file = do
	fromName <- Annex.flagGet "fromrepository"
	toName <- Annex.flagGet "torepository"
	case (fromName, toName) of
		("", "") -> error "specify either --from or --to"
		("", to) -> moveToStart file
		(from, "") -> moveFromStart 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.
 -
 - 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 :: FilePath -> Annex (Maybe SubCmdPerform)
moveToStart file = isAnnexed file $ \(key, backend) -> do
	ishere <- inAnnex key
	if (not ishere)
		then return Nothing -- not here, so nothing to do
		else return $ Just $ moveToPerform file key
moveToPerform :: FilePath -> Key -> Annex (Maybe SubCmdCleanup)
moveToPerform file key = do
	-- checking the remote is expensive, so not done in the start step
	remote <- Remotes.commandLineRemote
	isthere <- Remotes.inAnnex remote key
	case isthere of
		Left err -> do
			showNote $ show err
			return Nothing
		Right False -> do
			Core.showNote $ "moving 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
				else return Nothing -- failed
		Right True -> return $ Just $ dropCleanup key
moveToCleanup :: Git.Repo -> Key -> FilePath -> Annex Bool
moveToCleanup remote key tmpfile = do
	-- Tell remote to use the transferred content.
	Remotes.runCmd remote "git-annex" ["setkey", "--quiet",
		"--backend=" ++ (backendName key),
		"--key=" ++ keyName key,
		tmpfile]
	-- Record that the key is present on the remote.
	g <- Annex.gitRepo
	remoteuuid <- getUUID remote
	log <- liftIO $ logChange g key remoteuuid ValuePresent
	Annex.queue "add" [] log
	-- Cleanup on the local side is the same as done for the
	-- drop subcommand.
	dropCleanup key

{- Moves 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.
 -}
moveFromStart :: FilePath -> Annex (Maybe SubCmdPerform)
moveFromStart file = isAnnexed file $ \(key, backend) -> do
	g <- Annex.gitRepo
	remote <- Remotes.commandLineRemote
	l <- Remotes.keyPossibilities key
	if (elem remote l)
		then return $ Just $ moveFromPerform file key
		else return Nothing
moveFromPerform :: FilePath -> Key -> Annex (Maybe SubCmdCleanup)
moveFromPerform file key = do
	remote <- Remotes.commandLineRemote
	ishere <- inAnnex key
	if (ishere)
		then return $ Just $ moveFromCleanup remote key
		else do
			Core.showNote $ "moving from " ++ (Git.repoDescribe remote) ++ "..."
			ok <- getViaTmp key (Remotes.copyFromRemote remote key)
			if (ok)
				then return $ Just $ moveFromCleanup remote key
				else return Nothing -- fail
moveFromCleanup :: Git.Repo -> Key -> Annex Bool
moveFromCleanup remote key = do
	Remotes.runCmd remote "git-annex" ["dropkey", "--quiet", "--force",
		"--backend=" ++ (backendName key),
		keyName key]
	-- Record locally that the key is not on the remote.
	remoteuuid <- getUUID remote
	g <- Annex.gitRepo
	log <- liftIO $ logChange g key remoteuuid ValueMissing
	Annex.queue "add" [] log
	return True

-- helpers
notAnnexed file a = do
	r <- Backend.lookupFile file
	case (r) of
		Just v -> return Nothing
		Nothing -> a
isAnnexed file a = do
	r <- Backend.lookupFile file
	case (r) of
		Just v -> a v
		Nothing -> return Nothing