Removed dependency on json library; all JSON is now handled by aeson.
I've eyeballed all --json commands, and the only difference should be that some fields are re-ordered.
This commit is contained in:
parent
eabef6efce
commit
870873bdaa
12 changed files with 68 additions and 56 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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 $
|
||||
|
|
|
@ -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 $
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
20
Remote.hs
20
Remote.hs
|
@ -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
|
||||
]
|
||||
|
||||
|
|
11
Test.hs
11
Test.hs
|
@ -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 $
|
||||
|
|
|
@ -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
|
||||
data JSONChunk v where
|
||||
JSONChunk :: ToJSON v => [(String, v)] -> JSONChunk [(String, v)]
|
||||
AesonObject :: Object -> JSONChunk Object
|
||||
|
||||
encodeJSONChunk :: JSONChunk a -> String
|
||||
encodeJSONChunk (JSONObject l) = JSON.encodeStrict $ JSON.toJSObject l
|
||||
encodeJSONChunk (AesonObject o) = B.toString (Aeson.encode o)
|
||||
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
|
||||
|
||||
{- 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. -}
|
||||
{- 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
|
||||
|
|
1
debian/control
vendored
1
debian/control
vendored
|
@ -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,
|
||||
|
|
|
@ -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,
|
||||
|
|
Loading…
Reference in a new issue