add "input" field to json output

The use case of this field is mostly to support -J combined with --json.
When that is implemented, a user will be able to look at the field to
determine which of the requests they have sent it corresponds to.

The field typically has a single value in its list, but in some cases
mutliple values (eg 2 command-line params) are combined together and the
list will have more.

Note that json parsing was already non-strict, so old git-annex metadata
--json --batch can be fed json produced by the new git-annex and will
not stumble over the new field.

Assistant/Threads/Committer.hs

@@ -24,6 +24,7 @@ import Utility.ThreadScheduler
 import qualified Utility.Lsof as Lsof
 import qualified Utility.DirWatcher as DirWatcher
 import Types.KeySource
+import Types.Command
 import Config
 import Annex.Content
 import Annex.Ingest
@@ -286,7 +287,7 @@ handleAdds lockdowndir havelsof delayadd cs = returnWhen (null incomplete) $ do
 	  	ks = keySource ld
 		doadd = sanitycheck ks $ do
 			(mkey, _mcache) <- liftAnnex $ do
-				showStart "add" $ keyFilename ks
+				showStart "add" (keyFilename ks) (SeekInput [])
 				ingest nullMeterUpdate (Just $ LockedDown lockdownconfig ks) Nothing
 			maybe (failedingest change) (done change $ fromRawFilePath $ keyFilename ks) mkey
 	add _ _ = return Nothing

CHANGELOG

@@ -1,7 +1,7 @@
 git-annex (8.20200909) UNRELEASED; urgency=medium
 
   * --json output now includes a new field "input" which is the input
-    (filename, url, etc) that caused that json to be output.
+    value (filename, url, etc) that caused a json object to be output.
 
  -- Joey Hess <id@joeyh.name>  Mon, 14 Sep 2020 13:13:10 -0400
 

Command/Config.hs

