json object for FileNotFound

When a nonexistant file is passed to a command and  --json-error-messages
is enabled, output a JSON object indicating the problem.

(But git ls-files --error-unmatch still displays errors about such files in
some situations.)

I don't like the duplication of the name of the command introduced by this,
but I can't see a great way around it. One way would be to pass the Command
instead.

When json is not enabled, the stderr is unchanged. This is necessary
because some commands like find have custom output. So dislaying
"find foo not found" would be wrong. So had to complicate things with
toplevelFileProblem having different output with and without json.

When not using --json-error-messages but still using --json, it displays
the error to stderr, but does display a json object without the error. It
does have an errorid though. Unsure how useful that behavior is.

Sponsored-by: Dartmouth College's Datalad project

CHANGELOG

@@ -25,6 +25,10 @@ git-annex (10.20230408) UNRELEASED; urgency=medium
   * assistant --autostop: Avoid crashing when ~/.config/git-annex/autostart
     lists a directory that it cannot chdir to.
   * Honor --force option when operating on a local git remote.
+  * When a nonexistant file is passed to a command and 
+    --json-error-messages is enabled, output a JSON object indicating the
+    problem. (But git ls-files --error-unmatch still displays errors about
+    such files in some situations.)
 
  -- Joey Hess <id@joeyh.name>  Sat, 08 Apr 2023 13:57:18 -0400
 

CmdLine/Seek.hs

@@ -147,9 +147,9 @@ withPairs a params = sequence_ $
 	pairs c (x:y:xs) = pairs ((x,y):c) xs
 	pairs _ _ = giveup "expected pairs"
 
-withFilesToBeCommitted :: ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
+withFilesToBeCommitted :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek
-withFilesToBeCommitted a l = seekFiltered (const (pure True)) a $
+withFilesToBeCommitted ww a l = seekFiltered (const (pure True)) a $
-	seekHelper id WarnUnmatchWorkTreeItems (const LsFiles.stagedNotDeleted) l
+	seekHelper id ww (const LsFiles.stagedNotDeleted) l
 
 {- unlocked pointer files that are staged, and whose content has not been
  - modified-}
@@ -512,15 +512,15 @@ seekHelper c ww a (WorkTreeItems l) = do
 		and <$> sequence cleanups
 seekHelper _ _ _ NoWorkTreeItems = return ([], pure True)
 
-data WarnUnmatchWhen = WarnUnmatchLsFiles | WarnUnmatchWorkTreeItems
+data WarnUnmatchWhen = WarnUnmatchLsFiles String | WarnUnmatchWorkTreeItems String
 
 seekOptions :: WarnUnmatchWhen -> Annex [LsFiles.Options]
-seekOptions WarnUnmatchLsFiles =
+seekOptions (WarnUnmatchLsFiles _) =
 	ifM (annexSkipUnknown <$> Annex.getGitConfig)
 		( return [] 
 		, return [LsFiles.ErrorUnmatch]
 		)
-seekOptions WarnUnmatchWorkTreeItems = return []
+seekOptions (WarnUnmatchWorkTreeItems _) = return []
 
 -- Items in the work tree, which may be files or directories.
 data WorkTreeItems
@@ -554,23 +554,23 @@ workTreeItems = workTreeItems' (AllowHidden False)
 
 workTreeItems' :: AllowHidden -> WarnUnmatchWhen -> CmdParams -> Annex WorkTreeItems
 workTreeItems' (AllowHidden allowhidden) ww ps = case ww of
-	WarnUnmatchWorkTreeItems -> runcheck
+	(WarnUnmatchWorkTreeItems action) -> runcheck action
-	WarnUnmatchLsFiles -> 
+	(WarnUnmatchLsFiles action) -> 
 		ifM (annexSkipUnknown <$> Annex.getGitConfig)
