From d7ea6a56844e4918cecb7e9472e74d6e76641ae4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 9 Sep 2016 18:13:55 -0400 Subject: [PATCH] drop incremental json object display; clean up code This gets rid of quite a lot of ugly hacks around json generation. I doubt that any real-world json parsers can parse incomplete objects, so while it's not as nice to need to wait for the complete object, especially for commands like `git annex info` that take a while, it doesn't seem worth the added complexity. This also causes the order of fields within the json objects to be reordered. Since any real json parser shouldn't care, the only possible problem would be with ad-hoc parsers of the old json output. --- Messages.hs | 13 ++++--- Messages/Internal.hs | 43 ++++++++++------------- Messages/JSON.hs | 68 ++++++++++++++++++++++-------------- Types/Messages.hs | 6 ++-- Utility/JSONStream.hs | 80 ------------------------------------------- git-annex.cabal | 1 - 6 files changed, 70 insertions(+), 141 deletions(-) delete mode 100644 Utility/JSONStream.hs diff --git a/Messages.hs b/Messages.hs index 53f356c1de..0ab1f72bbb 100644 --- a/Messages.hs +++ b/Messages.hs @@ -27,7 +27,7 @@ module Messages ( earlyWarning, warningIO, indent, - JSONChunk(..), + JSON.JSONChunk(..), maybeShowJSON, showFullJSON, showCustom, @@ -54,7 +54,6 @@ import Types.Messages import Types.ActionItem import Messages.Internal import qualified Messages.JSON as JSON -import Utility.JSONStream (JSONChunk(..)) import qualified Annex showStart :: String -> FilePath -> Annex () @@ -122,7 +121,7 @@ showEndFail :: Annex () showEndFail = showEndResult False showEndResult :: Bool -> Annex () -showEndResult ok = outputMessageFinal (JSON.end ok) $ endResult ok ++ "\n" +showEndResult ok = outputMessage (JSON.end ok) $ endResult ok ++ "\n" endResult :: Bool -> String endResult True = "ok" @@ -154,12 +153,12 @@ indent :: String -> String indent = intercalate "\n" . map (\l -> " " ++ l) . lines {- Shows a JSON chunk only when in json mode. -} -maybeShowJSON :: JSONChunk v -> Annex () -maybeShowJSON v = void $ withMessageState $ outputJSON (JSON.add v) False +maybeShowJSON :: JSON.JSONChunk v -> Annex () +maybeShowJSON v = void $ withMessageState $ outputJSON (JSON.add v) {- Shows a complete JSON value, only when in json mode. -} -showFullJSON :: JSONChunk v -> Annex Bool -showFullJSON v = withMessageState $ outputJSON (JSON.complete v) True +showFullJSON :: JSON.JSONChunk v -> Annex Bool +showFullJSON v = withMessageState $ outputJSON (JSON.complete v) {- Performs an action that outputs nonstandard/customized output, and - in JSON mode wraps its output in JSON.start and JSON.end, so it's diff --git a/Messages/Internal.hs b/Messages/Internal.hs index 2c9a461a5f..7ea8ee0672 100644 --- a/Messages/Internal.hs +++ b/Messages/Internal.hs @@ -13,44 +13,39 @@ import Types.Messages import Messages.Concurrent import Messages.JSON -import qualified Data.ByteString.Lazy as B withMessageState :: (MessageState -> Annex a) -> Annex a withMessageState a = Annex.getState Annex.output >>= a -outputMessage :: JSONChunk -> String -> Annex () -outputMessage = outputMessage' False - -outputMessageFinal :: JSONChunk -> String -> Annex () -outputMessageFinal = outputMessage' True - -outputMessage' :: Bool -> JSONChunk -> String -> Annex () -outputMessage' endmessage json msg = withMessageState $ \s -> case outputType s of +outputMessage :: JSONBuilder -> String -> Annex () +outputMessage jsonbuilder msg = withMessageState $ \s -> case outputType s of NormalOutput | concurrentOutputEnabled s -> concurrentMessage s False msg q | otherwise -> liftIO $ flushed $ putStr msg - JSONOutput _ -> void $ outputJSON json endmessage s + JSONOutput _ -> void $ outputJSON jsonbuilder s QuietOutput -> q -outputJSON :: JSONChunk -> Bool -> MessageState -> Annex Bool -outputJSON json endmessage s = case outputType s of - 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 = none } } - liftIO $ flushed $ emit b - else Annex.changeState $ \st -> - st { Annex.output = s { jsonBuffer = b } } +-- Buffer changes to JSON until end is reached and then emit it. +outputJSON :: JSONBuilder -> MessageState -> Annex Bool +outputJSON jsonbuilder s = case outputType s of + JSONOutput _ + | endjson -> do + Annex.changeState $ \st -> + st { Annex.output = s { jsonBuffer = Nothing } } + maybe noop (liftIO . flushed . emit) json return True | otherwise -> do - liftIO $ flushed $ emit json + Annex.changeState $ \st -> + st { Annex.output = s { jsonBuffer = json } } return True _ -> return False where - b = jsonBuffer s `B.append` json + (json, endjson) = case jsonbuilder i of + Nothing -> (jsonBuffer s, False) + (Just (j, e)) -> (Just j, e) + i = case jsonBuffer s of + Nothing -> Nothing + Just b -> Just (b, False) outputError :: String -> Annex () outputError msg = withMessageState $ \s -> diff --git a/Messages/JSON.hs b/Messages/JSON.hs index e8491c691a..6c22d9537b 100644 --- a/Messages/JSON.hs +++ b/Messages/JSON.hs @@ -5,10 +5,11 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, GADTs #-} module Messages.JSON ( - JSONChunk, + JSONBuilder, + JSONChunk(..), emit, none, start, @@ -27,6 +28,7 @@ import Control.Applicative import qualified Data.Map as M import qualified Data.Text as T import qualified Data.ByteString.Lazy as B +import qualified Data.HashMap.Strict as HM import System.IO import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent @@ -34,29 +36,31 @@ import Data.Maybe import Data.Monoid import Prelude -import qualified Utility.JSONStream as Stream import Types.Key import Utility.Metered import Utility.Percentage -type JSONChunk = B.ByteString - -- A global lock to avoid concurrent threads emitting json at the same time. {-# NOINLINE emitLock #-} emitLock :: MVar () emitLock = unsafePerformIO $ newMVar () -emit :: JSONChunk -> IO () -emit v = do +emit :: Object -> IO () +emit o = do takeMVar emitLock - B.hPut stdout v + B.hPut stdout (encode o) + putStr "\n" putMVar emitLock () -none :: JSONChunk -none = B.empty +-- Building up a JSON object can be done by first using start, +-- then add and note any number of times, and finally complete. +type JSONBuilder = Maybe (Object, Bool) -> Maybe (Object, Bool) -start :: String -> Maybe FilePath -> Maybe Key -> JSONChunk -start command file key = Stream.start $ Stream.AesonObject o +none :: JSONBuilder +none = id + +start :: String -> Maybe FilePath -> Maybe Key -> JSONBuilder +start command file key _ = Just (o, False) where Object o = toJSON $ JSONActionItem { itemCommand = Just command @@ -65,24 +69,36 @@ start command file key = Stream.start $ Stream.AesonObject o , itemAdded = Nothing } -end :: Bool -> JSONChunk -end b =Stream.add (Stream.JSONChunk [("success", b)]) `B.append` Stream.end +end :: Bool -> JSONBuilder +end b (Just (o, _)) = Just (HM.insert "success" (toJSON b) o, True) +end _ Nothing = Nothing -note :: String -> JSONChunk -note s = add (Stream.JSONChunk [("note", s)]) +note :: String -> JSONBuilder +note s (Just (o, e)) = Just (HM.insert "note" (toJSON s) o, e) +note _ Nothing = Nothing -add :: Stream.JSONChunk a -> JSONChunk -add = Stream.add +data JSONChunk v where + AesonObject :: Object -> JSONChunk Object + JSONChunk :: ToJSON v => [(String, v)] -> JSONChunk [(String, v)] -complete :: Stream.JSONChunk a -> JSONChunk -complete v = Stream.start v `B.append` Stream.end +add :: JSONChunk v -> JSONBuilder +add v (Just (o, e)) = Just (HM.union o' o, e) + where + Object o' = case v of + AesonObject ao -> Object ao + JSONChunk l -> object (map mkPair l) + mkPair (s, d) = (T.pack s, toJSON d) +add _ Nothing = Nothing -progress :: B.ByteString -> Integer -> BytesProcessed -> IO () -progress jsonbuffer size bytesprocessed = emit $ B.concat - [ Stream.start $ Stream.AesonObject o - , Stream.addNestedObject "action" jsonbuffer - , Stream.end - ] +complete :: JSONChunk v -> JSONBuilder +complete v _ = add v (Just (HM.empty, True)) + +-- Show JSON formatted progress, including the current state of the JSON +-- object for the action being performed. +progress :: Maybe Object -> Integer -> BytesProcessed -> IO () +progress maction size bytesprocessed = emit $ case maction of + Just action -> HM.insert "action" (Object action) o + Nothing -> o where n = fromBytesProcessed bytesprocessed :: Integer Object o = object diff --git a/Types/Messages.hs b/Types/Messages.hs index 49242ea457..751a513d6f 100644 --- a/Types/Messages.hs +++ b/Types/Messages.hs @@ -10,7 +10,7 @@ module Types.Messages where import Data.Default -import qualified Data.ByteString.Lazy as B +import qualified Data.Aeson as Aeson #ifdef WITH_CONCURRENTOUTPUT import System.Console.Regions (ConsoleRegion) @@ -31,7 +31,7 @@ data MessageState = MessageState , consoleRegion :: Maybe ConsoleRegion , consoleRegionErrFlag :: Bool #endif - , jsonBuffer :: B.ByteString + , jsonBuffer :: Maybe Aeson.Object } instance Default MessageState @@ -45,5 +45,5 @@ instance Default MessageState , consoleRegion = Nothing , consoleRegionErrFlag = False #endif - , jsonBuffer = B.empty + , jsonBuffer = Nothing } diff --git a/Utility/JSONStream.hs b/Utility/JSONStream.hs deleted file mode 100644 index 45978ef06f..0000000000 --- a/Utility/JSONStream.hs +++ /dev/null @@ -1,80 +0,0 @@ -{- Streaming JSON output. - - - - Copyright 2011, 2016 Joey Hess - - - - License: BSD-2-clause - -} - -{-# LANGUAGE GADTs, OverloadedStrings #-} - -module Utility.JSONStream ( - JSONChunk(..), - start, - add, - addNestedObject, - end -) where - -import Data.Aeson -import qualified Data.Text as T -import qualified Data.ByteString.Lazy as B -import qualified Data.ByteString.Lazy.UTF8 as BU8 -import Data.Char -import Data.Word - -data JSONChunk v where - AesonObject :: Object -> JSONChunk Object - JSONChunk :: ToJSON v => [(String, v)] -> JSONChunk [(String, v)] - -encodeJSONChunk :: JSONChunk v -> B.ByteString -encodeJSONChunk (AesonObject o) = encode o -encodeJSONChunk (JSONChunk l) = encode $ object $ map mkPair l - where - mkPair (s, v) = (T.pack s, toJSON v) - -{- Aeson does not support building up a larger JSON object piece by piece - - with streaming output. To support streaming, a hack: - - The final "}" is left off the JSON, allowing more chunks to be added - - to later. -} -start :: JSONChunk a -> B.ByteString -start a - | not (B.null b) && B.last b == endchar = B.init b - | otherwise = bad b - where - b = encodeJSONChunk a - -add :: JSONChunk a -> B.ByteString -add a - | not (B.null b) && B.head b == startchar = - B.cons addchar (B.drop 1 b) - | otherwise = bad b - where - b = start a - -addNestedObject :: String -> B.ByteString -> B.ByteString -addNestedObject s b = B.concat - [ ",\"" - , BU8.fromString s - , "\":" - , b - , "}" - ] - -end :: B.ByteString -end = endchar `B.cons` sepchar `B.cons` B.empty - -startchar :: Word8 -startchar = fromIntegral (ord '{') - -endchar :: Word8 -endchar = fromIntegral (ord '}') - -addchar :: Word8 -addchar = fromIntegral (ord ',') - -sepchar :: Word8 -sepchar = fromIntegral (ord '\n') - -bad :: B.ByteString -> a -bad b = error $ "JSON encoder generated unexpected value: " ++ show b - diff --git a/git-annex.cabal b/git-annex.cabal index c32da7e23c..2a3728090a 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1017,7 +1017,6 @@ Executable git-annex Utility.HumanNumber Utility.HumanTime Utility.InodeCache - Utility.JSONStream Utility.LinuxMkLibs Utility.LockFile Utility.LockFile.LockStatus