24938e320442cf3ca96e9697c2555e362dc5f70c
[ganeti-github.git] / src / Ganeti / JSON.hs
1 {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, TupleSections,
2 GeneralizedNewtypeDeriving, DeriveTraversable #-}
3 {-# OPTIONS_GHC -fno-warn-orphans #-}
4
5 {-| JSON utility functions. -}
6
7 {-
8
9 Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
10 All rights reserved.
11
12 Redistribution and use in source and binary forms, with or without
13 modification, are permitted provided that the following conditions are
14 met:
15
16 1. Redistributions of source code must retain the above copyright notice,
17 this list of conditions and the following disclaimer.
18
19 2. Redistributions in binary form must reproduce the above copyright
20 notice, this list of conditions and the following disclaimer in the
21 documentation and/or other materials provided with the distribution.
22
23 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
24 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
25 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
26 PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
27 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
28 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
29 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
30 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
31 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
32 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
33 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
34
35 -}
36
37 module Ganeti.JSON
38 ( fromJResult
39 , fromJResultE
40 , readJSONWithDesc
41 , readEitherString
42 , JSRecord
43 , loadJSArray
44 , fromObj
45 , maybeFromObj
46 , fromObjWithDefault
47 , fromKeyValue
48 , fromJVal
49 , fromJValE
50 , jsonHead
51 , getMaybeJsonHead
52 , getMaybeJsonElem
53 , asJSObject
54 , asObjectList
55 , tryFromObj
56 , arrayMaybeFromJVal
57 , tryArrayMaybeFromObj
58 , toArray
59 , optionalJSField
60 , optFieldsToObj
61 , containerFromList
62 , lookupContainer
63 , alterContainerL
64 , readContainer
65 , mkUsedKeys
66 , allUsedKeys
67 , DictObject(..)
68 , showJSONtoDict
69 , readJSONfromDict
70 , ArrayObject(..)
71 , HasStringRepr(..)
72 , GenericContainer(..)
73 , emptyContainer
74 , Container
75 , MaybeForJSON(..)
76 , TimeAsDoubleJSON(..)
77 , Tuple5(..)
78 , nestedAccessByKey
79 , nestedAccessByKeyDotted
80 , branchOnField
81 , addField
82 , maybeParseMap
83 )
84 where
85
86 import Control.Applicative
87 import Control.DeepSeq
88 import Control.Monad.Error.Class
89 import Control.Monad.Writer
90 import qualified Data.ByteString as BS
91 import qualified Data.ByteString.UTF8 as UTF8
92 import qualified Data.Foldable as F
93 import qualified Data.Text as T
94 import qualified Data.Traversable as F
95 import Data.Maybe (fromMaybe, catMaybes)
96 import qualified Data.Map as Map
97 import qualified Data.Set as Set
98 import System.Time (ClockTime(..))
99 import Text.Printf (printf)
100
101 import qualified Text.JSON as J
102 import qualified Text.JSON.Types as JT
103 import Text.JSON.Pretty (pp_value)
104
105 -- Note: this module should not import any Ganeti-specific modules
106 -- beside BasicTypes, since it's used in THH which is used itself to
107 -- build many other modules.
108
109 import Ganeti.BasicTypes
110
111 -- Remove after we require >= 1.8.58
112 -- See: https://github.com/ndmitchell/hlint/issues/24
113 {-# ANN module "HLint: ignore Unused LANGUAGE pragma" #-}
114
115 -- * JSON-related functions
116
117 instance NFData J.JSValue where
118 rnf J.JSNull = ()
119 rnf (J.JSBool b) = rnf b
120 rnf (J.JSRational b r) = rnf b `seq` rnf r
121 rnf (J.JSString s) = rnf $ J.fromJSString s
122 rnf (J.JSArray a) = rnf a
123 rnf (J.JSObject o) = rnf o
124
125 instance (NFData a) => NFData (J.JSObject a) where
126 rnf = rnf . J.fromJSObject
127
128 -- | A type alias for a field of a JSRecord.
129 type JSField = (String, J.JSValue)
130
131 -- | A type alias for the list-based representation of J.JSObject.
132 type JSRecord = [JSField]
133
134 -- | Annotate @readJSON@ error messages with descriptions of what
135 -- is being parsed into what.
136 readJSONWithDesc :: (J.JSON a)
137 => String -- ^ description of @a@
138 -> Bool -- ^ include input in
139 -- error messages
140 -> J.JSValue -- ^ input value
141 -> J.Result a
142 readJSONWithDesc name incInput input =
143 case J.readJSON input of
144 J.Ok r -> J.Ok r
145 J.Error e -> J.Error $ if incInput then msg ++ " from " ++ show input
146 else msg
147 where msg = "Can't parse value for '" ++ name ++ "': " ++ e
148
149 -- | Converts a JSON Result into a monadic value.
150 fromJResult :: Monad m => String -> J.Result a -> m a
151 fromJResult s (J.Error x) = fail (s ++ ": " ++ x)
152 fromJResult _ (J.Ok x) = return x
153
154 -- | Converts a JSON Result into a MonadError value.
155 fromJResultE :: (Error e, MonadError e m) => String -> J.Result a -> m a
156 fromJResultE s (J.Error x) = throwError . strMsg $ s ++ ": " ++ x
157 fromJResultE _ (J.Ok x) = return x
158
159 -- | Tries to read a string from a JSON value.
160 --
161 -- In case the value was not a string, we fail the read (in the
162 -- context of the current monad.
163 readEitherString :: (Monad m) => J.JSValue -> m String
164 readEitherString v =
165 case v of
166 J.JSString s -> return $ J.fromJSString s
167 _ -> fail "Wrong JSON type"
168
169 -- | Converts a JSON message into an array of JSON objects.
170 loadJSArray :: (Monad m)
171 => String -- ^ Operation description (for error reporting)
172 -> String -- ^ Input message
173 -> m [J.JSObject J.JSValue]
174 loadJSArray s = fromJResult s . J.decodeStrict
175
176 -- | Helper function for missing-key errors
177 buildNoKeyError :: JSRecord -> String -> String
178 buildNoKeyError o k =
179 printf "key '%s' not found, object contains only %s" k (show (map fst o))
180
181 -- | Reads the value of a key in a JSON object.
182 fromObj :: (J.JSON a, Monad m) => JSRecord -> String -> m a
183 fromObj o k =
184 case lookup k o of
185 Nothing -> fail $ buildNoKeyError o k
186 Just val -> fromKeyValue k val
187
188 -- | Reads the value of an optional key in a JSON object. Missing
189 -- keys, or keys that have a \'null\' value, will be returned as
190 -- 'Nothing', otherwise we attempt deserialisation and return a 'Just'
191 -- value.
192 maybeFromObj :: (J.JSON a, Monad m) =>
193 JSRecord -> String -> m (Maybe a)
194 maybeFromObj o k =
195 case lookup k o of
196 Nothing -> return Nothing
197 -- a optional key with value JSNull is the same as missing, since
198 -- we can't convert it meaningfully anyway to a Haskell type, and
199 -- the Python code can emit 'null' for optional values (depending
200 -- on usage), and finally our encoding rules treat 'null' values
201 -- as 'missing'
202 Just J.JSNull -> return Nothing
203 Just val -> liftM Just (fromKeyValue k val)
204
205 -- | Reads the value of a key in a JSON object with a default if
206 -- missing. Note that both missing keys and keys with value \'null\'
207 -- will cause the default value to be returned.
208 fromObjWithDefault :: (J.JSON a, Monad m) =>
209 JSRecord -> String -> a -> m a
210 fromObjWithDefault o k d = liftM (fromMaybe d) $ maybeFromObj o k
211
212 arrayMaybeFromJVal :: (J.JSON a, Monad m) => J.JSValue -> m [Maybe a]
213 arrayMaybeFromJVal (J.JSArray xs) =
214 mapM parse xs
215 where
216 parse J.JSNull = return Nothing
217 parse x = liftM Just $ fromJVal x
218 arrayMaybeFromJVal v =
219 fail $ "Expecting array, got '" ++ show (pp_value v) ++ "'"
220
221 -- | Reads an array of optional items
222 arrayMaybeFromObj :: (J.JSON a, Monad m) =>
223 JSRecord -> String -> m [Maybe a]
224 arrayMaybeFromObj o k =
225 case lookup k o of
226 Just a -> arrayMaybeFromJVal a
227 _ -> fail $ buildNoKeyError o k
228
229 -- | Wrapper for arrayMaybeFromObj with better diagnostic
230 tryArrayMaybeFromObj :: (J.JSON a)
231 => String -- ^ Textual "owner" in error messages
232 -> JSRecord -- ^ The object array
233 -> String -- ^ The desired key from the object
234 -> Result [Maybe a]
235 tryArrayMaybeFromObj t o = annotateResult t . arrayMaybeFromObj o
236
237 -- | Reads a JValue, that originated from an object key.
238 fromKeyValue :: (J.JSON a, Monad m)
239 => String -- ^ The key name
240 -> J.JSValue -- ^ The value to read
241 -> m a
242 fromKeyValue k val =
243 fromJResult (printf "key '%s'" k) (J.readJSON val)
244
245 -- | Small wrapper over readJSON.
246 fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a
247 fromJVal v =
248 case J.readJSON v of
249 J.Error s -> fail ("Cannot convert value '" ++ show (pp_value v) ++
250 "', error: " ++ s)
251 J.Ok x -> return x
252
253 -- | Small wrapper over 'readJSON' for 'MonadError'.
254 fromJValE :: (Error e, MonadError e m, J.JSON a) => J.JSValue -> m a
255 fromJValE v =
256 case J.readJSON v of
257 J.Error s -> throwError . strMsg $
258 "Cannot convert value '" ++ show (pp_value v) ++
259 "', error: " ++ s
260 J.Ok x -> return x
261
262 -- | Helper function that returns Null or first element of the list.
263 jsonHead :: (J.JSON b) => [a] -> (a -> b) -> J.JSValue
264 jsonHead [] _ = J.JSNull
265 jsonHead (x:_) f = J.showJSON $ f x
266
267 -- | Helper for extracting Maybe values from a possibly empty list.
268 getMaybeJsonHead :: (J.JSON b) => [a] -> (a -> Maybe b) -> J.JSValue
269 getMaybeJsonHead [] _ = J.JSNull
270 getMaybeJsonHead (x:_) f = maybe J.JSNull J.showJSON (f x)
271
272 -- | Helper for extracting Maybe values from a list that might be too short.
273 getMaybeJsonElem :: (J.JSON b) => [a] -> Int -> (a -> Maybe b) -> J.JSValue
274 getMaybeJsonElem [] _ _ = J.JSNull
275 getMaybeJsonElem xs 0 f = getMaybeJsonHead xs f
276 getMaybeJsonElem (_:xs) n f
277 | n < 0 = J.JSNull
278 | otherwise = getMaybeJsonElem xs (n - 1) f
279
280 -- | Converts a JSON value into a JSON object.
281 asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue)
282 asJSObject (J.JSObject a) = return a
283 asJSObject _ = fail "not an object"
284
285 -- | Coneverts a list of JSON values into a list of JSON objects.
286 asObjectList :: (Monad m) => [J.JSValue] -> m [J.JSObject J.JSValue]
287 asObjectList = mapM asJSObject
288
289 -- | Try to extract a key from an object with better error reporting
290 -- than fromObj.
291 tryFromObj :: (J.JSON a) =>
292 String -- ^ Textual "owner" in error messages
293 -> JSRecord -- ^ The object array
294 -> String -- ^ The desired key from the object
295 -> Result a
296 tryFromObj t o = annotateResult t . fromObj o
297
298 -- | Ensure a given JSValue is actually a JSArray.
299 toArray :: (Monad m) => J.JSValue -> m [J.JSValue]
300 toArray (J.JSArray arr) = return arr
301 toArray o =
302 fail $ "Invalid input, expected array but got " ++ show (pp_value o)
303
304 -- | Creates a Maybe JSField. If the value string is Nothing, the JSField
305 -- will be Nothing as well.
306 optionalJSField :: (J.JSON a) => String -> Maybe a -> Maybe JSField
307 optionalJSField name (Just value) = Just (name, J.showJSON value)
308 optionalJSField _ Nothing = Nothing
309
310 -- | Creates an object with all the non-Nothing fields of the given list.
311 optFieldsToObj :: [Maybe JSField] -> J.JSValue
312 optFieldsToObj = J.makeObj . catMaybes
313
314 -- * Container type (special type for JSON serialisation)
315
316 -- | Class of types that can be converted from Strings. This is
317 -- similar to the 'Read' class, but it's using a different
318 -- serialisation format, so we have to define a separate class. Mostly
319 -- useful for custom key types in JSON dictionaries, which have to be
320 -- backed by strings.
321 class HasStringRepr a where
322 fromStringRepr :: (Monad m) => String -> m a
323 toStringRepr :: a -> String
324
325 -- | Trivial instance 'HasStringRepr' for 'String'.
326 instance HasStringRepr String where
327 fromStringRepr = return
328 toStringRepr = id
329
330 -- | The container type, a wrapper over Data.Map
331 newtype GenericContainer a b =
332 GenericContainer { fromContainer :: Map.Map a b }
333 deriving (Show, Eq, Ord, Functor, F.Foldable, F.Traversable)
334
335 instance (NFData a, NFData b) => NFData (GenericContainer a b) where
336 rnf = rnf . Map.toList . fromContainer
337
338 -- | The empty container.
339 emptyContainer :: GenericContainer a b
340 emptyContainer = GenericContainer Map.empty
341
342 -- | Type alias for string keys.
343 type Container = GenericContainer BS.ByteString
344
345 instance HasStringRepr BS.ByteString where
346 fromStringRepr = return . UTF8.fromString
347 toStringRepr = UTF8.toString
348
349 -- | Creates a GenericContainer from a list of key-value pairs.
350 containerFromList :: Ord a => [(a,b)] -> GenericContainer a b
351 containerFromList = GenericContainer . Map.fromList
352
353 -- | Looks up a value in a container with a default value.
354 -- If a key has no value, a given monadic default is returned.
355 -- This allows simple error handling, as the default can be
356 -- 'mzero', 'failError' etc.
357 lookupContainer :: (Monad m, Ord a)
358 => m b -> a -> GenericContainer a b -> m b
359 lookupContainer dflt k = maybe dflt return . Map.lookup k . fromContainer
360
361 -- | Updates a value inside a container.
362 -- The signature of the function is crafted so that it can be directly
363 -- used as a lens.
364 alterContainerL :: (Functor f, Ord a)
365 => a
366 -> (Maybe b -> f (Maybe b))
367 -> GenericContainer a b
368 -> f (GenericContainer a b)
369 alterContainerL key f (GenericContainer m) =
370 fmap (\v -> GenericContainer $ Map.alter (const v) key m)
371 (f $ Map.lookup key m)
372
373 -- | Container loader.
374 readContainer :: (Monad m, HasStringRepr a, Ord a, J.JSON b) =>
375 J.JSObject J.JSValue -> m (GenericContainer a b)
376 readContainer obj = do
377 let kjvlist = J.fromJSObject obj
378 kalist <- mapM (\(k, v) -> do
379 k' <- fromStringRepr k
380 v' <- fromKeyValue k v
381 return (k', v')) kjvlist
382 return $ GenericContainer (Map.fromList kalist)
383
384 {-# ANN showContainer "HLint: ignore Use ***" #-}
385 -- | Container dumper.
386 showContainer :: (HasStringRepr a, J.JSON b) =>
387 GenericContainer a b -> J.JSValue
388 showContainer =
389 J.makeObj . map (\(k, v) -> (toStringRepr k, J.showJSON v)) .
390 Map.toList . fromContainer
391
392 instance (HasStringRepr a, Ord a, J.JSON b) =>
393 J.JSON (GenericContainer a b) where
394 showJSON = showContainer
395 readJSON (J.JSObject o) = readContainer o
396 readJSON v = fail $ "Failed to load container, expected object but got "
397 ++ show (pp_value v)
398
399 -- * Types that (de)serialize in a special form of JSON
400
401 newtype UsedKeys = UsedKeys (Maybe (Set.Set String))
402
403 instance Monoid UsedKeys where
404 mempty = UsedKeys (Just Set.empty)
405 mappend (UsedKeys xs) (UsedKeys ys) = UsedKeys $ liftA2 Set.union xs ys
406
407 mkUsedKeys :: Set.Set String -> UsedKeys
408 mkUsedKeys = UsedKeys . Just
409
410 allUsedKeys :: UsedKeys
411 allUsedKeys = UsedKeys Nothing
412
413 -- | Class of objects that can be converted from and to 'JSObject'
414 -- lists-format.
415 class DictObject a where
416 toDict :: a -> [(String, J.JSValue)]
417 fromDictWKeys :: [(String, J.JSValue)] -> WriterT UsedKeys J.Result a
418 fromDict :: [(String, J.JSValue)] -> J.Result a
419 fromDict = liftM fst . runWriterT . fromDictWKeys
420
421 -- | A default implementation of 'showJSON' using 'toDict'.
422 showJSONtoDict :: (DictObject a) => a -> J.JSValue
423 showJSONtoDict = J.makeObj . toDict
424
425 -- | A default implementation of 'readJSON' using 'fromDict'.
426 -- Checks that the input value is a JSON object and
427 -- converts it using 'fromDict'.
428 -- Also checks the input contains only the used keys returned by 'fromDict'.
429 readJSONfromDict :: (DictObject a)
430 => J.JSValue -> J.Result a
431 readJSONfromDict jsv = do
432 dict <- liftM J.fromJSObject $ J.readJSON jsv
433 (r, UsedKeys keys) <- runWriterT $ fromDictWKeys dict
434 -- check that no superfluous dictionary keys are present
435 case keys of
436 Just allowedSet | not (Set.null superfluous) ->
437 fail $ "Superfluous dictionary keys: "
438 ++ show (Set.toAscList superfluous) ++ ", but only "
439 ++ show (Set.toAscList allowedSet) ++ " allowed."
440 where
441 superfluous = Set.fromList (map fst dict) Set.\\ allowedSet
442 _ -> return ()
443 return r
444
445 -- | Class of objects that can be converted from and to @[JSValue]@ with
446 -- a fixed length and order.
447 class ArrayObject a where
448 toJSArray :: a -> [J.JSValue]
449 fromJSArray :: [J.JSValue] -> J.Result a
450
451 -- * General purpose data types for working with JSON
452
453 -- | A Maybe newtype that allows for serialization more appropriate to the
454 -- semantics of Maybe and JSON in our calls. Does not produce needless
455 -- and confusing dictionaries.
456 --
457 -- In particular, `J.JSNull` corresponds to `Nothing`.
458 -- This also means that this `Maybe a` newtype should not be used with `a`
459 -- values that themselves can serialize to `null`.
460 newtype MaybeForJSON a = MaybeForJSON { unMaybeForJSON :: Maybe a }
461 deriving (Show, Eq, Ord)
462 instance (J.JSON a) => J.JSON (MaybeForJSON a) where
463 readJSON J.JSNull = return $ MaybeForJSON Nothing
464 readJSON x = (MaybeForJSON . Just) `liftM` J.readJSON x
465 showJSON (MaybeForJSON (Just x)) = J.showJSON x
466 showJSON (MaybeForJSON Nothing) = J.JSNull
467
468 newtype TimeAsDoubleJSON
469 = TimeAsDoubleJSON { unTimeAsDoubleJSON :: ClockTime }
470 deriving (Show, Eq, Ord)
471 instance J.JSON TimeAsDoubleJSON where
472 readJSON v = do
473 t <- J.readJSON v :: J.Result Double
474 return . TimeAsDoubleJSON . uncurry TOD
475 $ divMod (round $ t * pico) (pico :: Integer)
476 where
477 pico :: (Num a) => a
478 pico = 10^(12 :: Int)
479 showJSON (TimeAsDoubleJSON (TOD ss ps)) = J.showJSON
480 (fromIntegral ss + fromIntegral ps / 10^(12 :: Int) :: Double)
481
482 -- Text.JSON from the JSON package only has instances for tuples up to size 4.
483 -- We use these newtypes so that we don't get a breakage once the 'json'
484 -- package adds instances for larger tuples (or have to resort to CPP).
485
486 newtype Tuple5 a b c d e = Tuple5 { unTuple5 :: (a, b, c, d, e) }
487
488 instance (J.JSON a, J.JSON b, J.JSON c, J.JSON d, J.JSON e)
489 => J.JSON (Tuple5 a b c d e) where
490 readJSON (J.JSArray [a,b,c,d,e]) =
491 Tuple5 <$> ((,,,,) <$> J.readJSON a
492 <*> J.readJSON b
493 <*> J.readJSON c
494 <*> J.readJSON d
495 <*> J.readJSON e)
496 readJSON _ = fail "Unable to read Tuple5"
497 showJSON (Tuple5 (a, b, c, d, e)) =
498 J.JSArray
499 [ J.showJSON a
500 , J.showJSON b
501 , J.showJSON c
502 , J.showJSON d
503 , J.showJSON e
504 ]
505
506
507 -- | Look up a value in a JSON object. Accessing @["a", "b", "c"]@ on an
508 -- object is equivalent as accessing @myobject.a.b.c@ on a JavaScript object.
509 --
510 -- An error is returned if the object doesn't have such an accessor or if
511 -- any value during the nested access is not an object at all.
512 nestedAccessByKey :: [String] -> J.JSValue -> J.Result J.JSValue
513 nestedAccessByKey keys json = case keys of
514 [] -> return json
515 k:ks -> case json of
516 J.JSObject obj -> J.valFromObj k obj >>= nestedAccessByKey ks
517 _ -> J.Error $ "Cannot access non-object with key '" ++ k ++ "'"
518
519
520 -- | Same as `nestedAccessByKey`, but accessing with a dotted string instead
521 -- (like @nestedAccessByKeyDotted "a.b.c"@).
522 nestedAccessByKeyDotted :: String -> J.JSValue -> J.Result J.JSValue
523 nestedAccessByKeyDotted s =
524 nestedAccessByKey (map T.unpack . T.splitOn (T.pack ".") . T.pack $ s)
525
526
527 -- | Branch decoding on a field in a JSON object.
528 branchOnField :: String -- ^ fieldname to branch on
529 -> (J.JSValue -> J.Result a)
530 -- ^ decoding function if field is present and @true@; field
531 -- will already be removed in the input
532 -> (J.JSValue -> J.Result a)
533 -- ^ decoding function otherwise
534 -> J.JSValue -> J.Result a
535 branchOnField k ifTrue ifFalse (J.JSObject jobj) =
536 let fields = J.fromJSObject jobj
537 jobj' = J.JSObject . J.toJSObject $ filter ((/=) k . fst) fields
538 in if lookup k fields == Just (J.JSBool True)
539 then ifTrue jobj'
540 else ifFalse jobj'
541 branchOnField k _ _ _ = J.Error $ "Need an object to branch on key " ++ k
542
543 -- | Add a field to a JSON object; to nothing, if the argument is not an object.
544 addField :: (String, J.JSValue) -> J.JSValue -> J.JSValue
545 addField (n,v) (J.JSObject obj) = J.JSObject $ JT.set_field obj n v
546 addField _ jsval = jsval
547
548 -- | Maybe obtain a map from a JSON object.
549 maybeParseMap :: J.JSON a => J.JSValue -> Maybe (Map.Map String a)
550 maybeParseMap = liftM fromContainer . readContainer <=< asJSObject