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.

3 files changed, 31 insertions, 5 deletions

diff --git a/Messages/Internal.hs b/Messages/Internal.hs
index 21d11d811..bf212b71b 100644
--- a/Messages/Internal.hs
+++ b/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
-		| concurrentOutputEnabled s -> do
+	JSONOutput withprogress
+		| 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
diff --git a/Messages/JSON.hs b/Messages/JSON.hs
index 0cceda3f3..7b94aa220 100644
--- a/Messages/JSON.hs
+++ b/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
diff --git a/Messages/Progress.hs b/Messages/Progress.hs
index fa11c1304..a48e7b07e 100644
--- a/Messages/Progress.hs
+++ b/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