addurl, get: Added --json-progress option, which adds progress objects to the json output.

This doesn't work right when used with -J yet, and there is some really
ugly hand-crafting of part of the json output.

CHANGELOG

@@ -6,6 +6,8 @@ git-annex (6.20160908) UNRELEASED; urgency=medium
     over ssh etc.
   * Make --json and --quiet work when used with -J.
     Previously, -J override the other options.
+  * addurl, get: Added --json-progress option, which adds progress
+    objects to the json output.
   * Remove key:null from git-annex add --json output.
 
  -- Joey Hess <id@joeyh.name>  Thu, 08 Sep 2016 12:48:55 -0400

CmdLine/GitAnnex/Options.hs

@@ -286,12 +286,19 @@ combiningOptions =
 	shortopt o h = globalFlag (Limit.addToken [o]) ( short o <> help h <> hidden )
 
 jsonOption :: GlobalOption
-jsonOption = globalFlag (Annex.setOutput JSONOutput)
+jsonOption = globalFlag (Annex.setOutput (JSONOutput False))
 	( long "json" <> short 'j'
 	<> help "enable JSON output"
 	<> hidden
 	)
 
+jsonProgressOption :: GlobalOption
+jsonProgressOption = globalFlag (Annex.setOutput (JSONOutput True))
+	( long "json-progress" <> short 'j'
+	<> help "include progress in JSON output"
+	<> hidden
+	)
+
 -- Note that a command that adds this option should wrap its seek
 -- action in `allowConcurrentOutput`.
 jobsOption :: GlobalOption

Command/AddUrl.hs

@@ -31,7 +31,7 @@ import Annex.Quvi
 import qualified Utility.Quvi as Quvi
 
 cmd :: Command
-cmd = notBareRepo $ withGlobalOptions [jobsOption, jsonOption] $
+cmd = notBareRepo $ withGlobalOptions [jobsOption, jsonOption, jsonProgressOption] $
 	command "addurl" SectionCommon "add urls to annex"
 		(paramRepeating paramUrl) (seek <$$> optParser)
 

Command/Get.hs

@@ -16,7 +16,7 @@ import Annex.Wanted
 import qualified Command.Move
 
 cmd :: Command
-cmd = withGlobalOptions (jobsOption : jsonOption : annexedMatchingOptions) $ 
+cmd = withGlobalOptions (jobsOption : jsonOption : jsonProgressOption : annexedMatchingOptions) $ 
 	command "get" SectionCommon 
 		"make content of annexed files available"
 		paramPaths (seek <$$> optParser)

Command/MetaData.hs

@@ -79,7 +79,7 @@ seek o = do
 				(seeker $ whenAnnexed $ start now o)
 				(forFiles o)
 		Batch -> withMessageState $ \s -> case outputType s of
-			JSONOutput -> batchInput parseJSONInput $
+			JSONOutput _ -> batchInput parseJSONInput $
 				commandAction . startBatch now
 			_ -> error "--batch is currently only supported in --json mode"
 

Messages.hs

@@ -213,7 +213,7 @@ commandProgressDisabled :: Annex Bool
 commandProgressDisabled = withMessageState $ \s -> return $
 	case outputType s of
 		QuietOutput -> True
