summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joeyh@joeyh.name>2016-07-26 13:30:07 -0400
committerGravatar Joey Hess <joeyh@joeyh.name>2016-07-26 13:30:07 -0400
commit3eb54bb464b4566e5ea5fe9db5addc20231597d0 (patch)
tree265691703d3ee1c8f64dc6accc7dd0c30fbb3c3b
parent4ee3e4194a716273f68641ba0312339ab7c70b8b (diff)
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.
-rw-r--r--Command/Add.hs2
-rw-r--r--Command/AddUrl.hs2
-rw-r--r--Command/Find.hs2
-rw-r--r--Command/Info.hs4
-rw-r--r--Command/MetaData.hs2
-rw-r--r--Command/Status.hs2
-rw-r--r--Messages.hs9
-rw-r--r--Messages/JSON.hs16
-rw-r--r--Remote.hs3
-rw-r--r--Utility/JSONStream.hs43
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 <id@joeyh.name>
+ - Copyright 2011-2016 Joey Hess <id@joeyh.name>
-
- 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 <id@joeyh.name>
+ - Copyright 2011, 2016 Joey Hess <id@joeyh.name>
-
- 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
+