-			( runcheck
+			( runcheck action
 			, return $ WorkTreeItems ps
 			)
   where
-	runcheck = do
+	runcheck action = do
 		currbranch <- getCurrentBranch
 		stopattop <- prepviasymlink
 		ps' <- flip filterM ps $ \p -> do
 			let p' = toRawFilePath p
 			relf <- liftIO $ relPathCwdToFile p'
 			ifM (not <$> (exists p' <||> hidden currbranch relf))
-				( prob (QuotedPath (toRawFilePath p) <> " not found")
+				( prob action FileNotFound p' "not found"
 				, ifM (viasymlink stopattop (upFrom relf))
-					( prob (QuotedPath (toRawFilePath p) <> " is beyond a symbolic link")
+					( prob action FileBeyondSymbolicLink p' "is beyond a symbolic link"
 					, return True
 					)
 				)
@@ -605,8 +605,8 @@ workTreeItems' (AllowHidden allowhidden) ww ps = case ww of
 			<$> catObjectMetaDataHidden f currbranch
 		| otherwise = return False
 
-	prob msg = do
+	prob action errorid p msg = do
-		toplevelWarning False msg
+		toplevelFileProblem False errorid msg action p Nothing (SeekInput [fromRawFilePath p])
 		Annex.incError
 		return False
 	

Command/Add.hs

@@ -119,7 +119,7 @@ seek o = startConcurrency commandStages $ do
 			-- are not known to git yet, since this will add
 			-- them. Instead, have workTreeItems warn about other
 			-- problems, like files that don't exist.
-			let ww = WarnUnmatchWorkTreeItems
+			let ww = WarnUnmatchWorkTreeItems "add"
 			l <- workTreeItems ww (addThese o)
 			let go b a = a ww (commandAction . gofile b) l
 			unless (updateOnly o) $

Command/Copy.hs

@@ -60,7 +60,7 @@ seek' o fto = startConcurrency (Command.Move.stages fto) $ do
 		Batch fmt -> batchOnly (keyOptions o) (copyFiles o) $
 			batchAnnexed fmt seeker keyaction
   where
-	ww = WarnUnmatchLsFiles
+	ww = WarnUnmatchLsFiles "copy"
 	
 	seeker = AnnexedFileSeeker
 		{ startAction = start o fto

Command/Drop.hs

@@ -74,7 +74,7 @@ seek o = startConcurrency commandStages $ do
 		Batch fmt -> batchOnly (keyOptions o) (dropFiles o) $
 			batchAnnexed fmt seeker (startKeys o from)
   where
-	ww = WarnUnmatchLsFiles
+	ww = WarnUnmatchLsFiles "drop"
 
 start :: DropOptions -> Maybe Remote -> SeekInput -> RawFilePath -> Key -> CommandStart
 start o from si file key = start' o from key afile ai si

Command/FilterBranch.hs

@@ -192,4 +192,4 @@ seek o = withOtherTmp $ \tmpdir -> do
 	c <- inRepo $ Git.commitTree cmode cmessage [] t
 	liftIO $ putStrLn (fromRef c)
   where
-	ww = WarnUnmatchLsFiles
+	ww = WarnUnmatchLsFiles "filter-branch"

Command/Find.hs

@@ -75,7 +75,7 @@ seek o = do
 		Batch fmt -> batchOnly (keyOptions o) (findThese o) $
 			batchAnnexedFiles fmt seeker
   where
-	ww = WarnUnmatchLsFiles
+	ww = WarnUnmatchLsFiles "find"
 
 -- Default to needing content to be present, but if the user specified a
 -- limit, content does not need to be present.

Command/Fix.hs

@@ -35,7 +35,7 @@ seek :: CmdParams -> CommandSeek
 seek ps = unlessM crippledFileSystem $
 	withFilesInGitAnnex ww seeker =<< workTreeItems ww ps
   where
-	ww = WarnUnmatchLsFiles
+	ww = WarnUnmatchLsFiles "fix"
 	seeker = AnnexedFileSeeker
 		{ startAction = start FixAll
 		, checkContentPresent = Nothing

Command/Fsck.hs

@@ -113,7 +113,7 @@ seek o = startConcurrency commandStages $ do
 	cleanupIncremental i
 	void $ tryIO $ recordActivity Fsck u
   where
-	ww = WarnUnmatchLsFiles
+	ww = WarnUnmatchLsFiles "fsck"
 
 checkDeadRepo :: UUID -> Annex ()
 checkDeadRepo u =

Command/Get.hs

@@ -53,7 +53,7 @@ seek o = startConcurrency transferStages $ do
 		Batch fmt -> batchOnly (keyOptions o) (getFiles o) $
 			batchAnnexed fmt seeker (startKeys from)
   where
-	ww = WarnUnmatchLsFiles
+	ww = WarnUnmatchLsFiles "get"
 
 start :: GetOptions -> Maybe Remote -> SeekInput -> RawFilePath -> Key -> CommandStart
 start o from si file key = start' expensivecheck from key afile ai si

Command/Inprogress.hs

@@ -49,7 +49,7 @@ seek o = do
 			withFilesInGitAnnex ww seeker
 				=<< workTreeItems ww (inprogressFiles o)
   where
-	ww = WarnUnmatchLsFiles
+	ww = WarnUnmatchLsFiles "inprogress"
 
 start :: IsTerminal -> S.Set Key -> SeekInput -> RawFilePath -> Key -> CommandStart
 start isterminal s _si _file k

Command/List.hs

@@ -56,7 +56,7 @@ seek o = do
 		}
 	withFilesInGitAnnex ww seeker =<< workTreeItems ww (listThese o)
   where
-	ww = WarnUnmatchLsFiles
+	ww = WarnUnmatchLsFiles "list"
 
 getList :: ListOptions -> Annex [(UUID, RemoteName, TrustLevel)]
 getList o

Command/Lock.hs

@@ -32,7 +32,7 @@ cmd = withAnnexOptions [jsonOptions, annexedMatchingOptions] $
 seek :: CmdParams -> CommandSeek
 seek ps = withFilesInGitAnnex ww seeker =<< workTreeItems ww ps
   where
-	ww = WarnUnmatchLsFiles
+	ww = WarnUnmatchLsFiles "lock"
 	seeker = AnnexedFileSeeker
 		{ startAction = start
 		, checkContentPresent = Nothing

Command/Log.hs

@@ -105,7 +105,7 @@ seek o = ifM (null <$> Annex.Branch.getUnmergedRefs)
 	, giveup "This repository is read-only, and there are unmerged git-annex branches, which prevents displaying location log changes. (Set annex.merge-annex-branches to false to ignore the unmerged git-annex branches.)"
 	)
   where
-	ww = WarnUnmatchLsFiles
+	ww = WarnUnmatchLsFiles "log"
 
 start :: LogOptions -> (FilePath -> Outputter) -> SeekInput -> RawFilePath -> Key -> CommandStart
 start o outputter _ file key = do

Command/MetaData.hs

@@ -76,7 +76,7 @@ seek :: MetaDataOptions -> CommandSeek
 seek o = case batchOption o of
 	NoBatch -> do
 		c <- currentVectorClock
-		let ww = WarnUnmatchLsFiles
+		let ww = WarnUnmatchLsFiles "metadata"
 		let seeker = AnnexedFileSeeker
 			{ startAction = start c o
 			, checkContentPresent = Nothing

Command/Migrate.hs

@@ -41,7 +41,7 @@ optParser desc = MigrateOptions
 seek :: MigrateOptions -> CommandSeek
 seek o = withFilesInGitAnnex ww seeker =<< workTreeItems ww (migrateThese o)
   where
-	ww = WarnUnmatchLsFiles
+	ww = WarnUnmatchLsFiles "migrate"
 	seeker = AnnexedFileSeeker
 		{ startAction = start o
 		, checkContentPresent = Nothing

Command/Mirror.hs

@@ -50,7 +50,7 @@ seek o = startConcurrency stages $
 	stages = case fromToOptions o of
 		FromRemote _ -> transferStages
 		ToRemote _ -> commandStages
-	ww = WarnUnmatchLsFiles
+	ww = WarnUnmatchLsFiles "mirror"
 	seeker = AnnexedFileSeeker
 		{ startAction = start o
 		, checkContentPresent = Nothing

Command/Move.hs

@@ -84,7 +84,7 @@ seek' o fto = startConcurrency (stages fto) $ do
 		, usesLocationLog = True
 		}
 	keyaction = startKey fto (removeWhen o)
-	ww = WarnUnmatchLsFiles
+	ww = WarnUnmatchLsFiles "move"
 
 stages :: FromToHereOptions -> UsedStages
 stages (FromOrToRemote (FromRemote _)) = transferStages

Command/Multicast.hs

@@ -131,7 +131,7 @@ send ups fs = do
 	-- expensive.
 	starting "sending files" (ActionItemOther Nothing) (SeekInput []) $
 		withTmpFile "send" $ \t h -> do
-			let ww = WarnUnmatchLsFiles
+			let ww = WarnUnmatchLsFiles "multicast"
 			(fs', cleanup) <- seekHelper id ww LsFiles.inRepo
 				=<< workTreeItems ww fs
 			matcher <- Limit.getMatcher

Command/PreCommit.hs

@@ -32,10 +32,10 @@ cmd = command "pre-commit" SectionPlumbing
 
 seek :: CmdParams -> CommandSeek
 seek ps = do
-	let ww = WarnUnmatchWorkTreeItems
+	let ww = WarnUnmatchWorkTreeItems "pre-commit"
 	l <- workTreeItems ww ps
 	-- fix symlinks to files being committed
-	flip withFilesToBeCommitted l $ \(si, f) -> commandAction $
+	flip (withFilesToBeCommitted ww) l $ \(si, f) -> commandAction $
 		maybe stop (Command.Fix.start Command.Fix.FixSymlinks si f)
 			=<< isAnnexLink f
 	-- after a merge conflict or git cherry-pick or stash, pointer

Command/Sync.hs

@@ -794,7 +794,7 @@ seekSyncContent o rs currbranch = do
 		in seekFiltered (const (pure True)) filterer $
 			seekHelper id ww (LsFiles.inRepoOrBranch origbranch) l 
 
-	ww = WarnUnmatchLsFiles
+	ww = WarnUnmatchLsFiles "sync"
 
 	gofile bloom mvar _ f k = 
 		go (Right bloom) mvar (AssociatedFile (Just f)) k

Command/Unannex.hs

@@ -30,7 +30,7 @@ cmd = withAnnexOptions [annexedMatchingOptions] $
 seek :: CmdParams -> CommandSeek
 seek ps = withFilesInGitAnnex ww (seeker False) =<< workTreeItems ww ps
   where
-	ww = WarnUnmatchLsFiles
+	ww = WarnUnmatchLsFiles "unannex"
 
 seeker :: Bool -> AnnexedFileSeeker
 seeker fast = AnnexedFileSeeker

Command/Uninit.hs

@@ -53,13 +53,13 @@ seek ps = do
 	l <- workTreeItems ww ps
 	withFilesNotInGit
 		(CheckGitIgnore False)
-		WarnUnmatchWorkTreeItems
+		(WarnUnmatchWorkTreeItems "uninit")
 		checksymlinks
 		l
 	withFilesInGitAnnex ww (Command.Unannex.seeker True) l
 	finish
   where
-	ww = WarnUnmatchLsFiles
+	ww = WarnUnmatchLsFiles "uninit"
 	checksymlinks (_, f) = 
 		commandAction $ lookupKey f >>= \case
 			Nothing -> stop

Command/Unlock.hs

@@ -33,7 +33,7 @@ mkcmd n d = withAnnexOptions [jsonOptions, annexedMatchingOptions] $
 seek :: CmdParams -> CommandSeek
 seek ps = withFilesInGitAnnex ww seeker =<< workTreeItems ww ps
   where
-	ww = WarnUnmatchLsFiles
+	ww = WarnUnmatchLsFiles "unlock"
 	seeker = AnnexedFileSeeker
 		{ startAction = start
 		, checkContentPresent = Nothing

Command/Whereis.hs

@@ -64,7 +64,7 @@ seek o = do
 		Batch fmt -> batchOnly (keyOptions o) (whereisFiles o) $
 			batchAnnexed fmt seeker (startKeys o m)
   where
-	ww = WarnUnmatchLsFiles
+	ww = WarnUnmatchLsFiles "whereis"
 
 start :: WhereisOptions -> M.Map UUID Remote -> SeekInput -> RawFilePath -> Key -> CommandStart
 start o remotemap si file key = 

Messages.hs

@@ -27,6 +27,8 @@ module Messages (
 	showEndFail,
 	showEndResult,
 	endResult,
+	ErrorId(..),
+	toplevelFileProblem,
 	toplevelWarning,
 	warning,
 	earlyWarning,
@@ -34,6 +36,7 @@ module Messages (
 	indent,
 	JSON.JSONChunk(..),
 	maybeShowJSON,
+	maybeShowJSON',
 	showFullJSON,
 	showCustom,
 	showHeader,
@@ -197,8 +200,18 @@ endResult :: Bool -> S.ByteString
 endResult True = "ok"
 endResult False = "failed"
 
+toplevelMsg :: StringContainingQuotedPath -> StringContainingQuotedPath
+toplevelMsg = ("git-annex: " <>)
+
+toplevelFileProblem :: Bool -> ErrorId -> StringContainingQuotedPath -> String -> RawFilePath -> Maybe Key -> SeekInput -> Annex ()
+toplevelFileProblem makeway errorid msg action file mkey si = do
+	maybeShowJSON' $ JSON.start action (Just file) mkey si
+	maybeShowJSON' $ JSON.errorid errorid
+	warning' makeway id (toplevelMsg (QuotedPath file <> " " <> msg))
+	maybeShowJSON' $ JSON.end False
+
 toplevelWarning :: Bool -> StringContainingQuotedPath -> Annex ()
-toplevelWarning makeway s = warning' makeway id ("git-annex: " <> s)
+toplevelWarning makeway s = warning' makeway id (toplevelMsg s)
 
 warning :: StringContainingQuotedPath -> Annex ()
 warning = warning' True indent
@@ -207,10 +220,10 @@ earlyWarning :: StringContainingQuotedPath -> Annex ()
 earlyWarning = warning' False id
 
 warning' :: Bool -> (S.ByteString -> S.ByteString) -> StringContainingQuotedPath -> Annex ()
-warning' makeway consolewhitespacef w = do
+warning' makeway consolewhitespacef msg = do
 	when makeway $
 		outputMessage JSON.none id "\n"
-	outputError (\s -> consolewhitespacef s <> "\n") w
+	outputError (\s -> consolewhitespacef s <> "\n") msg
 
 {- Not concurrent output safe. -}
 warningIO :: String -> IO ()
@@ -226,6 +239,9 @@ indent = S.intercalate "\n" . map ("  " <>) . S8.lines
 maybeShowJSON :: JSON.JSONChunk v -> Annex ()
 maybeShowJSON v = void $ withMessageState $ bufferJSON (JSON.add v)
 
+maybeShowJSON' :: JSON.JSONBuilder -> Annex ()
+maybeShowJSON' v = void $ withMessageState $ bufferJSON v
+
 {- Shows a complete JSON value, only when in json mode. -}
 showFullJSON :: JSON.JSONChunk v -> Annex Bool
 showFullJSON v = withMessageState $ bufferJSON (JSON.complete v)

Messages/JSON.hs

@@ -20,6 +20,7 @@ module Messages.JSON (
 	addErrorMessage,
 	note,
 	info,
+	errorid,
 	add,
 	complete,
 	progress,
@@ -51,6 +52,7 @@ import Utility.Metered
 import Utility.Percentage
 import Utility.Aeson
 import Utility.FileSystemEncoding
+import Types.Messages
 
 -- A global lock to avoid concurrent threads emitting json at the same time.
 {-# NOINLINE emitLock #-}
@@ -68,7 +70,8 @@ emit' b = do
 	putMVar emitLock ()
 
 -- Building up a JSON object can be done by first using start,
--- then add and note any number of times, and finally complete.
+-- then add and note and errorid any number of times, and finally
+-- complete.
 type JSONBuilder = Maybe (Object, Bool) -> Maybe (Object, Bool)
 
 none :: JSONBuilder
@@ -112,6 +115,12 @@ note s (Just (o, e)) = Just (HM.unionWith combinelines (HM.singleton "note" (toJ
 		String (old <> "\n" <> new)
 	combinelines new _old = new
 
+errorid :: ErrorId -> JSONBuilder
+errorid _ Nothing = Nothing
+errorid eid (Just (o, e)) = Just (HM.unionWith replaceold (HM.singleton "errorid" (toJSON' (show eid))) o, e)
+  where
+	replaceold new _old = new
+
 info :: String -> JSONBuilder
 info s _ = case j of
 	Object o -> Just (o, True)

Types/Messages.hs

@@ -84,3 +84,9 @@ data SerializedOutput
 data SerializedOutputResponse
 	= ReadyPrompt
 	deriving (Eq, Show)
+
+-- | Error identifiers. Avoid changing these.
+data ErrorId
+	= FileNotFound
+	| FileBeyondSymbolicLink
+	deriving (Show)

doc/todo/api_for_telling_when_nonexistant_or_non_git_files_passed/comment_8_2550e1760dcfb90c9c2ca1ee145adcf1._comment

@@ -0,0 +1,19 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 8"""
+ date="2023-04-25T22:45:24Z"
+ content="""
+Ok, implemented the simple alternative. Here's how it looks:
+
+	joey@darkstar:~/tmp/xxx>git-annex add 'dne' --json --json-error-messages
+	{"command":"add","error-messages":["git-annex: dne not found"],"errorid":"FileNotFound","file":"dne","input":["dne"],"success":false}
+	add: 1 failed
+
+The errorid will remain stable. I can add those to other error messages
+now, on request BTW.
+
+Note that when git-annex relies on `git ls-files --error-unmatch` to
+complain about nonexistant or non-git files, the error messages from
+git will still be displayed to stderr, not this nice json. So
+datalad will need to keep its parser for that part.
+"""]]