-		JSONOutput -> True
+		JSONOutput _ -> True
 		NormalOutput -> concurrentOutputEnabled s
 
 {- Use to show a message that is displayed implicitly, and so might be

Messages/Internal.hs

@@ -26,20 +26,20 @@ outputMessage' endmessage json msg = withMessageState $ \s -> case outputType s
 	NormalOutput
 		| concurrentOutputEnabled s -> concurrentMessage s False msg q
 		| otherwise -> liftIO $ flushed $ putStr msg
-	JSONOutput -> void $ outputJSON json endmessage s
+	JSONOutput _ -> void $ outputJSON json endmessage s
 	QuietOutput -> q
 
 outputJSON :: IO () -> Bool -> MessageState -> Annex Bool
 outputJSON json endmessage s = case outputType s of
-	JSONOutput
+	JSONOutput withprogress
-		| concurrentOutputEnabled s -> do
+		| withprogress || concurrentOutputEnabled s -> do
 			-- Buffer json fragments until end is reached.
 			if endmessage
 				then do
 					Annex.changeState $ \st -> 
 						st { Annex.output = s { jsonBuffer = [] } }
 					liftIO $ flushed $ do
-						sequence_ $ reverse $ jsonBuffer s
+						showJSONBuffer s
 						json
 				else Annex.changeState $ \st ->
 				        st { Annex.output = s { jsonBuffer = json : jsonBuffer s } }
@@ -49,6 +49,9 @@ outputJSON json endmessage s = case outputType s of
 			return True
 	_ -> return False
 
+showJSONBuffer :: MessageState -> IO ()
+showJSONBuffer s = sequence_ $ reverse $ jsonBuffer s
+
 outputError :: String -> Annex ()
 outputError msg = withMessageState $ \s ->
 	if concurrentOutputEnabled s

Messages/JSON.hs

@@ -13,6 +13,7 @@ module Messages.JSON (
 	note,
 	add,
 	complete,
+	progress,
 	DualDisp(..),
 	ObjectMap(..),
 	JSONActionItem(..),
@@ -30,6 +31,8 @@ import Prelude
 
 import qualified Utility.JSONStream as Stream
 import Types.Key
+import Utility.Metered
+import Utility.Percentage
 
 start :: String -> Maybe FilePath -> Maybe Key -> IO ()
 start command file key = B.hPut stdout $ Stream.start $ Stream.AesonObject o
@@ -53,6 +56,20 @@ add = B.hPut stdout . Stream.add
 complete :: Stream.JSONChunk a -> IO ()
 complete v = B.hPut stdout $ Stream.start v `B.append` Stream.end
 
+progress :: IO () -> Integer -> BytesProcessed -> IO ()
+progress jsonbuffer size bytesprocessed = do
+	B.hPut stdout $ Stream.start $ Stream.AesonObject o
+	putStr ",\"action\":"
+	jsonbuffer
+	B.hPut stdout $ Stream.end
+	B.hPut stdout $ Stream.end
+  where
+	n = fromBytesProcessed bytesprocessed :: Integer
+	Object o = object
+		[ "byte-progress" .= n
+		, "percent-progress" .= showPercentage 2 (percentage size n)
+		]
+
 -- A value that can be displayed either normally, or as JSON.
 data DualDisp = DualDisp
 	{ dispNormal :: String

Messages/Progress.hs

@@ -16,6 +16,7 @@ import Utility.Metered
 import Types
 import Types.Messages
 import Types.Key
+import qualified Messages.JSON as JSON
 
 #ifdef WITH_CONCURRENTOUTPUT
 import Messages.Concurrent
@@ -35,7 +36,6 @@ metered othermeter key a = case keySize key of
 	Just size -> withMessageState (go $ fromInteger size)
   where
 	go _ (MessageState { outputType = QuietOutput }) = nometer
-	go _ (MessageState { outputType = JSONOutput }) = nometer
 	go size (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do
 		showOutput
 		(progress, meter) <- mkmeter size
@@ -57,6 +57,12 @@ metered othermeter key a = case keySize key of
 #else
 		nometer
 #endif
+	go _ (MessageState { outputType = JSONOutput False }) = nometer
+	go size (MessageState { outputType = JSONOutput True }) = do
+		buf <- withMessageState $ return . showJSONBuffer
+		m <- liftIO $ rateLimitMeterUpdate 0.1 (Just size) $
+			JSON.progress buf size
+		a (combinemeter m)
 
 	mkmeter size = do
 		progress <- liftIO $ newProgress "" size

Types/Messages.hs

@@ -15,7 +15,7 @@ import Data.Default
 import System.Console.Regions (ConsoleRegion)
 #endif
 
-data OutputType = NormalOutput | QuietOutput | JSONOutput
+data OutputType = NormalOutput | QuietOutput | JSONOutput Bool
 	deriving (Show)
 
 data SideActionBlock = NoBlock | StartBlock | InBlock

doc/git-annex-addurl.mdwn

@@ -88,6 +88,10 @@ be used to get better filenames.
   Enable JSON output. This is intended to be parsed by programs that use
   git-annex. Each line of output is a JSON object.
 
+* `--json-progress`
+
+  Include progress objects in JSON output.
+
 # CAVEATS
 
 If annex.largefiles is configured, and does not match a file, `git annex

doc/git-annex-get.mdwn

@@ -86,7 +86,7 @@ or transferring them from some kind of key-value store.
   displayed. If the specified file's content is already present, or
   it is not an annexed file, a blank line is output in response instead.
 
-  Since the usual progress output while getting a file is verbose and not
+  Since the usual output while getting a file is verbose and not
   machine-parseable, you may want to use --json in combination with
   --batch.
 
@@ -95,6 +95,10 @@ or transferring them from some kind of key-value store.
   Enable JSON output. This is intended to be parsed by programs that use
   git-annex. Each line of output is a JSON object.
 
+* `--json-progress`
+
+  Include progress objects in JSON output.
+
 # SEE ALSO
 
 [[git-annex]](1)