@@ -72,7 +72,7 @@ seek (UnsetConfig ck@(ConfigKey name)) = checkIsGlobalConfig ck $ commandAction
   where
 	ai = ActionItemOther (Just "unset")
 	si = SeekInput [decodeBS' name]
-seek (GetConfig ck@(ConfigKey name)) = checkIsGlobalConfig ck $ commandAction $
+seek (GetConfig ck) = checkIsGlobalConfig ck $ commandAction $
 	startingCustomOutput ai $ do
 		getGlobalConfig ck >>= \case
 			Just (ConfigValue v) -> liftIO $ S8.putStrLn v

Command/FuzzTest.hs

@@ -36,7 +36,7 @@ start :: CommandStart
 start = do
 	guardTest
 	logf <- fromRepo gitAnnexFuzzTestLogFile
-	showStart "fuzztest" (toRawFilePath logf)
+	showStart "fuzztest" (toRawFilePath logf) (SeekInput [])
 	logh <- liftIO $ openFile logf WriteMode
 	void $ forever $ fuzz logh
 	stop

Command/ImportFeed.hs

@@ -78,7 +78,7 @@ seek o = do
 
 getFeed :: AddUnlockedMatcher -> ImportFeedOptions -> Cache -> URLString -> CommandSeek
 getFeed addunlockedmatcher opts cache url = do
-	showStart' "importfeed" (Just url)
+	showStartOther "importfeed" (Just url) (SeekInput [])
 	downloadFeed url >>= \case
 		Nothing -> showEndResult =<< feedProblem url
 			"downloading the feed failed"
@@ -124,7 +124,7 @@ getCache :: Maybe String -> Annex Cache
 getCache opttemplate = ifM (Annex.getState Annex.force)
 	( ret S.empty S.empty
 	, do
-		showStart "importfeed" "checking known urls"
+		showStart "importfeed" "checking known urls" (SeekInput [])
 		(is, us) <- unzip <$> knownItems
 		showEndOk
 		ret (S.fromList us) (S.fromList (concat is))
@@ -256,7 +256,7 @@ performDownload addunlockedmatcher opts cache todownload = case location todownl
 		case dest of
 			Nothing -> return True
 			Just f -> do
-				showStart' "addurl" (Just url)
+				showStartOther "addurl" (Just url) (SeekInput [])
 				ks <- getter f
 				if null ks
 					then do

Command/Info.hs

@@ -1,6 +1,6 @@
 {- git-annex command
  -
- - Copyright 2011-2016 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -135,34 +135,34 @@ globalInfo o = do
 	whenM ((==) DeadTrusted <$> lookupTrust u) $
 		earlyWarning "Warning: This repository is currently marked as dead."
 	stats <- selStats global_fast_stats global_slow_stats
-	showCustom "info" $ do
+	showCustom "info" (SeekInput []) $ do
 		evalStateT (mapM_ showStat stats) (emptyStatInfo o)
 		return True
 
 itemInfo :: InfoOptions -> (SeekInput, String) -> Annex ()
-itemInfo o (_, p) = ifM (isdir p)
+itemInfo o (si, p) = ifM (isdir p)
-	( dirInfo o p
+	( dirInfo o p si
 	, do
 		disallowMatchingOptions
 		v <- Remote.byName' p
 		case v of
-			Right r -> remoteInfo o r
+			Right r -> remoteInfo o r si
 			Left _ -> do
 				v' <- Remote.nameToUUID' p
 				case v' of
-					Right u -> uuidInfo o u
+					Right u -> uuidInfo o u si
 					Left _ -> do
 						relp <- liftIO $ relPathCwdToFile p
 						ifAnnexed (toRawFilePath relp)
-							(fileInfo o relp)
+							(fileInfo o relp si)
-							(treeishInfo o p)
+							(treeishInfo o p si)
 	)
   where
 	isdir = liftIO . catchBoolIO . (isDirectory <$$> getFileStatus)
 
-noInfo :: String -> Annex ()
+noInfo :: String -> SeekInput -> Annex ()
-noInfo s = do
+noInfo s si = do
-	showStart "info" (encodeBS' s)
+	showStart "info" (encodeBS' s) si
 	showNote $ "not a directory or an annexed file or a treeish or a remote or a uuid"
 	showEndFail
 
@@ -170,8 +170,8 @@ disallowMatchingOptions :: Annex ()
 disallowMatchingOptions = whenM Limit.limited $
 	giveup "File matching options can only be used when getting info on a directory."
 
-dirInfo :: InfoOptions -> FilePath -> Annex ()
+dirInfo :: InfoOptions -> FilePath -> SeekInput -> Annex ()
-dirInfo o dir = showCustom (unwords ["info", dir]) $ do
+dirInfo o dir si = showCustom (unwords ["info", dir]) si $ do
 	stats <- selStats
 		(tostats (dir_name:tree_fast_stats True))
 		(tostats tree_slow_stats)
@@ -180,12 +180,12 @@ dirInfo o dir = showCustom (unwords ["info", dir]) $ do
   where
 	tostats = map (\s -> s dir)
 
-treeishInfo :: InfoOptions -> String -> Annex ()
+treeishInfo :: InfoOptions -> String -> SeekInput -> Annex ()
-treeishInfo o t = do
+treeishInfo o t si = do
 	mi <- getTreeStatInfo o (Git.Ref (encodeBS' t))
 	case mi of
-		Nothing -> noInfo t
+		Nothing -> noInfo t si
-		Just i -> showCustom (unwords ["info", t]) $ do
+		Just i -> showCustom (unwords ["info", t]) si $ do
 			stats <- selStats 
 				(tostats (tree_name:tree_fast_stats False)) 
 				(tostats tree_slow_stats)
@@ -194,13 +194,13 @@ treeishInfo o t = do
   where
 	tostats = map (\s -> s t)
 
-fileInfo :: InfoOptions -> FilePath -> Key -> Annex ()
+fileInfo :: InfoOptions -> FilePath -> SeekInput -> Key -> Annex ()
-fileInfo o file k = showCustom (unwords ["info", file]) $ do
+fileInfo o file si k = showCustom (unwords ["info", file]) si $ do
 	evalStateT (mapM_ showStat (file_stats file k)) (emptyStatInfo o)
 	return True
 
-remoteInfo :: InfoOptions -> Remote -> Annex ()
+remoteInfo :: InfoOptions -> Remote -> SeekInput -> Annex ()
-remoteInfo o r = showCustom (unwords ["info", Remote.name r]) $ do
+remoteInfo o r si = showCustom (unwords ["info", Remote.name r]) si $ do
 	i <- map (\(k, v) -> simpleStat k (pure v)) <$> Remote.getInfo r
 	let u = Remote.uuid r
 	l <- selStats 
@@ -209,8 +209,8 @@ remoteInfo o r = showCustom (unwords ["info", Remote.name r]) $ do
 	evalStateT (mapM_ showStat l) (emptyStatInfo o)
 	return True
 
-uuidInfo :: InfoOptions -> UUID -> Annex ()
+uuidInfo :: InfoOptions -> UUID -> SeekInput -> Annex ()
-uuidInfo o u = showCustom (unwords ["info", fromUUID u]) $ do
+uuidInfo o u si = showCustom (unwords ["info", fromUUID u]) si $ do
 	l <- selStats (uuid_fast_stats u) (uuid_slow_stats u)
 	evalStateT (mapM_ showStat l) (emptyStatInfo o)
 	return True

Command/List.hs

@@ -78,7 +78,7 @@ printHeader :: [(UUID, RemoteName, TrustLevel)] -> Annex ()
 printHeader l = liftIO $ putStrLn $ lheader $ map (\(_, n, t) -> (n, t)) l
 
 start :: [(UUID, RemoteName, TrustLevel)] -> SeekInput -> RawFilePath -> Key -> CommandStart
-start l si file key = do
+start l _si file key = do
 	ls <- S.fromList <$> keyLocations key
 	liftIO $ putStrLn $ format (map (\(u, _, t) -> (t, S.member u ls)) l) file
 	stop

Command/Map.hs

@@ -197,7 +197,7 @@ same a b
 {- reads the config of a remote, with progress display -}
 scan :: Git.Repo -> Annex Git.Repo
 scan r = do
-	showStart' "map" (Just $ Git.repoDescribe r)
+	showStartOther "map" (Just $ Git.repoDescribe r) (SeekInput [])
 	v <- tryScan r
 	case v of
 		Just r' -> do

Messages.hs

@@ -9,7 +9,7 @@
 
 module Messages (
 	showStart,
-	showStart',
+	showStartOther,
 	showStartMessage,
 	showEndMessage,
 	StartMessage(..),
@@ -64,39 +64,39 @@ import Types
 import Types.Messages
 import Types.ActionItem
 import Types.Concurrency
-import Types.Command (StartMessage(..))
+import Types.Command (StartMessage(..), SeekInput)
 import Types.Transfer (transferKey)
 import Messages.Internal
 import Messages.Concurrent
 import qualified Messages.JSON as JSON
 import qualified Annex
 
-showStart :: String -> RawFilePath -> Annex ()
+showStart :: String -> RawFilePath -> SeekInput -> Annex ()
-showStart command file = outputMessage json $
+showStart command file si = outputMessage json $
 	encodeBS' command <> " " <> file <> " "
   where
-	json = JSON.start command (Just file) Nothing
+	json = JSON.start command (Just file) Nothing si
 
-showStart' :: String -> Maybe String -> Annex ()
+showStartKey :: String -> Key -> ActionItem -> SeekInput -> Annex ()
-showStart' command mdesc = outputMessage json $ encodeBS' $
+showStartKey command key ai si = outputMessage json $
+	encodeBS' command <> " " <> actionItemDesc ai <> " "
+  where
+	json = JSON.start command (actionItemWorkTreeFile ai) (Just key) si
+
+showStartOther :: String -> Maybe String -> SeekInput -> Annex ()
+showStartOther command mdesc si = outputMessage json $ encodeBS' $
 	command ++ (maybe "" (" " ++) mdesc) ++ " "
   where
-	json = JSON.start command Nothing Nothing
+	json = JSON.start command Nothing Nothing si
-
-showStartKey :: String -> Key -> ActionItem -> Annex ()
-showStartKey command key i = outputMessage json $
-	encodeBS' command <> " " <> actionItemDesc i <> " "
-  where
-	json = JSON.start command (actionItemWorkTreeFile i) (Just key)
 
 showStartMessage :: StartMessage -> Annex ()
 showStartMessage (StartMessage command ai si) = case ai of
-	ActionItemAssociatedFile _ k -> showStartKey command k ai
+	ActionItemAssociatedFile _ k -> showStartKey command k ai si
-	ActionItemKey k -> showStartKey command k ai
+	ActionItemKey k -> showStartKey command k ai si
-	ActionItemBranchFilePath _ k -> showStartKey command k ai
+	ActionItemBranchFilePath _ k -> showStartKey command k ai si
-	ActionItemFailedTransfer t _ -> showStartKey command (transferKey t) ai
+	ActionItemFailedTransfer t _ -> showStartKey command (transferKey t) ai si
-	ActionItemWorkTreeFile file -> showStart command file
+	ActionItemWorkTreeFile file -> showStart command file si
-	ActionItemOther msg -> showStart' command msg
+	ActionItemOther msg -> showStartOther command msg si
 	OnlyActionOn _ ai' -> showStartMessage (StartMessage command ai' si)
 showStartMessage (StartUsualMessages command ai si) = do
 	outputType <$> Annex.getState Annex.output >>= \case
@@ -238,9 +238,9 @@ showFullJSON v = withMessageState $ bufferJSON (JSON.complete v)
  - a complete JSON document.
  - This is only needed when showStart and showEndOk is not used.
  -}
-showCustom :: String -> Annex Bool -> Annex ()
+showCustom :: String -> SeekInput -> Annex Bool -> Annex ()
-showCustom command a = do
+showCustom command si a = do
-	outputMessage (JSON.start command Nothing Nothing) ""
+	outputMessage (JSON.start command Nothing Nothing si) ""
 	r <- a
 	outputMessage (JSON.end r) ""
 

Messages/JSON.hs

@@ -1,6 +1,6 @@
 {- git-annex command-line JSON output and input
  -
- - Copyright 2011-2018 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -39,6 +39,7 @@ import Data.Monoid
 import Prelude
 
 import Types.Messages
+import Types.Command (SeekInput(..))
 import Key
 import Utility.Metered
 import Utility.Percentage
@@ -64,8 +65,8 @@ type JSONBuilder = Maybe (Object, Bool) -> Maybe (Object, Bool)
 none :: JSONBuilder
 none = id
 
-start :: String -> Maybe RawFilePath -> Maybe Key -> JSONBuilder
+start :: String -> Maybe RawFilePath -> Maybe Key -> SeekInput -> JSONBuilder
-start command file key _ = case j of
+start command file key si _ = case j of
 	Object o -> Just (o, False)
 	_ -> Nothing
   where
@@ -74,6 +75,7 @@ start command file key _ = case j of
 		, itemKey = key
 		, itemFile = fromRawFilePath <$> file
 		, itemAdded = Nothing
+		, itemSeekInput = si
 		}
 
 end :: Bool -> JSONBuilder
@@ -176,6 +178,7 @@ data JSONActionItem a = JSONActionItem
 	, itemKey :: Maybe Key
 	, itemFile :: Maybe FilePath
 	, itemAdded :: Maybe a -- for additional fields added by `add`
+	, itemSeekInput :: SeekInput
 	}
 	deriving (Show)
 
@@ -183,10 +186,11 @@ instance ToJSON' (JSONActionItem a) where
 	toJSON' i = object $ catMaybes
 		[ Just $ "command" .= itemCommand i
 		, case itemKey i of
-			Nothing -> Nothing
 			Just k -> Just $ "key" .= toJSON' k
+			Nothing -> Nothing
 		, Just $ "file" .= toJSON' (itemFile i)
 		-- itemAdded is not included; must be added later by 'add'
+		, Just $ "input" .= fromSeekInput (itemSeekInput i)
 		]
 
 instance FromJSON a => FromJSON (JSONActionItem a) where
@@ -195,6 +199,7 @@ instance FromJSON a => FromJSON (JSONActionItem a) where
 		<*> (maybe (return Nothing) parseJSON =<< (v .:? "key"))
 		<*> (v .:? "file")
 		<*> parseadded
+		<*> pure (SeekInput [])
 	  where
 		parseadded = (Just <$> parseJSON (Object v)) <|> return Nothing
 	parseJSON _ = mempty

Types/Command.hs

@@ -40,7 +40,7 @@ type CommandCleanup = Annex Bool
 
 {- Input that was seeked on to make an ActionItem. Eg, the input filename,
  - or directory name. -}
-newtype SeekInput = SeekInput [String]
+newtype SeekInput = SeekInput { fromSeekInput :: [String] }
 	deriving (Show)
 
 {- Message that is displayed when starting to perform an action on