1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
|
{- git-annex command-line JSON output and input
-
- Copyright 2011-2018 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings, GADTs #-}
module Messages.JSON (
JSONBuilder,
JSONChunk(..),
emit,
none,
start,
end,
finalize,
addErrorMessage,
note,
info,
add,
complete,
progress,
DualDisp(..),
ObjectMap(..),
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.HashMap.Strict as HM
import System.IO
import System.IO.Unsafe (unsafePerformIO)
import Control.Concurrent
import Data.Maybe
import Data.Monoid
import Prelude
import Types.Messages
import Key
import Utility.Metered
import Utility.Percentage
-- A global lock to avoid concurrent threads emitting json at the same time.
{-# NOINLINE emitLock #-}
emitLock :: MVar ()
emitLock = unsafePerformIO $ newMVar ()
emit :: Object -> IO ()
emit o = do
takeMVar emitLock
B.hPut stdout (encode o)
putStr "\n"
putMVar emitLock ()
-- Building up a JSON object can be done by first using start,
-- then add and note any number of times, and finally complete.
type JSONBuilder = Maybe (Object, Bool) -> Maybe (Object, Bool)
none :: JSONBuilder
none = id
start :: String -> Maybe FilePath -> Maybe Key -> JSONBuilder
start command file key _ = Just (o, False)
where
Object o = toJSON $ JSONActionItem
{ itemCommand = Just command
, itemKey = key
, itemFile = file
, itemAdded = Nothing
}
end :: Bool -> JSONBuilder
end b (Just (o, _)) = Just (HM.insert "success" (toJSON b) o, True)
end _ Nothing = Nothing
finalize :: JSONOptions -> Object -> Object
finalize jsonoptions o
-- Always include error-messages field, even if empty,
-- to make the json be self-documenting.
| jsonErrorMessages jsonoptions = addErrorMessage [] o
| otherwise = o
addErrorMessage :: [String] -> Object -> Object
addErrorMessage msg o =
HM.insertWith combinearray "error-messages" v o
where
combinearray (Array new) (Array old) = Array (old <> new)
combinearray new _old = new
v = Array $ V.fromList $ map (String . T.pack) msg
note :: String -> JSONBuilder
note _ Nothing = Nothing
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)
combinelines new _old = new
info :: String -> JSONBuilder
info s _ = Just (o, True)
where
Object o = object ["info" .= toJSON s]
data JSONChunk v where
AesonObject :: Object -> JSONChunk Object
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)
add _ Nothing = Nothing
complete :: JSONChunk v -> JSONBuilder
complete v _ = add v (Just (HM.empty, True))
-- Show JSON formatted progress, including the current state of the JSON
-- object for the action being performed.
progress :: Maybe Object -> Maybe Integer -> BytesProcessed -> IO ()
progress maction msize bytesprocessed = emit $ case maction of
Just action -> HM.insert "action" (Object action) o
Nothing -> o
where
n = fromBytesProcessed bytesprocessed :: Integer
Object o = case msize of
Just size -> object
[ "byte-progress" .= n
, "percent-progress" .= showPercentage 2 (percentage size n)
, "total-size" .= size
]
Nothing -> object
[ "byte-progress" .= n ]
-- A value that can be displayed either normally, or as JSON.
data DualDisp = DualDisp
{ dispNormal :: String
, dispJson :: String
}
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 item that a git-annex command acts on, and displays a JSON object about.
data JSONActionItem a = JSONActionItem
{ itemCommand :: Maybe String
, itemKey :: Maybe Key
, itemFile :: Maybe FilePath
, itemAdded :: Maybe a -- for additional fields added by `add`
}
deriving (Show)
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
-- itemAdded is not included; must be added later by 'add'
]
instance FromJSON a => FromJSON (JSONActionItem a) where
parseJSON (Object v) = JSONActionItem
<$> (v .:? "command")
<*> (maybe (return Nothing) parseJSON =<< (v .:? "key"))
<*> (v .:? "file")
<*> parseadded
where
parseadded = (Just <$> parseJSON (Object v)) <|> return Nothing
parseJSON _ = mempty
|
