changelog

Commands.hs

@@ -11,12 +11,9 @@ 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
@@ -50,19 +47,19 @@ 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)
+	startres <- start param :: Annex (Maybe SubCmdPerform)
-	case (res) of
+	case (startres) of
 		Nothing -> return True
 		Just perform -> do
 			showStart cmdname param
-			res <- perform :: Annex (Maybe SubCmdCleanup)
+			performres <- perform :: Annex (Maybe SubCmdCleanup)
-			case (res) of
+			case (performres) of
 				Nothing -> do
 					showEndFail
 					return False
 				Just cleanup -> do
-					res <- cleanup
+					cleanupres <- cleanup
-					if (res)
+					if (cleanupres)
 						then do
 							showEndOk
 							return True
@@ -76,7 +73,7 @@ doSubCmd cmdname start param = do
 data SubCmdWants = FilesInGit | FilesNotInGit | FilesMissing
 	| Description | Keys | Tempfile | FilesToBeCommitted
 
-data SubCommand = Command {
+data SubCommand = SubCommand {
 	subcmdname :: String,
 	subcmdaction :: SubCmdStart,
 	subcmdwants :: SubCmdWants,
@@ -84,27 +81,27 @@ data SubCommand = Command {
 }
 subCmds :: [SubCommand]
 subCmds =  [
-	  (Command "add"	addStart	FilesNotInGit
+	  (SubCommand "add"	addStart	FilesNotInGit
 		"add files to annex")
-	, (Command "get"	getStart	FilesInGit
+	, (SubCommand "get"	getStart	FilesInGit
 		"make content of annexed files available")
-	, (Command "drop"	dropStart	FilesInGit
+	, (SubCommand "drop"	dropStart	FilesInGit
 		"indicate content of files not currently wanted")
-	, (Command "move"	moveStart	FilesInGit
+	, (SubCommand "move"	moveStart	FilesInGit
 		"transfer content of files to/from another repository")
-	, (Command "init"	initStart	Description
+	, (SubCommand "init"	initStart	Description
 		"initialize git-annex with repository description")
-	, (Command "unannex"	unannexStart	FilesInGit
+	, (SubCommand "unannex"	unannexStart	FilesInGit
 		"undo accidential add command")
-	, (Command "fix"	fixStart	FilesInGit
+	, (SubCommand "fix"	fixStart	FilesInGit
 		"fix up symlinks to point to annexed content")
-	, (Command "pre-commit"	fixStart	FilesToBeCommitted
+	, (SubCommand "pre-commit" fixStart	FilesToBeCommitted
 		"fix up symlinks before they are committed")
-	, (Command "fromkey"	fromKeyStart	FilesMissing
+	, (SubCommand "fromkey"	fromKeyStart	FilesMissing
 		"adds a file using a specific key")
-	, (Command "dropkey"	dropKeyStart	Keys
+	, (SubCommand "dropkey"	dropKeyStart	Keys
 		"drops annexed content for specified keys")
-	, (Command "setkey"	setKeyStart	Tempfile
+	, (SubCommand "setkey"	setKeyStart	Tempfile
 		"sets annexed content for a key using a temp file")
 	]
 
@@ -131,6 +128,7 @@ options = [
 		storebool n b = Annex.flagChange n $ FlagBool b
 		storestring n s = Annex.flagChange n $ FlagString s
 
+header :: String
 header = "Usage: git-annex " ++ (join "|" $ map subcmdname subCmds)
 
 {- Usage message with lists of options and subcommands. -}
@@ -162,7 +160,7 @@ findWanted FilesNotInGit params repo = do
 findWanted FilesInGit params repo = do
 	files <- mapM (Git.inRepo repo) params
 	return $ foldl (++) [] files
-findWanted FilesMissing params repo = do
+findWanted FilesMissing params _ = do
 	files <- liftIO $ filterM missing params
 	return $ files
 	where
@@ -186,15 +184,17 @@ parseCmd argv state = do
 	when (null params) $ error usage
 	case lookupCmd (params !! 0) of
 		[] -> error usage
-		[Command name action want _] -> do
+		[SubCommand { subcmdname = name, subcmdaction = action,
-			f <- findWanted want (drop 1 params)
+				subcmdwants = want, subcmddesc = _ }] -> do
+			files <- findWanted want (drop 1 params)
 				(TypeInternals.repo state)
 			let actions = map (doSubCmd name action) $
-				filter notstate f
+				filter notstate files
-			let configactions = map (\f -> do
+			let configactions = map (\flag -> do
-				f
+				flag
 				return True) flags
 			return (configactions, actions)
+		_ -> error "internal error: multiple matching subcommands"
 	where
 		-- never include files from the state directory
 		notstate f = stateLoc /= take (length stateLoc) f
@@ -214,11 +214,10 @@ addStart file = notAnnexed file $ do
 		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
+		Just (key, _) -> return $ Just $ addCleanup file key
 addCleanup :: FilePath -> Key -> Annex Bool
 addCleanup file key = do
 	logStatus key ValuePresent
@@ -239,8 +238,10 @@ 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
+	ok <- Backend.removeKey backend key
-	return $ Just $ unannexCleanup file key
+	if (ok)
+		then return $ Just $ unannexCleanup file key
+		else return Nothing
 unannexCleanup :: FilePath -> Key -> Annex Bool
 unannexCleanup file key = do
 	logStatus key ValueMissing
@@ -259,9 +260,9 @@ getStart file = isAnnexed file $ \(key, backend) -> do
 	inannex <- inAnnex key
 	if (inannex)
 		then return Nothing
-		else return $ Just $ getPerform file key backend
+		else return $ Just $ getPerform key backend
-getPerform :: FilePath -> Key -> Backend -> Annex (Maybe SubCmdCleanup)
+getPerform :: Key -> Backend -> Annex (Maybe SubCmdCleanup)
-getPerform file key backend = do
+getPerform key backend = do
 	ok <- getViaTmp key (Backend.retrieveKeyFile backend key)
 	if (ok)
 		then return $ Just $ return True -- no cleanup needed
@@ -331,15 +332,15 @@ setKeyPerform tmpfile key = do
 	ok <- liftIO $ boolSystem "mv" [tmpfile, loc]
 	if (not ok)
 		then error "mv failed!"
-		else return $ Just $ setKeyCleanup tmpfile key
+		else return $ Just $ setKeyCleanup key
-setKeyCleanup :: FilePath -> Key -> Annex Bool
+setKeyCleanup :: Key -> Annex Bool
-setKeyCleanup tmpfile key = do
+setKeyCleanup 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
+fixStart file = isAnnexed file $ \(key, _) -> do
 	link <- calcGitLink file key
 	l <- liftIO $ readSymbolicLink file
 	if (link == l)
@@ -373,9 +374,9 @@ initPerform description = do
 initCleanup :: Annex Bool
 initCleanup = do
 	g <- Annex.gitRepo
-	log <- uuidLog
+	logfile <- uuidLog
-	liftIO $ Git.run g ["add", log]
+	liftIO $ Git.run g ["add", logfile]
-	liftIO $ Git.run g ["commit", "-m", "git annex init", log]
+	liftIO $ Git.run g ["commit", "-m", "git annex init", logfile]
 	return True
 
 {- Adds a file pointing at a manually-specified key -}
@@ -411,9 +412,9 @@ moveStart file = do
 	toName <- Annex.flagGet "torepository"
 	case (fromName, toName) of
 		("", "") -> error "specify either --from or --to"
-		("", to) -> moveToStart file
+		("",  _) -> moveToStart file
-		(from, "") -> moveFromStart file
+		(_ , "") -> moveFromStart file
-		(_, _) -> error "only one of --from or --to can be specified"
+		(_ ,  _) -> 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
@@ -427,13 +428,13 @@ moveStart file = do
  - allow it to be dropped.
  -}
 moveToStart :: FilePath -> Annex (Maybe SubCmdPerform)
-moveToStart file = isAnnexed file $ \(key, backend) -> do
+moveToStart file = isAnnexed file $ \(key, _) -> do
 	ishere <- inAnnex key
 	if (not ishere)
 		then return Nothing -- not here, so nothing to do
-		else return $ Just $ moveToPerform file key
+		else return $ Just $ moveToPerform key
-moveToPerform :: FilePath -> Key -> Annex (Maybe SubCmdCleanup)
+moveToPerform :: Key -> Annex (Maybe SubCmdCleanup)
-moveToPerform file key = do
+moveToPerform key = do
 	-- checking the remote is expensive, so not done in the start step
 	remote <- Remotes.commandLineRemote
 	isthere <- Remotes.inAnnex remote key
@@ -452,18 +453,21 @@ moveToPerform file key = do
 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",
+	ok <- Remotes.runCmd remote "git-annex" ["setkey", "--quiet",
 		"--backend=" ++ (backendName key),
 		"--key=" ++ keyName key,
 		tmpfile]
-	-- Record that the key is present on the remote.
+	if ok
-	g <- Annex.gitRepo
+		then do
-	remoteuuid <- getUUID remote
+			-- Record that the key is present on the remote.
-	log <- liftIO $ logChange g key remoteuuid ValuePresent
+			g <- Annex.gitRepo
-	Annex.queue "add" [] log
+			remoteuuid <- getUUID remote
-	-- Cleanup on the local side is the same as done for the
+			logfile <- liftIO $ logChange g key remoteuuid ValuePresent
-	-- drop subcommand.
+			Annex.queue "add" [] logfile
-	dropCleanup key
+			-- Cleanup on the local side is the same as done for the
+			-- drop subcommand.
+			dropCleanup key
+		else return False
 
 {- Moves the content of an annexed file from another repository to the current
  - repository and updates locationlog information on both.
@@ -472,15 +476,14 @@ moveToCleanup remote key tmpfile = do
  - from the other repository.
  -}
 moveFromStart :: FilePath -> Annex (Maybe SubCmdPerform)
-moveFromStart file = isAnnexed file $ \(key, backend) -> do
+moveFromStart file = isAnnexed file $ \(key, _) -> do
-	g <- Annex.gitRepo
 	remote <- Remotes.commandLineRemote
 	l <- Remotes.keyPossibilities key
 	if (elem remote l)
-		then return $ Just $ moveFromPerform file key
+		then return $ Just $ moveFromPerform key
 		else return Nothing
-moveFromPerform :: FilePath -> Key -> Annex (Maybe SubCmdCleanup)
+moveFromPerform :: Key -> Annex (Maybe SubCmdCleanup)
-moveFromPerform file key = do
+moveFromPerform key = do
 	remote <- Remotes.commandLineRemote
 	ishere <- inAnnex key
 	if (ishere)
@@ -493,22 +496,25 @@ moveFromPerform file key = do
 				else return Nothing -- fail
 moveFromCleanup :: Git.Repo -> Key -> Annex Bool
 moveFromCleanup remote key = do
-	Remotes.runCmd remote "git-annex" ["dropkey", "--quiet", "--force",
+	ok <- Remotes.runCmd remote "git-annex" ["dropkey", "--quiet", "--force",
 		"--backend=" ++ (backendName key),
 		keyName key]
-	-- Record locally that the key is not on the remote.
+	when ok $ do
-	remoteuuid <- getUUID remote
+		-- Record locally that the key is not on the remote.
-	g <- Annex.gitRepo
+		remoteuuid <- getUUID remote
-	log <- liftIO $ logChange g key remoteuuid ValueMissing
+		g <- Annex.gitRepo
-	Annex.queue "add" [] log
+		logfile <- liftIO $ logChange g key remoteuuid ValueMissing
-	return True
+		Annex.queue "add" [] logfile
+	return ok
 
 -- helpers
+notAnnexed :: FilePath -> Annex (Maybe a) -> Annex (Maybe a)
 notAnnexed file a = do
 	r <- Backend.lookupFile file
 	case (r) of
-		Just v -> return Nothing
+		Just _ -> return Nothing
 		Nothing -> a
+isAnnexed :: FilePath -> ((Key, Backend) -> Annex (Maybe a)) -> Annex (Maybe a)
 isAnnexed file a = do
 	r <- Backend.lookupFile file
 	case (r) of