From 3eb54bb464b4566e5ea5fe9db5addc20231597d0 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 26 Jul 2016 13:30:07 -0400 Subject: allow using Aeson for streaming JSON output Keeping Text.JSON use for now, because it seems a better fit for most of the commands, which don't use very structured JSON objects, but just output whatever fields suites them. But this lets Aeson be used when a more structured data type is available to serialize to JSON. --- Command/Add.hs | 2 +- Command/AddUrl.hs | 2 +- Command/Find.hs | 2 +- Command/Info.hs | 4 ++-- Command/MetaData.hs | 2 +- Command/Status.hs | 2 +- Messages.hs | 9 +++++---- Messages/JSON.hs | 16 ++++++++-------- Remote.hs | 3 ++- Utility/JSONStream.hs | 43 ++++++++++++++++++++++++++++++------------- 10 files changed, 52 insertions(+), 33 deletions(-) diff --git a/Command/Add.hs b/Command/Add.hs index d6a2e5bf7..9a658e444 100644 --- a/Command/Add.hs +++ b/Command/Add.hs @@ -146,7 +146,7 @@ perform file = do cleanup :: Key -> Bool -> CommandCleanup cleanup key hascontent = do - maybeShowJSON [("key", key2file key)] + maybeShowJSON $ JSONObject [("key", key2file key)] when hascontent $ logStatus key InfoPresent return True diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 0370a2fc9..2b889ac19 100644 --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -356,7 +356,7 @@ cleanup u url file key mtmp = case mtmp of ) where go = do - maybeShowJSON [("key", key2file key)] + maybeShowJSON $ JSONObject [("key", key2file key)] when (isJust mtmp) $ logStatus key InfoPresent setUrlPresent u key url diff --git a/Command/Find.hs b/Command/Find.hs index 08c720575..9cd075ed6 100644 --- a/Command/Find.hs +++ b/Command/Find.hs @@ -66,7 +66,7 @@ start o file key = ifM (limited <||> inAnnex key) showFormatted :: Maybe Utility.Format.Format -> String -> [(String, String)] -> Annex () showFormatted format unformatted vars = - unlessM (showFullJSON vars) $ + unlessM (showFullJSON $ JSONObject vars) $ case format of Nothing -> liftIO $ putStrLn unformatted Just formatter -> liftIO $ putStr $ diff --git a/Command/Info.hs b/Command/Info.hs index 05d6a01d3..4eae57e5b 100644 --- a/Command/Info.hs +++ b/Command/Info.hs @@ -250,7 +250,7 @@ nostat = return Nothing json :: JSON j => (j -> String) -> StatState j -> String -> StatState String json fmt a desc = do j <- a - lift $ maybeShowJSON [(desc, j)] + lift $ maybeShowJSON $ JSONObject [(desc, j)] return $ fmt j nojson :: StatState String -> String -> StatState String @@ -374,7 +374,7 @@ transfer_list :: Stat transfer_list = stat desc $ nojson $ lift $ do uuidmap <- Remote.remoteMap id ts <- getTransfers - maybeShowJSON [(desc, map (uncurry jsonify) ts)] + maybeShowJSON $ JSONObject [(desc, map (uncurry jsonify) ts)] return $ if null ts then "none" else multiLine $ diff --git a/Command/MetaData.hs b/Command/MetaData.hs index 14e727fc7..3123a63d0 100644 --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -96,7 +96,7 @@ perform now o k = case getSet o of cleanup :: Key -> CommandCleanup cleanup k = do l <- map unwrapmeta . fromMetaData <$> getCurrentMetaData k - maybeShowJSON l + maybeShowJSON (JSONObject l) showLongNote $ unlines $ concatMap showmeta l return True where diff --git a/Command/Status.hs b/Command/Status.hs index 260cf2ab4..f4270228d 100644 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -43,7 +43,7 @@ displayStatus s = do let c = statusChar s absf <- fromRepo $ fromTopFilePath (statusFile s) f <- liftIO $ relPathCwdToFile absf - unlessM (showFullJSON [("status", [c]), ("file", f)]) $ + unlessM (showFullJSON $ JSONObject [("status", [c]), ("file", f)]) $ liftIO $ putStrLn $ [c] ++ " " ++ f -- Git thinks that present direct mode files are typechanged. diff --git a/Messages.hs b/Messages.hs index 050dff950..63f5b10bb 100644 --- a/Messages.hs +++ b/Messages.hs @@ -29,6 +29,7 @@ module Messages ( earlyWarning, warningIO, indent, + JSONChunk(..), maybeShowJSON, showFullJSON, showCustom, @@ -43,7 +44,6 @@ module Messages ( implicitMessage, ) where -import Text.JSON import System.Log.Logger import System.Log.Formatter import System.Log.Handler (setFormatter) @@ -55,6 +55,7 @@ import Types.Messages import Git.FilePath import Messages.Internal import qualified Messages.JSON as JSON +import Utility.JSONStream (JSONChunk(..)) import Types.Key import qualified Annex @@ -181,15 +182,15 @@ warningIO w = do indent :: String -> String indent = intercalate "\n" . map (\l -> " " ++ l) . lines -{- Shows a JSON fragment only when in json mode. -} -maybeShowJSON :: JSON a => [(String, a)] -> Annex () +{- Shows a JSON chunk only when in json mode. -} +maybeShowJSON :: JSONChunk v -> Annex () maybeShowJSON v = withOutputType $ liftIO . go where go JSONOutput = JSON.add v go _ = return () {- Shows a complete JSON value, only when in json mode. -} -showFullJSON :: JSON a => [(String, a)] -> Annex Bool +showFullJSON :: JSONChunk v -> Annex Bool showFullJSON v = withOutputType $ liftIO . go where go JSONOutput = JSON.complete v >> return True diff --git a/Messages/JSON.hs b/Messages/JSON.hs index fa829a76c..6e89693fc 100644 --- a/Messages/JSON.hs +++ b/Messages/JSON.hs @@ -1,6 +1,6 @@ -{- git-annex JSON output +{- git-annex command-line JSON output and input - - - Copyright 2011 Joey Hess + - Copyright 2011-2016 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -21,7 +21,7 @@ import Types.Key import Data.Maybe start :: String -> Maybe FilePath -> Maybe Key -> IO () -start command file key = putStr $ Stream.start $ catMaybes +start command file key = putStr $ Stream.start $ Stream.JSONObject $ catMaybes [ part "command" (Just command) , part "file" file , part "key" (fmap key2file key) @@ -31,15 +31,15 @@ start command file key = putStr $ Stream.start $ catMaybes part l (Just v) = Just (l, v) end :: Bool -> IO () -end b = putStr $ Stream.add [("success", b)] ++ Stream.end +end b = putStr $ Stream.add (Stream.JSONObject [("success", b)]) ++ Stream.end note :: String -> IO () -note s = add [("note", s)] +note s = add (Stream.JSONObject [("note", s)]) -add :: JSON a => [(String, a)] -> IO () -add v = putStr $ Stream.add v +add :: Stream.JSONChunk a -> IO () +add = putStr . Stream.add -complete :: JSON a => [(String, a)] -> IO () +complete :: Stream.JSONChunk a -> IO () complete v = putStr $ Stream.start v ++ Stream.end -- A value that can be displayed either normally, or as JSON. diff --git a/Remote.hs b/Remote.hs index 79059df99..b67df1f4f 100644 --- a/Remote.hs +++ b/Remote.hs @@ -72,6 +72,7 @@ import Remote.List import Config import Git.Types (RemoteName) import qualified Git +import Utility.JSONStream {- Map from UUIDs of Remotes to a calculated value. -} remoteMap :: (Remote -> v) -> Annex (M.Map UUID v) @@ -203,7 +204,7 @@ prettyPrintUUIDsWith -> Annex String prettyPrintUUIDsWith optfield header descm showval uuidvals = do hereu <- getUUID - maybeShowJSON [(header, map (jsonify hereu) uuidvals)] + maybeShowJSON $ JSONObject [(header, map (jsonify hereu) uuidvals)] return $ unwords $ map (\u -> "\t" ++ prettify hereu u ++ "\n") uuidvals where finddescription u = M.findWithDefault "" u descm diff --git a/Utility/JSONStream.hs b/Utility/JSONStream.hs index 2746678cc..efee1dec6 100644 --- a/Utility/JSONStream.hs +++ b/Utility/JSONStream.hs @@ -1,35 +1,51 @@ {- Streaming JSON output. - - - Copyright 2011 Joey Hess + - Copyright 2011, 2016 Joey Hess - - License: BSD-2-clause -} +{-# LANGUAGE GADTs #-} + module Utility.JSONStream ( + JSONChunk(..), start, add, end ) where -import Text.JSON +import qualified Text.JSON as JSON +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy.UTF8 as B -{- Text.JSON does not support building up a larger JSON document piece by - - piece as a stream. To support streaming, a hack. The JSObject is converted - - to a string with its final "}" is left off, allowing it to be added to - - later. -} -start :: JSON a => [(String, a)] -> String -start l +{- Only JSON objects can be used as chunks in the stream, not + - other values. + - + - Both Aeson and Text.Json objects are supported. -} +data JSONChunk a where + JSONObject :: JSON.JSON a => [(String, a)] -> JSONChunk [(String, a)] + AesonObject :: Aeson.Object -> JSONChunk Aeson.Object + +encodeJSONChunk :: JSONChunk a -> String +encodeJSONChunk (JSONObject l) = JSON.encodeStrict $ JSON.toJSObject l +encodeJSONChunk (AesonObject o) = B.toString (Aeson.encode o) + +{- Text.JSON and Aeson do not support building up a larger JSON document + - piece by piece as a stream. To support streaming, a hack. The final "}" + - is left off the object, allowing it to be added to later. -} +start :: JSONChunk a -> String +start a | last s == endchar = init s | otherwise = bad s where - s = encodeStrict $ toJSObject l + s = encodeJSONChunk a -add :: JSON a => [(String, a)] -> String -add l +add :: JSONChunk a -> String +add a | head s == startchar = ',' : drop 1 s | otherwise = bad s where - s = start l + s = start a end :: String end = [endchar, '\n'] @@ -41,4 +57,5 @@ endchar :: Char endchar = '}' bad :: String -> a -bad s = error $ "Text.JSON returned unexpected string: " ++ s +bad s = error $ "JSON encoder generated unexpected value: " ++ s + -- cgit v1.2.3