split commands into 3 phases

I feel like I just leveled up in Haskell.

Commands.hs

@@ -24,31 +24,66 @@ import Core
 import qualified Remotes
 import qualified TypeInternals
 
-data CmdWants = FilesInGit | FilesNotInGit | FilesMissing | Description
+{- A subcommand runs in three stages. Each stage can return the next stage
-data Command = Command {
+ - to run. 
-	cmdname :: String,
+ -
-	cmdaction :: (String -> Annex ()),
+ - 1. The start stage is run before anything is printed about the
-	cmdwants :: CmdWants,
+ -   subcommand, and can early abort it if the input does not make sense.
-	cmddesc :: String
+ -   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.
+ -
+ - 3. The cleanup stage is run only if the do 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 ()
+doSubCmd cmdname start param = do
+	res <- start param :: Annex (Maybe SubCmdPerform)
+	case (res) of
+		Nothing -> return ()
+		Just perform -> do
+			showStart cmdname param
+			res <- perform :: Annex (Maybe SubCmdCleanup)
+			case (res) of
+				Nothing -> showEndFail
+				Just cleanup -> do
+					res <- cleanup
+					if (res)
+						then showEndOk
+						else showEndFail
+
+
+data SubCmdWants = FilesInGit | FilesNotInGit | FilesMissing | Description
+data SubCommand = Command {
+	subcmdname :: String,
+	subcmdaction :: SubCmdStart,
+	subcmdwants :: SubCmdWants,
+	subcmddesc :: String
 }
 
-cmds :: [Command]
+subCmds :: [SubCommand]
-cmds =  [
+subCmds =  [
-	  (Command "add"	addCmd		FilesNotInGit
+	  (Command "add"	addStart	FilesNotInGit
 		"add files to annex")
-	, (Command "get"	getCmd		FilesInGit
+	, (Command "get"	getStart	FilesInGit
 		"make content of annexed files available")
-	, (Command "drop"	dropCmd		FilesInGit
+	, (Command "drop"	dropStart	FilesInGit
 		"indicate content of files not currently wanted")
-	, (Command "move"	moveCmd		FilesInGit
+	, (Command "move"	moveStart	FilesInGit
 		"transfer content of files to/from another repository")
-	, (Command "init"	initCmd		Description
+	, (Command "init"	initStart	Description
 		"initialize git-annex with repository description")
-	, (Command "unannex"	unannexCmd	FilesInGit
+	, (Command "unannex"	unannexStart	FilesInGit
 		"undo accidential add command")
-	, (Command "fix"	fixCmd		FilesInGit
+	, (Command "fix"	fixStart	FilesInGit
 		"fix up files' symlinks to point to annexed content")
-	, (Command "fromkey"	fromKeyCmd	FilesMissing
+	, (Command "fromkey"	fromKeyStart	FilesMissing
 		"adds a file using a specific key")
 	]
 
@@ -71,29 +106,29 @@ options = [
 		storebool n b = Annex.flagChange n $ FlagBool b
 		storestring n s = Annex.flagChange n $ FlagString s
 
-header = "Usage: git-annex " ++ (join "|" $ map cmdname cmds)
+header = "Usage: git-annex " ++ (join "|" $ map subcmdname subCmds)
 
 usage :: String
 usage = usageInfo header options ++ "\nSubcommands:\n" ++ cmddescs
 	where
-		cmddescs = unlines $ map (\c -> indent $ showcmd c) cmds
+		cmddescs = unlines $ map (\c -> indent $ showcmd c) subCmds
 		showcmd c =
-			(cmdname c) ++
+			(subcmdname c) ++
-			(pad 10 (cmdname c)) ++
+			(pad 10 (subcmdname c)) ++
-			(descWanted (cmdwants c)) ++
+			(descWanted (subcmdwants c)) ++
-			(pad 13 (descWanted (cmdwants c))) ++
+			(pad 13 (descWanted (subcmdwants c))) ++
-			(cmddesc c)
+			(subcmddesc c)
 		indent l = "  " ++ l
 		pad n s = take (n - (length s)) $ repeat ' '
 
 {- Generate descriptions of wanted parameters for subcommands. -}
-descWanted :: CmdWants -> String
+descWanted :: SubCmdWants -> String
 descWanted Description = "DESCRIPTION"
 descWanted _ = "PATH ..."
 
-{- Finds the type of parameters a command wants, from among the passed
+{- Finds the type of parameters a subcommand wants, from among the passed
  - parameter list. -}
-findWanted :: CmdWants -> [String] -> Git.Repo -> IO [String]
+findWanted :: SubCmdWants -> [String] -> Git.Repo -> IO [String]
 findWanted FilesNotInGit params repo = do
 	files <- mapM (Git.notInRepo repo) params
 	return $ foldl (++) [] files
@@ -121,94 +156,99 @@ parseCmd argv state = do
 		then error usage
 		else case (lookupCmd (params !! 0)) of
 			[] -> error usage
-			[Command _ action want _] -> do
+			[Command name action want _] -> do
 				f <- findWanted want (drop 1 params)
 					(TypeInternals.repo state)
-				return (flags, map action $ filter notstate f)
+				return (flags, map (doSubCmd name action) $
+					filter notstate f)
 	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  == cmdname c) cmds
+		lookupCmd cmd = filter (\c -> cmd  == subcmdname c) subCmds
 
-{- Annexes a file, storing it in a backend, and then moving it into
+{- The add subcommand annexes a file, storing it in a backend, and then
- - the annex directory and setting up the symlink pointing to its content. -}
+ - moving it into the annex directory and setting up the symlink pointing
-addCmd :: FilePath -> Annex ()
+ - to its content. -}
-addCmd file = notAnnexed file $ do
+addStart :: FilePath -> Annex (Maybe SubCmdPerform)
+addStart file = notAnnexed file $ do
 	s <- liftIO $ getSymbolicLinkStatus file
 	if ((isSymbolicLink s) || (not $ isRegularFile s))
-		then return ()
+		then return Nothing
-		else do
+		else return $ Just $ addPerform file
-			showStart "add" file
+addPerform :: FilePath -> Annex (Maybe SubCmdCleanup)
+addPerform file = do
 	g <- Annex.gitRepo
 	stored <- Backend.storeFileKey file
 	case (stored) of
-				Nothing -> showEndFail
+		Nothing -> return Nothing
-				Just (key, backend) -> do
+		Just (key, backend) -> return $ Just $ addCleanup file key
+addCleanup :: FilePath -> Key -> Annex Bool
+addCleanup file key = do
 	logStatus key ValuePresent
-					setup g key
+	g <- Annex.gitRepo
-	where
-		setup g key = do
 	let dest = annexLocation g key
 	liftIO $ createDirectoryIfMissing True (parentDir dest)
 	liftIO $ renameFile file dest
 	link <- calcGitLink file key
 	liftIO $ createSymbolicLink link file
 	liftIO $ Git.run g ["add", file]
-			showEndOk
+	return True
 
-{- Undo addCmd. -}
+{- The unannex subcommand undoes an add. -}
-unannexCmd :: FilePath -> Annex ()
+unannexStart :: FilePath -> Annex (Maybe SubCmdPerform)
-unannexCmd file = isAnnexed file $ \(key, backend) -> do
+unannexStart file = isAnnexed file $ \(key, backend) -> do
-	showStart "unannex" file
+	return $ Just $ unannexPerform file key backend
-	Annex.flagChange "force" $ FlagBool True -- force backend to always remove
+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
-	moveout g src
-	where
-		moveout g src = do
 	liftIO $ removeFile file
 	liftIO $ Git.run g ["rm", "--quiet", file]
-			-- git rm deletes empty directories;
+	-- git rm deletes empty directories; put them back
-			-- put them back
 	liftIO $ createDirectoryIfMissing True (parentDir file)
 	liftIO $ renameFile src file
-			showEndOk
+	return True
 
 {- Gets an annexed file from one of the backends. -}
-getCmd :: FilePath -> Annex ()
+getStart :: FilePath -> Annex (Maybe SubCmdPerform)
-getCmd file = isAnnexed file $ \(key, backend) -> do
+getStart file = isAnnexed file $ \(key, backend) -> do
 	inannex <- inAnnex key
 	if (inannex)
-		then return ()
+		then return Nothing
-		else do
+		else return $ Just $ getPerform file key backend
-			showStart "get" file
+getPerform :: FilePath -> Key -> Backend -> Annex (Maybe SubCmdCleanup)
+getPerform file key backend = do
 	ok <- getViaTmp key (Backend.retrieveKeyFile backend key)
 	if (ok)
-				then showEndOk
+		then return $ Just $ return True
-				else showEndFail
+		else return Nothing
 
 {- Indicates a file's content is not wanted anymore, and should be removed
  - if it's safe to do so. -}
-dropCmd :: FilePath -> Annex ()
+dropStart :: FilePath -> Annex (Maybe SubCmdPerform)
-dropCmd file = isAnnexed file $ \(key, backend) -> do
+dropStart file = isAnnexed file $ \(key, backend) -> do
 	inbackend <- Backend.hasKey key
 	if (not inbackend)
-		then return () -- no-op
+		then return Nothing
-		else do
+		else return $ Just $ dropPerform file key backend
-			showStart "drop" file
+dropPerform :: FilePath -> Key -> Backend -> Annex (Maybe SubCmdCleanup)
+dropPerform file key backend = do
 	success <- Backend.removeKey backend key
 	if (success)
-				then do
+		then return $ Just $ dropCleanup key
-					cleanup key
+		else return Nothing
-					showEndOk
+dropCleanup :: Key -> Annex Bool
-				else showEndFail
+dropCleanup key = do
-	where
-		cleanup key = do
 	logStatus key ValueMissing
 	inannex <- inAnnex key
 	if (inannex)
@@ -216,44 +256,54 @@ dropCmd file = isAnnexed file $ \(key, backend) -> do
 			g <- Annex.gitRepo
 			let loc = annexLocation g key
 			liftIO $ removeFile loc
-					return ()
+			return True
-				else return ()
+		else return True
 
 {- Fixes the symlink to an annexed file. -}
-fixCmd :: FilePath -> Annex ()
+fixStart :: FilePath -> Annex (Maybe SubCmdPerform)
-fixCmd file = isAnnexed file $ \(key, backend) -> do
+fixStart file = isAnnexed file $ \(key, backend) -> do
 	link <- calcGitLink file key
 	l <- liftIO $ readSymbolicLink file
 	if (link == l)
-		then return ()
+		then return Nothing
-		else do
+		else return $ Just $ fixPerform file link
-			showStart "fix" file
+fixPerform :: FilePath -> FilePath -> Annex (Maybe SubCmdCleanup)
+fixPerform file link = do
 	liftIO $ createDirectoryIfMissing True (parentDir file)
 	liftIO $ removeFile file
 	liftIO $ createSymbolicLink link file
 	g <- Annex.gitRepo
 	liftIO $ Git.run g ["add", file]
-			showEndOk
+	return $ Just $ fixCleanup
+fixCleanup :: Annex Bool
+fixCleanup = do
+	return True
 
 {- Stores description for the repository. -}
-initCmd :: String -> Annex ()
+initStart :: String -> Annex (Maybe SubCmdPerform)
-initCmd description = do
+initStart description = do
 	if (null description)
 		then error $ 
 			"please specify a description of this repository\n" ++
 			usage
-		else do
+		else return $ Just $ initPerform description
+initPerform :: String -> Annex (Maybe SubCmdCleanup)
+initPerform description = do
 	g <- Annex.gitRepo
 	u <- getUUID g
 	describeUUID u description
+	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]
-			liftIO $ putStrLn "description set"
+	return True
 
 {- Adds a file pointing at a manually-specified key -}
-fromKeyCmd :: FilePath -> Annex ()
+fromKeyStart :: FilePath -> Annex (Maybe SubCmdPerform)
-fromKeyCmd file = do
+fromKeyStart file = do
 	keyname <- Annex.flagGet "key"
 	if (null keyname)
 		then error "please specify the key with --key"
@@ -264,33 +314,31 @@ fromKeyCmd file = do
 	inbackend <- Backend.hasKey key
 	if (not inbackend)
 		then error $ "key ("++keyname++") is not present in backend"
-		else return ()
+		else return $ Just $ fromKeyPerform file key
-
+fromKeyPerform :: FilePath -> Key -> Annex (Maybe SubCmdCleanup)
+fromKeyPerform file key = do
 	link <- calcGitLink file key
-	showStart "fromkey" file
 	liftIO $ createDirectoryIfMissing True (parentDir file)
 	liftIO $ createSymbolicLink link file
+	return $ Just $ fromKeyCleanup file
+fromKeyCleanup :: FilePath -> Annex Bool
+fromKeyCleanup file = do
 	g <- Annex.gitRepo
 	liftIO $ Git.run g ["add", file]
-	showEndOk
+	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.
+ - moving data in the key-value backend. -}
- -
+moveStart :: FilePath -> Annex (Maybe SubCmdPerform)
- - Note that unlike drop, this does not honor annex.numcopies.
+moveStart file = do
- - A file's content can be moved even if there are insufficient copies to
- - allow it to be dropped.
- -}
-moveCmd :: FilePath -> Annex ()
-moveCmd file = do
 	fromName <- Annex.flagGet "fromrepository"
 	toName <- Annex.flagGet "torepository"
 	case (fromName, toName) of
 		("", "") -> error "specify either --from or --to"
-		("", to) -> moveTo file
+		("", to) -> moveToStart file
-		(from, "") -> moveFrom file
+		(from, "") -> moveFromStart file
 		(_, _) -> error "only one of --from or --to can be specified"
 
 {- Moves the content of an annexed file to another repository,
@@ -299,14 +347,20 @@ moveCmd file = do
  -
  - 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.
  -}
-moveTo :: FilePath -> Annex ()
+moveToStart :: FilePath -> Annex (Maybe SubCmdPerform)
-moveTo file = isAnnexed file $ \(key, backend) -> do
+moveToStart file = isAnnexed file $ \(key, backend) -> do
 	ishere <- inAnnex key
 	if (not ishere)
-		then return () -- not here, so nothing to do
+		then return Nothing -- not here, so nothing to do
-		else do
+		else return $ Just $ moveToPerform file key
-			showStart "move" file
+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
@@ -319,14 +373,16 @@ moveTo file = isAnnexed file $ \(key, backend) -> do
 			removeit remote key
 		removeit remote key = do
 			error "TODO: drop key from local"
-			-- Update local location log; key is present
+			return $ Just $ moveToCleanup remote key
-			-- there and missing here.
+moveToCleanup :: Git.Repo -> Key -> Annex Bool
+moveToCleanup remote key = do
+	-- Update local location log; key is present there and missing here.
 	logStatus key ValueMissing
 	u <- getUUID remote
 	liftIO $ logChange remote key u ValuePresent
 	-- Propigate location log to remote.
 	error "TODO: update remote locationlog"
-			showEndOk
+	return True
 
 {- Moves the content of an annexed file from another repository to the current
  - repository and updates locationlog information on both.
@@ -334,33 +390,42 @@ moveTo file = isAnnexed file $ \(key, backend) -> do
  - If the current repository already has the content, it is still removed
  - from the other repository.
  -}
-moveFrom :: FilePath -> Annex ()
+moveFromStart :: FilePath -> Annex (Maybe SubCmdPerform)
-moveFrom file = isAnnexed file $ \(key, backend) -> do
+moveFromStart file = isAnnexed file $ \(key, backend) -> do
-	showStart "move" file -- have to show this before checking remote
+	return $ Just $ moveFromPerform file key
-	ishere <- inAnnex key
+moveFromPerform :: FilePath -> Key -> Annex (Maybe SubCmdCleanup)
+moveFromPerform file key = do
+	-- checking the remote is expensive, so not done in the start step
 	remote <- Remotes.commandLineRemote
 	isthere <- Remotes.inAnnex remote key
+	ishere <- inAnnex key
 	case (ishere, isthere) of
 		(_, Left err) -> error (show err)
-		(_, Right False) -> showEndFail
+		(_, Right False) -> return Nothing -- not in remote; fail
 		(False, Right True) -> moveit remote key
 		(True, Right True) -> removeit remote key
 	where
 		moveit remote key = do
-			getViaTmp key (Remotes.copyFromRemote remote key)
+			ok <- getViaTmp key (Remotes.copyFromRemote remote key)
-			removeit remote key
+			if (ok)
+				then removeit remote key
+				else return Nothing -- fail
 		removeit remote key = do
 			error $ "TODO remove" ++ file
-			showEndOk
+			return $ Just moveFromCleanup
+moveFromCleanup :: Annex Bool
+moveFromCleanup = do
+	error "update location logs"
+	return True
 
 -- helpers
 notAnnexed file a = do
 	r <- Backend.lookupFile file
 	case (r) of
-		Just v -> return ()
+		Just v -> return Nothing
 		Nothing -> a
 isAnnexed file a = do
 	r <- Backend.lookupFile file
 	case (r) of
 		Just v -> a v
-		Nothing -> return ()
+		Nothing -> return Nothing

Core.hs

@@ -110,6 +110,8 @@ getViaTmp key action = do
 			logStatus key ValuePresent
 			return True
 		else do
+			-- the tmp file is left behind, in case caller wants
+			-- to resume its transfer
 			return False
 
 {- Output logging -}

doc/todo/parallel_possibilities.mdwn

@@ -5,9 +5,8 @@ heavily and mostly runs other git commands, maybe not a whole lot.
 Anyway, each git-annex command is broken down into a series of independant 
 actions, which has some potential for parallelism.
 
-Probably they would need to be split further. Each action currently has 3
+Each action has 3 distinct phases, basically "check", "perform", and
-distinct phases, basically "check", "do", and "record". If the check action
+"cleanup". The perform actions are not parellizable; the cleanup may be,
-returned a do action that returned a record action, then it could easily
+and the check should be easily parallelizable, although they may access the
-make sense to parallelize the check actions and start on the do actions
+disk or run minor git query commands, so would probably not want to run
-(which probably won't parallelize well) while they are still being
+too many of them at once.
-generated, and possibly parallelize the record actions at the end.