uninit: Support --json and --json-error-messages

Had to convert uninit to do everything that can error out inside a
CommandStart. This was harder than feels nice.

(Also, in passing, converted CommandCheck to use a data type, not a
weird number that it was not clear how it managed to be unique.)

Sponsored-By: the NIH-funded NICEMAN (ReproNim TR&D3) project

CHANGELOG

@@ -41,7 +41,7 @@ git-annex (10.20230408) UNRELEASED; urgency=medium
     (addunused, configremote, dead, describe, dropunused, enableremote,
     expire, fix, importfeed, init, initremote, log, merge, migrate, reinit,
     reinject, rekey, renameremote, rmurl, semitrust, setpresentkey, trust,
-    unannex, undo, untrust, unused, upgrade)
+    unannex, undo, uninit, untrust, unused, upgrade)
   * log: When --raw-date is used, display only seconds from the epoch, as
     documented, omitting a trailing "s" that was included in the output
     before.

CmdLine/GitAnnexShell/Checks.hs

@@ -78,7 +78,7 @@ checkDirectory mdir = do
 {- Modifies a Command to check that it is run in either a git-annex
  - repository, or a repository with a gcrypt-id set. -}
 gitAnnexShellCheck :: Command -> Command
-gitAnnexShellCheck = addCheck okforshell . dontCheck repoExists
+gitAnnexShellCheck = addCheck GitAnnexShellOk okforshell . dontCheck repoExists
   where
 	okforshell = unlessM (isInitialized <||> isJust . gcryptId <$> Annex.getGitConfig) $
 		giveup "Not a git-annex or gcrypt repository."

Command.hs

@@ -125,17 +125,17 @@ commonChecks :: [CommandCheck]
 commonChecks = [repoExists]
 
 repoExists :: CommandCheck
-repoExists = CommandCheck 0 (ensureInitialized remoteList)
+repoExists = CommandCheck RepoExists (ensureInitialized remoteList)
 
 notBareRepo :: Command -> Command
-notBareRepo = addCheck checkNotBareRepo
+notBareRepo = addCheck CheckNotBareRepo checkNotBareRepo
 
 checkNotBareRepo :: Annex ()
 checkNotBareRepo = whenM (fromRepo Git.repoIsLocalBare) $
 	giveup "You cannot run this command in a bare repository."
 
 noDaemonRunning :: Command -> Command
-noDaemonRunning = addCheck $ whenM (isJust <$> daemonpid) $
+noDaemonRunning = addCheck NoDaemonRunning $ whenM (isJust <$> daemonpid) $
 	giveup "You cannot run this command while git-annex watch or git-annex assistant is running."
   where
 	daemonpid = liftIO . checkDaemon . fromRawFilePath
@@ -144,9 +144,9 @@ noDaemonRunning = addCheck $ whenM (isJust <$> daemonpid) $
 dontCheck :: CommandCheck -> Command -> Command
 dontCheck check cmd = mutateCheck cmd $ \c -> filter (/= check) c
 
-addCheck :: Annex () -> Command -> Command
-addCheck check cmd = mutateCheck cmd $ \c ->
-	CommandCheck (length c + 100) check : c
+addCheck :: CommandCheckId -> Annex () -> Command -> Command
+addCheck cid check cmd = mutateCheck cmd $ \c ->
+	CommandCheck cid check : c
 
 mutateCheck :: Command -> ([CommandCheck] -> [CommandCheck]) -> Command
 mutateCheck cmd@(Command { cmdcheck = c }) a = cmd { cmdcheck = a c }

Command/Uninit.hs

