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
|
{- git-annex command-line JSON output and input
-
- Copyright 2011-2016 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,
note,
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.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 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
note :: String -> JSONBuilder
note s (Just (o, e)) = Just (HM.insert "note" (toJSON s) o, e)
note _ Nothing = Nothing
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
|
