mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

Fix mangling of --json output of utf-8 characters when not running in a utf-8 locale

Browse source 
As long as all code imports Utility.Aeson rather than Data.Aeson,
and no Strings that may contain utf-8 characters are used for eg, object
keys via T.pack, this is guaranteed to fix the problem everywhere that
git-annex generates json.

It's kind of annoying to need to wrap ToJSON with a ToJSON', especially
since every data type that has a ToJSON instance has to be ported over.
However, that only took 50 lines of code, which is worth it to ensure full
coverage. I initially tried an alternative approach of a newtype FileEncoded,
which had to be used everywhere a String was fed into aeson, and chasing
down all the sites would have been far too hard. Did consider creating an
intentionally overlapping instance ToJSON String, and letting ghc fail
to build anything that passed in a String, but am not sure that wouldn't
pollute some library that git-annex depends on that happens to use ToJSON
String internally.

This commit was supported by the NSF-funded DataLad project.
This commit is contained in:
Joey Hess 2018-04-16 15:42:45 -04:00
parent 6ddd374935
commit 89e1a05a8f
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
14 changed files with 173 additions and 62 deletions
Download patch file Download diff file Expand all files Collapse all files

43
Messages/JSON.hs
View file

@ -26,12 +26,10 @@ module Messages.JSON (
JSONActionItem(..),
) where
import Data.Aeson
import Control.Applicative
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy as L
import qualified Data.HashMap.Strict as HM
import System.IO
import System.IO.Unsafe (unsafePerformIO)
@ -44,6 +42,7 @@ import Types.Messages
import Key
import Utility.Metered
import Utility.Percentage
import Utility.Aeson
-- A global lock to avoid concurrent threads emitting json at the same time.
{-# NOINLINE emitLock #-}
@ -53,7 +52,7 @@ emitLock = unsafePerformIO $ newMVar ()
emit :: Object -> IO ()
emit o = do
takeMVar emitLock
B.hPut stdout (encode o)
L.hPut stdout (encode o)
putStr "\n"
putMVar emitLock ()
@ -67,7 +66,7 @@ none = id
start :: String -> Maybe FilePath -> Maybe Key -> JSONBuilder
start command file key _ = Just (o, False)
where
Object o = toJSON $ JSONActionItem
Object o = toJSON' $ JSONActionItem
{ itemCommand = Just command
, itemKey = key
, itemFile = file
@ -75,7 +74,7 @@ start command file key _ = Just (o, False)
}
end :: Bool -> JSONBuilder
end b (Just (o, _)) = Just (HM.insert "success" (toJSON b) o, True)
end b (Just (o, _)) = Just (HM.insert "success" (toJSON' b) o, True)
end _ Nothing = Nothing
finalize :: JSONOptions -> Object -> Object
@ -91,32 +90,32 @@ addErrorMessage msg o =
where
combinearray (Array new) (Array old) = Array (old <> new)
combinearray new _old = new
v = Array $ V.fromList $ map (String . T.pack) msg
v = Array $ V.fromList $ map (String . packString) msg
note :: String -> JSONBuilder
note _ Nothing = Nothing
note s (Just (o, e)) = Just (HM.insertWith combinelines "note" (toJSON s) o, e)
note s (Just (o, e)) = Just (HM.insertWith combinelines "note" (toJSON' s) o, e)
where
combinelines (String new) (String old) =
String (old <> T.pack "\n" <> new)
String (old <> "\n" <> new)
combinelines new _old = new
info :: String -> JSONBuilder
info s _ = Just (o, True)
where
Object o = object ["info" .= toJSON s]
Object o = object ["info" .= toJSON' s]
data JSONChunk v where
AesonObject :: Object -> JSONChunk Object
JSONChunk :: ToJSON v => [(String, v)] -> JSONChunk [(String, v)]
JSONChunk :: ToJSON' v => [(String, v)] -> JSONChunk [(String, v)]
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)
JSONChunk l -> object $ map mkPair l
mkPair (s, d) = (packString s, toJSON' d)
add _ Nothing = Nothing
complete :: JSONChunk v -> JSONBuilder
@ -145,8 +144,8 @@ data DualDisp = DualDisp
, dispJson :: String
}
instance ToJSON DualDisp where
toJSON = toJSON . dispJson
instance ToJSON' DualDisp where
toJSON' = toJSON' . dispJson
instance Show DualDisp where
show = dispNormal
@ -156,10 +155,10 @@ instance Show DualDisp where
-- 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
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)
go (k, v) = (packString k, toJSON' v)
-- An item that a git-annex command acts on, and displays a JSON object about.
data JSONActionItem a = JSONActionItem
@ -170,13 +169,13 @@ data JSONActionItem a = JSONActionItem
}
deriving (Show)
instance ToJSON (JSONActionItem a) where
toJSON i = object $ catMaybes
instance ToJSON' (JSONActionItem a) where
toJSON' i = object $ catMaybes
[ Just $ "command" .= itemCommand i
, case itemKey i of
Nothing -> Nothing
Just k -> Just $ "key" .= toJSON k
, Just $ "file" .= itemFile i
Just k -> Just $ "key" .= toJSON' k
, Just $ "file" .= toJSON' (itemFile i)
-- itemAdded is not included; must be added later by 'add'
]