diff options
| -rw-r--r-- | CHANGELOG | 1 | ||||
| -rw-r--r-- | Command/Add.hs | 2 | ||||
| -rw-r--r-- | Command/AddUrl.hs | 2 | ||||
| -rw-r--r-- | Command/Find.hs | 2 | ||||
| -rw-r--r-- | Command/Info.hs | 25 | ||||
| -rw-r--r-- | Command/Status.hs | 2 | ||||
| -rw-r--r-- | Messages/JSON.hs | 25 | ||||
| -rw-r--r-- | Remote.hs | 20 | ||||
| -rw-r--r-- | Test.hs | 11 | ||||
| -rw-r--r-- | Utility/JSONStream.hs | 35 | ||||
| -rw-r--r-- | debian/control | 1 | ||||
| -rw-r--r-- | git-annex.cabal | 2 |
12 files changed, 70 insertions, 58 deletions
@@ -12,6 +12,7 @@ git-annex (6.20160726) UNRELEASED; urgency=medium since aws 0.14.0 is not compatible with the newer version. * git-annex.cabal: Temporarily limit to persistent <2.5 since esqueleto 2.4.3 is not compatible with the newer version. + * Removed dependency on json library; all JSON is now handled by aeson. -- Joey Hess <id@joeyh.name> Wed, 20 Jul 2016 12:03:15 -0400 diff --git a/Command/Add.hs b/Command/Add.hs index 9a658e444..eeaaf5d34 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 $ JSONObject [("key", key2file key)] + maybeShowJSON $ JSONChunk [("key", key2file key)] when hascontent $ logStatus key InfoPresent return True diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs index 2b889ac19..326bf782b 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 $ JSONObject [("key", key2file key)] + maybeShowJSON $ JSONChunk [("key", key2file key)] when (isJust mtmp) $ logStatus key InfoPresent setUrlPresent u key url diff --git a/Command/Find.hs b/Command/Find.hs index 9cd075ed6..553ddc419 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 $ JSONObject vars) $ + unlessM (showFullJSON $ JSONChunk vars) $ case format of Nothing -> liftIO $ putStrLn unformatted Just formatter -> liftIO $ putStr $ diff --git a/Command/Info.hs b/Command/Info.hs index 4eae57e5b..bdc8afc34 100644 --- a/Command/Info.hs +++ b/Command/Info.hs @@ -11,8 +11,9 @@ module Command.Info where import "mtl" Control.Monad.State.Strict import qualified Data.Map.Strict as M -import Text.JSON +import qualified Data.Text as T import Data.Ord +import Data.Aeson hiding (json) import Command import qualified Git @@ -34,7 +35,7 @@ import Logs.Transfer import Types.TrustLevel import Types.FileMatcher import qualified Limit -import Messages.JSON (DualDisp(..)) +import Messages.JSON (DualDisp(..), ObjectMap(..)) import Annex.BloomFilter import qualified Command.Unused @@ -247,10 +248,10 @@ simpleStat desc getval = stat desc $ json id getval nostat :: Stat nostat = return Nothing -json :: JSON j => (j -> String) -> StatState j -> String -> StatState String +json :: ToJSON j => (j -> String) -> StatState j -> String -> StatState String json fmt a desc = do j <- a - lift $ maybeShowJSON $ JSONObject [(desc, j)] + lift $ maybeShowJSON $ JSONChunk [(desc, j)] return $ fmt j nojson :: StatState String -> String -> StatState String @@ -374,7 +375,7 @@ transfer_list :: Stat transfer_list = stat desc $ nojson $ lift $ do uuidmap <- Remote.remoteMap id ts <- getTransfers - maybeShowJSON $ JSONObject [(desc, map (uncurry jsonify) ts)] + maybeShowJSON $ JSONChunk [(desc, map (uncurry jsonify) ts)] return $ if null ts then "none" else multiLine $ @@ -388,11 +389,11 @@ transfer_list = stat desc $ nojson $ lift $ do , maybe (fromUUID $ transferUUID t) Remote.name $ M.lookup (transferUUID t) uuidmap ] - jsonify t i = toJSObject - [ ("transfer", showLcDirection (transferDirection t)) - , ("key", key2file (transferKey t)) - , ("file", fromMaybe "" (associatedFile i)) - , ("remote", fromUUID (transferUUID t)) + jsonify t i = object $ map (\(k, v) -> (T.pack k, v)) $ + [ ("transfer", toJSON (showLcDirection (transferDirection t))) + , ("key", toJSON (key2file (transferKey t))) + , ("file", toJSON (associatedFile i)) + , ("remote", toJSON (fromUUID (transferUUID t))) ] disk_size :: Stat @@ -415,9 +416,9 @@ disk_size = simpleStat "available local disk space" $ backend_usage :: Stat backend_usage = stat "backend usage" $ json fmt $ - toJSObject . sort . M.toList . backendsKeys <$> cachedReferencedData + ObjectMap . backendsKeys <$> cachedReferencedData where - fmt = multiLine . map (\(b, n) -> b ++ ": " ++ show n) . fromJSObject + fmt = multiLine . map (\(b, n) -> b ++ ": " ++ show n) . sort . M.toList . fromObjectMap numcopies_stats :: Stat numcopies_stats = stat "numcopies stats" $ json fmt $ diff --git a/Command/Status.hs b/Command/Status.hs index f4270228d..3a3bfa812 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 $ JSONObject [("status", [c]), ("file", f)]) $ + unlessM (showFullJSON $ JSONChunk [("status", [c]), ("file", f)]) $ liftIO $ putStrLn $ [c] ++ " " ++ f -- Git thinks that present direct mode files are typechanged. diff --git a/Messages/JSON.hs b/Messages/JSON.hs index 895c251db..b45c9eff8 100644 --- a/Messages/JSON.hs +++ b/Messages/JSON.hs @@ -14,19 +14,21 @@ module Messages.JSON ( add, complete, DualDisp(..), + ObjectMap(..), ParsedJSON(..), ) where -import qualified Text.JSON as JSON import Data.Aeson import Control.Applicative +import qualified Data.Map as M +import qualified Data.Text as T import qualified Utility.JSONStream as Stream import Types.Key import Data.Maybe start :: String -> Maybe FilePath -> Maybe Key -> IO () -start command file key = putStr $ Stream.start $ Stream.JSONObject $ catMaybes +start command file key = putStr $ Stream.start $ Stream.JSONChunk $ catMaybes [ part "command" (Just command) , part "file" file , part "key" (fmap key2file key) @@ -36,10 +38,10 @@ start command file key = putStr $ Stream.start $ Stream.JSONObject $ catMaybes part l (Just v) = Just (l, v) end :: Bool -> IO () -end b = putStr $ Stream.add (Stream.JSONObject [("success", b)]) ++ Stream.end +end b = putStr $ Stream.add (Stream.JSONChunk [("success", b)]) ++ Stream.end note :: String -> IO () -note s = add (Stream.JSONObject [("note", s)]) +note s = add (Stream.JSONChunk [("note", s)]) add :: Stream.JSONChunk a -> IO () add = putStr . Stream.add @@ -53,13 +55,22 @@ data DualDisp = DualDisp , dispJson :: String } -instance JSON.JSON DualDisp where - showJSON = JSON.JSString . JSON.toJSString . dispJson - readJSON _ = JSON.Error "stub" +instance ToJSON DualDisp where + toJSON = toJSON . dispJson instance Show DualDisp where show = dispNormal +-- A Map that is serialized to JSON as an object, with each key being a +-- field of the object. This is different from Aeson's normal +-- serialization of Map, which uses "[key, value]". +data ObjectMap a = ObjectMap { fromObjectMap :: M.Map String a } + +instance ToJSON a => ToJSON (ObjectMap a) where + toJSON (ObjectMap m) = object $ map go $ M.toList m + where + go (k, v) = (T.pack k, toJSON v) + -- An Aeson parser for the JSON output by this module, and -- similar JSON input from users. data ParsedJSON a = ParsedJSON @@ -55,10 +55,10 @@ module Remote ( claimingUrl, ) where -import qualified Data.Map as M -import Text.JSON -import Text.JSON.Generic import Data.Ord +import Data.Aeson +import qualified Data.Map as M +import qualified Data.Text as T import Annex.Common import Types.Remote @@ -194,7 +194,7 @@ prettyPrintUUIDsDescs header descm uuids = {- An optional field can be included in the list of UUIDs. -} prettyPrintUUIDsWith - :: JSON v + :: ToJSON v => Maybe String -> String -> M.Map UUID RemoteName @@ -203,7 +203,7 @@ prettyPrintUUIDsWith -> Annex String prettyPrintUUIDsWith optfield header descm showval uuidvals = do hereu <- getUUID - maybeShowJSON $ JSONObject [(header, map (jsonify hereu) uuidvals)] + maybeShowJSON $ JSONChunk [(header, map (jsonify hereu) uuidvals)] return $ unwords $ map (\u -> "\t" ++ prettify hereu u ++ "\n") uuidvals where finddescription u = M.findWithDefault "" u descm @@ -220,12 +220,12 @@ prettyPrintUUIDsWith optfield header descm showval uuidvals = do addoptval s = case showval =<< optval of Nothing -> s Just val -> val ++ ": " ++ s - jsonify hereu (u, optval) = toJSObject $ catMaybes - [ Just ("uuid", toJSON $ fromUUID u) - , Just ("description", toJSON $ finddescription u) - , Just ("here", toJSON $ hereu == u) + jsonify hereu (u, optval) = object $ catMaybes + [ Just (T.pack "uuid", toJSON $ fromUUID u) + , Just (T.pack "description", toJSON $ finddescription u) + , Just (T.pack "here", toJSON $ hereu == u) , case (optfield, optval) of - (Just field, Just val) -> Just (field, showJSON val) + (Just field, Just val) -> Just (T.pack field, toJSON val) _ -> Nothing ] @@ -32,7 +32,8 @@ import Test.Tasty.Ingredients.Rerun import Options.Applicative (switch, long, help) import qualified Data.Map as M -import qualified Text.JSON +import qualified Data.Aeson +import qualified Data.ByteString.Lazy.UTF8 as BU8 import Common @@ -924,10 +925,10 @@ test_merge = intmpclonerepo $ test_info :: Assertion test_info = intmpclonerepo $ do - json <- git_annex_output "info" ["--json"] - case Text.JSON.decodeStrict json :: Text.JSON.Result (Text.JSON.JSObject Text.JSON.JSValue) of - Text.JSON.Ok _ -> return () - Text.JSON.Error e -> assertFailure e + json <- BU8.fromString <$> git_annex_output "info" ["--json"] + case Data.Aeson.eitherDecode json :: Either String Data.Aeson.Value of + Right _ -> return () + Left e -> assertFailure e test_version :: Assertion test_version = intmpclonerepo $ diff --git a/Utility/JSONStream.hs b/Utility/JSONStream.hs index efee1dec6..af321b2f9 100644 --- a/Utility/JSONStream.hs +++ b/Utility/JSONStream.hs @@ -14,31 +14,30 @@ module Utility.JSONStream ( end ) where -import qualified Text.JSON as JSON -import qualified Data.Aeson as Aeson +import Data.Aeson +import qualified Data.Text as T import qualified Data.ByteString.Lazy.UTF8 as B -{- 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. -} +data JSONChunk v where + JSONChunk :: ToJSON v => [(String, v)] -> JSONChunk [(String, v)] + AesonObject :: Object -> JSONChunk Object + +encodeJSONChunk :: JSONChunk v -> B.ByteString +encodeJSONChunk (JSONChunk l) = encode $ object $ map mkPair l + where + mkPair (s, v) = (T.pack s, toJSON v) +encodeJSONChunk (AesonObject o) = encode o + +{- 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 -> String start a | last s == endchar = init s | otherwise = bad s where - s = encodeJSONChunk a + s = B.toString $ encodeJSONChunk a add :: JSONChunk a -> String add a diff --git a/debian/control b/debian/control index 30c4274ce..ec77a2946 100644 --- a/debian/control +++ b/debian/control @@ -23,7 +23,6 @@ Build-Depends: libghc-unix-compat-dev, libghc-dlist-dev, libghc-uuid-dev, - libghc-json-dev, libghc-aeson-dev, libghc-unordered-containers-dev, libghc-ifelse-dev, diff --git a/git-annex.cabal b/git-annex.cabal index f9033cc38..9e2adbc8f 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -331,7 +331,7 @@ Executable git-annex process, data-default, case-insensitive, uuid, random, dlist, unix-compat, SafeSemaphore, async, directory, filepath, IfElse, MissingH, hslogger, monad-logger, - utf8-string, bytestring, text, sandi, json, + utf8-string, bytestring, text, sandi, monad-control, transformers, bloomfilter, edit-distance, resourcet, http-conduit (<2.2.0), http-client, http-types, |