@@ -1,6 +1,6 @@
 {- git-annex command
  -
- - Copyright 2010-2021 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2023 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -11,6 +11,7 @@ import Command
 import qualified Git
 import qualified Git.Command
 import qualified Git.Ref
+import qualified Git.Branch
 import qualified Command.Unannex
 import qualified Annex.Branch
 import qualified Annex.Queue
@@ -23,23 +24,60 @@ import Utility.FileMode
 import qualified Utility.RawFilePath as R
 
 import System.PosixCompat.Files (linkCount)
+import Control.Concurrent.STM
 
 cmd :: Command
-cmd = addCheck check $ 
+cmd = withAnnexOptions [jsonOptions] $
 	command "uninit" SectionUtility
 		"de-initialize git-annex and clean out repository"
 		paramNothing (withParams seek)
 
-check :: Annex ()
-check = do
-	b <- current_branch
-	when (b == Just Annex.Branch.name) $ giveup $
-		"cannot uninit when the " ++ Git.fromRef Annex.Branch.name ++ " branch is checked out"
-	top <- fromRepo Git.repoPath
-	currdir <- liftIO R.getCurrentDirectory
-	whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $
-		giveup "can only run uninit from the top of the git repository"
+seek :: CmdParams -> CommandSeek
+seek = withNothing $ do
+	ok <- liftIO $ newTVarIO False
+	let checkok v a = do
+		liftIO $ atomically $ writeTVar ok v
+		() <- a	
+		liftIO $ atomically $ readTVar ok
+	let recordok = do
+		liftIO $ atomically $ writeTVar ok True
+		return True
+	let recordnotok = liftIO $ atomically $ writeTVar ok False
+
+	whenM (checkok False $ commandAction $ checkCanUninit recordok) $ do
+		let symlinksok = checkok True $ withFilesNotInGit
+			(CheckGitIgnore False)
+			(WarnUnmatchWorkTreeItems "uninit")
+			(checksymlinks recordnotok)
+			=<< workTreeItems ww []
+		whenM symlinksok $ do
+			withFilesInGitAnnex ww (Command.Unannex.seeker True)
+				=<< workTreeItems ww []
+			whenM (checkok False $ commandAction $ removeAnnexDir recordok) $ 
+				whenM (checkok False $ commandAction $ completeUnitialize recordok) $
+					liftIO exitSuccess
   where
+	ww = WarnUnmatchLsFiles "uninit"
+	checksymlinks recordnotok (_, f) = 
+		commandAction $ lookupKey f >>= \case
+			Nothing -> stop
+			Just k -> startCheckIncomplete recordnotok f k
+
+checkCanUninit :: CommandCleanup -> CommandStart
+checkCanUninit recordok = 
+	starting "uninit check" (ActionItemOther Nothing) (SeekInput []) $ do
+		runchecks
+		next recordok
+  where
+	runchecks = do
+		b <- current_branch
+		when (b == Just Annex.Branch.name) $ giveup $
+			"cannot uninit when the " ++ Git.fromRef Annex.Branch.name ++ " branch is checked out"
+		top <- fromRepo Git.repoPath
+		currdir <- liftIO R.getCurrentDirectory
+		whenM ((/=) <$> liftIO (absPath top) <*> liftIO (absPath currdir)) $
+			giveup "can only run uninit from the top of the git repository"
+	
 	current_branch = 
 		ifM (inRepo Git.Ref.headExists)
 			( Just . Git.Ref . encodeBS . Prelude.head . lines . decodeBS <$> revhead
@@ -48,65 +86,49 @@ check = do
 	revhead = inRepo $ Git.Command.pipeReadStrict
 		[Param "rev-parse", Param "--abbrev-ref", Param "HEAD"]
 
-seek :: CmdParams -> CommandSeek
-seek = withNothing $ do
-	withFilesNotInGit
-		(CheckGitIgnore False)
-		(WarnUnmatchWorkTreeItems "uninit")
-		checksymlinks
-		=<< workTreeItems ww []
-	withFilesInGitAnnex ww (Command.Unannex.seeker True)
-		=<< workTreeItems ww []
-	finish
-  where
-	ww = WarnUnmatchLsFiles "uninit"
-	checksymlinks (_, f) = 
-		commandAction $ lookupKey f >>= \case
-			Nothing -> stop
-			Just k -> startCheckIncomplete (fromRawFilePath f) k
-
 {- git annex symlinks that are not checked into git could be left by an
  - interrupted add. -}
-startCheckIncomplete :: FilePath -> Key -> CommandStart
-startCheckIncomplete file _ = giveup $ unlines
-	[ file ++ " points to annexed content, but is not checked into git."
-	, "Perhaps this was left behind by an interrupted git annex add?"
-	, "Not continuing with uninit; either delete or git annex add the file and retry."
-	]
+startCheckIncomplete :: Annex () -> RawFilePath -> Key -> CommandStart
+startCheckIncomplete recordnotok file key =
+	starting "uninit check" (mkActionItem (file, key)) (SeekInput []) $ do
+		recordnotok
+		giveup $ unlines err
+  where
+	err =
+		[ fromRawFilePath file ++ " points to annexed content, but is not checked into git."
+		, "Perhaps this was left behind by an interrupted git annex add?"
+		, "Not continuing with uninit; either delete or git annex add the file and retry."
+		]
 
-finish :: Annex ()
-finish = do
+removeAnnexDir :: CommandCleanup -> CommandStart
+removeAnnexDir recordok = do
 	Annex.Queue.flush
 	annexdir <- fromRawFilePath <$> fromRepo gitAnnexDir
 	annexobjectdir <- fromRepo gitAnnexObjectDir
-	leftovers <- removeUnannexed =<< listKeys InAnnex
-	prepareRemoveAnnexDir annexdir
-	if null leftovers
-		then liftIO $ removeDirectoryRecursive annexdir
-		else giveup $ unlines
-			[ "Not fully uninitialized"
-			, "Some annexed data is still left in " ++ fromRawFilePath annexobjectdir
-			, "This may include deleted files, or old versions of modified files."
-			, ""
-			, "If you don't care about preserving the data, just delete the"
-			, "directory."
-			, ""
-			, "Or, you can move it to another location, in case it turns out"
-			, "something in there is important."
-			, ""
-			, "Or, you can run `git annex unused` followed by `git annex dropunused`"
-			, "to remove data that is not used by any tag or branch, which might"
-			, "take care of all the data."
-			, ""
-			, "Then run `git annex uninit` again to finish."
-			]
-	uninitialize
-	-- avoid normal shutdown
-	saveState False
-	whenM (inRepo $ Git.Ref.exists Annex.Branch.fullname) $
-		inRepo $ Git.Command.run
-			[Param "branch", Param "-D", Param $ Git.fromRef Annex.Branch.name]
-	liftIO exitSuccess
+	starting ("uninit objects") (ActionItemOther (Just (QuotedPath annexobjectdir))) (SeekInput []) $ do
+		leftovers <- removeUnannexed =<< listKeys InAnnex
+		prepareRemoveAnnexDir annexdir
+		if null leftovers
+			then do
+				liftIO $ removeDirectoryRecursive annexdir
+				next recordok
+			else giveup $ unlines
+				[ "Not fully uninitialized"
+				, "Some annexed data is still left in " ++ fromRawFilePath annexobjectdir
+				, "This may include deleted files, or old versions of modified files."
+				, ""
+				, "If you don't care about preserving the data, just delete the"
+				, "directory."
+				, ""
+				, "Or, you can move it to another location, in case it turns out"
+				, "something in there is important."
+				, ""
+				, "Or, you can run `git annex unused` followed by `git annex dropunused`"
+				, "to remove data that is not used by any tag or branch, which might"
+				, "take care of all the data."
+				, ""
+				, "Then run `git annex uninit` again to finish."
+				]
 
 {- Turn on write bits in all remaining files in the annex directory, in
  - preparation for removal. 
@@ -140,3 +162,17 @@ removeUnannexed = go []
 	enoughlinks f = catchBoolIO $ do
 		s <- R.getFileStatus f
 		return $ linkCount s > 1
+
+completeUnitialize :: CommandCleanup -> CommandStart
+completeUnitialize recordok =
+	starting ("uninit finish") (ActionItemOther Nothing) (SeekInput []) $ do
+		uninitialize
+		removeAnnexBranch
+		next recordok
+
+removeAnnexBranch :: Annex ()
+removeAnnexBranch = do
+	-- avoid normal shutdown commit to the branch
+	saveState False
+	whenM (inRepo $ Git.Ref.exists Annex.Branch.fullname) $
+		inRepo $ Git.Branch.delete Annex.Branch.name

Types/Command.hs

@@ -24,7 +24,7 @@ import Types.ActionItem
 type CommandParser = Parser CommandSeek
 {- b. The check stage runs checks, that error out if
  -    anything prevents the command from running. -}
-data CommandCheck = CommandCheck { idCheck :: Int, runCheck :: Annex () }
+data CommandCheck = CommandCheck { idCheck :: CommandCheckId, runCheck :: Annex () }
 {- c. The seek stage is passed input from the parser, looks through
  -    the repo to find things to act on (ie, new files to add), and
  -    runs commandAction to handle all necessary actions. -}
@@ -136,3 +136,10 @@ descSection SectionAddOn = "Addon commands"
 
 newtype DryRun = DryRun Bool
 	deriving (Show)
+
+data CommandCheckId 
+	= CheckNotBareRepo
+	| RepoExists
+	| NoDaemonRunning
+	| GitAnnexShellOk
+	deriving (Show, Ord, Eq)

doc/git-annex-uninit.mdwn

@@ -14,7 +14,17 @@ git repository plus the previously annexed files.
 
 # OPTIONS
 
-* The [[git-annex-common-options]](1) can be used.
+* `--json`
+
+  Enable JSON output. This is intended to be parsed by programs that use
+  git-annex. Each line of output is a JSON object.
+
+* `--json-error-messages`
+
+  Messages that would normally be output to standard error are included in
+  the JSON instead.
+
+* Also the [[git-annex-common-options]](1) can be used.
 
 # SEE ALSO
 

doc/todo/--json_for_unannex__and_ideally_any_other_command_.mdwn

@@ -42,12 +42,10 @@ These commands have been updated to support --json:
 * git-annex-initremote
 * git-annex-enableremote
 * git-annex-configremote
+* git-annex-uninit
 
 These commands could support json, but I punted:
 
-* git-annex-uninit (hard to support --json-error-messages because it does
-  pre-check and post-unannex things that are not usual actions and so would
-  not show as json objects without more work)
 * git-annex-version (--raw already exists, and the output is fairly machine
   parseable already. It would be possible to jsonize the output to make it
   possibly more machine parseable. But I'm doubtful that would be useful.