diff options
| -rw-r--r-- | Messages.hs | 13 | ||||
| -rw-r--r-- | Messages/Internal.hs | 43 | ||||
| -rw-r--r-- | Messages/JSON.hs | 70 | ||||
| -rw-r--r-- | Types/Messages.hs | 6 | ||||
| -rw-r--r-- | Utility/JSONStream.hs | 80 | ||||
| -rw-r--r-- | git-annex.cabal | 1 |
6 files changed, 71 insertions, 142 deletions
diff --git a/Messages.hs b/Messages.hs index 53f356c1d..0ab1f72bb 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 2c9a461a5..7ea8ee067 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 e8491c691..6c22d9537 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) + +none :: JSONBuilder +none = id -start :: String -> Maybe FilePath -> Maybe Key -> JSONChunk -start command file key = Stream.start $ Stream.AesonObject o +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 - -progress :: B.ByteString -> Integer -> BytesProcessed -> IO () -progress jsonbuffer size bytesprocessed = emit $ B.concat - [ Stream.start $ Stream.AesonObject o - , Stream.addNestedObject "action" jsonbuffer - , 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 + +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 49242ea45..751a513d6 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 45978ef06..000000000 --- a/Utility/JSONStream.hs +++ /dev/null @@ -1,80 +0,0 @@ -{- Streaming JSON output. - - - - Copyright 2011, 2016 Joey Hess <id@joeyh.name> - - - - 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 c32da7e23..2a3728090 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 |