Don't keep input for error messages
[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 -> J.JSValue -- ^ input value
139 -> J.Result a
140 readJSONWithDesc name input =
141 case J.readJSON input of
142 J.Ok r -> J.Ok r
143 J.Error e -> J.Error $ "Can't parse value for '" ++ name ++ "': " ++ e
144
145 -- | Converts a JSON Result into a monadic value.
146 fromJResult :: Monad m => String -> J.Result a -> m a
147 fromJResult s (J.Error x) = fail (s ++ ": " ++ x)
148 fromJResult _ (J.Ok x) = return x
149
150 -- | Converts a JSON Result into a MonadError value.
151 fromJResultE :: (Error e, MonadError e m) => String -> J.Result a -> m a
152 fromJResultE s (J.Error x) = throwError . strMsg $ s ++ ": " ++ x
153 fromJResultE _ (J.Ok x) = return x
154
155 -- | Tries to read a string from a JSON value.
156 --
157 -- In case the value was not a string, we fail the read (in the
158 -- context of the current monad.
159 readEitherString :: (Monad m) => J.JSValue -> m String
160 readEitherString v =
161 case v of
162 J.JSString s -> return $ J.fromJSString s
163 _ -> fail "Wrong JSON type"
164
165 -- | Converts a JSON message into an array of JSON objects.
166 loadJSArray :: (Monad m)
167 => String -- ^ Operation description (for error reporting)
168 -> String -- ^ Input message
169 -> m [J.JSObject J.JSValue]
170 loadJSArray s = fromJResult s . J.decodeStrict
171
172 -- | Helper function for missing-key errors
173 buildNoKeyError :: JSRecord -> String -> String
174 buildNoKeyError o k =
175 printf "key '%s' not found, object contains only %s" k (show (map fst o))
176
177 -- | Reads the value of a key in a JSON object.
178 fromObj :: (J.JSON a, Monad m) => JSRecord -> String -> m a
179 fromObj o k =
180 case lookup k o of
181 Nothing -> fail $ buildNoKeyError o k
182 Just val -> fromKeyValue k val
183
184 -- | Reads the value of an optional key in a JSON object. Missing
185 -- keys, or keys that have a \'null\' value, will be returned as
186 -- 'Nothing', otherwise we attempt deserialisation and return a 'Just'
187 -- value.
188 maybeFromObj :: (J.JSON a, Monad m) =>
189 JSRecord -> String -> m (Maybe a)
190 maybeFromObj o k =
191 case lookup k o of
192 Nothing -> return Nothing
193 -- a optional key with value JSNull is the same as missing, since
194 -- we can't convert it meaningfully anyway to a Haskell type, and
195 -- the Python code can emit 'null' for optional values (depending
196 -- on usage), and finally our encoding rules treat 'null' values
197 -- as 'missing'
198 Just J.JSNull -> return Nothing
199 Just val -> liftM Just (fromKeyValue k val)
200
201 -- | Reads the value of a key in a JSON object with a default if
202 -- missing. Note that both missing keys and keys with value \'null\'
203 -- will cause the default value to be returned.
204 fromObjWithDefault :: (J.JSON a, Monad m) =>
205 JSRecord -> String -> a -> m a
206 fromObjWithDefault o k d = liftM (fromMaybe d) $ maybeFromObj o k
207
208 arrayMaybeFromJVal :: (J.JSON a, Monad m) => J.JSValue -> m [Maybe a]
209 arrayMaybeFromJVal (J.JSArray xs) =
210 mapM parse xs
211 where
212 parse J.JSNull = return Nothing
213 parse x = liftM Just $ fromJVal x
214 arrayMaybeFromJVal v =
215 fail $ "Expecting array, got '" ++ show (pp_value v) ++ "'"
216
217 -- | Reads an array of optional items
218 arrayMaybeFromObj :: (J.JSON a, Monad m) =>
219 JSRecord -> String -> m [Maybe a]
220 arrayMaybeFromObj o k =
221 case lookup k o of
222 Just a -> arrayMaybeFromJVal a
223 _ -> fail $ buildNoKeyError o k
224
225 -- | Wrapper for arrayMaybeFromObj with better diagnostic
226 tryArrayMaybeFromObj :: (J.JSON a)
227 => String -- ^ Textual "owner" in error messages
228 -> JSRecord -- ^ The object array
229 -> String -- ^ The desired key from the object
230 -> Result [Maybe a]
231 tryArrayMaybeFromObj t o = annotateResult t . arrayMaybeFromObj o
232
233 -- | Reads a JValue, that originated from an object key.
234 fromKeyValue :: (J.JSON a, Monad m)
235 => String -- ^ The key name
236 -> J.JSValue -- ^ The value to read
237 -> m a
238 fromKeyValue k val =
239 fromJResult (printf "key '%s'" k) (J.readJSON val)
240
241 -- | Small wrapper over readJSON.
242 fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a
243 fromJVal v =
244 case J.readJSON v of
245 J.Error s -> fail ("Cannot convert value '" ++ show (pp_value v) ++
246 "', error: " ++ s)
247 J.Ok x -> return x
248
249 -- | Small wrapper over 'readJSON' for 'MonadError'.
250 fromJValE :: (Error e, MonadError e m, J.JSON a) => J.JSValue -> m a
251 fromJValE v =
252 case J.readJSON v of
253 J.Error s -> throwError . strMsg $
254 "Cannot convert value '" ++ show (pp_value v) ++
255 "', error: " ++ s
256 J.Ok x -> return x
257
258 -- | Helper function that returns Null or first element of the list.
259 jsonHead :: (J.JSON b) => [a] -> (a -> b) -> J.JSValue
260 jsonHead [] _ = J.JSNull
261 jsonHead (x:_) f = J.showJSON $ f x
262
263 -- | Helper for extracting Maybe values from a possibly empty list.
264 getMaybeJsonHead :: (J.JSON b) => [a] -> (a -> Maybe b) -> J.JSValue
265 getMaybeJsonHead [] _ = J.JSNull
266 getMaybeJsonHead (x:_) f = maybe J.JSNull J.showJSON (f x)
267
268 -- | Helper for extracting Maybe values from a list that might be too short.
269 getMaybeJsonElem :: (J.JSON b) => [a] -> Int -> (a -> Maybe b) -> J.JSValue
270 getMaybeJsonElem [] _ _ = J.JSNull
271 getMaybeJsonElem xs 0 f = getMaybeJsonHead xs f
272 getMaybeJsonElem (_:xs) n f
273 | n < 0 = J.JSNull
274 | otherwise = getMaybeJsonElem xs (n - 1) f
275
276 -- | Converts a JSON value into a JSON object.
277 asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue)
278 asJSObject (J.JSObject a) = return a
279 asJSObject _ = fail "not an object"
280
281 -- | Coneverts a list of JSON values into a list of JSON objects.
282 asObjectList :: (Monad m) => [J.JSValue] -> m [J.JSObject J.JSValue]
283 asObjectList = mapM asJSObject
284
285 -- | Try to extract a key from an object with better error reporting
286 -- than fromObj.
287 tryFromObj :: (J.JSON a) =>
288 String -- ^ Textual "owner" in error messages
289 -> JSRecord -- ^ The object array
290 -> String -- ^ The desired key from the object
291 -> Result a
292 tryFromObj t o = annotateResult t . fromObj o
293
294 -- | Ensure a given JSValue is actually a JSArray.
295 toArray :: (Monad m) => J.JSValue -> m [J.JSValue]
296 toArray (J.JSArray arr) = return arr
297 toArray o =
298 fail $ "Invalid input, expected array but got " ++ show (pp_value o)
299
300 -- | Creates a Maybe JSField. If the value string is Nothing, the JSField
301 -- will be Nothing as well.
302 optionalJSField :: (J.JSON a) => String -> Maybe a -> Maybe JSField
303 optionalJSField name (Just value) = Just (name, J.showJSON value)
304 optionalJSField _ Nothing = Nothing
305
306 -- | Creates an object with all the non-Nothing fields of the given list.
307 optFieldsToObj :: [Maybe JSField] -> J.JSValue
308 optFieldsToObj = J.makeObj . catMaybes
309
310 -- * Container type (special type for JSON serialisation)
311
312 -- | Class of types that can be converted from Strings. This is
313 -- similar to the 'Read' class, but it's using a different
314 -- serialisation format, so we have to define a separate class. Mostly
315 -- useful for custom key types in JSON dictionaries, which have to be
316 -- backed by strings.
317 class HasStringRepr a where
318 fromStringRepr :: (Monad m) => String -> m a
319 toStringRepr :: a -> String
320
321 -- | Trivial instance 'HasStringRepr' for 'String'.
322 instance HasStringRepr String where
323 fromStringRepr = return
324 toStringRepr = id
325
326 -- | The container type, a wrapper over Data.Map
327 newtype GenericContainer a b =
328 GenericContainer { fromContainer :: Map.Map a b }
329 deriving (Show, Eq, Ord, Functor, F.Foldable, F.Traversable)
330
331 instance (NFData a, NFData b) => NFData (GenericContainer a b) where
332 rnf = rnf . Map.toList . fromContainer
333
334 -- | The empty container.
335 emptyContainer :: GenericContainer a b
336 emptyContainer = GenericContainer Map.empty
337
338 -- | Type alias for string keys.
339 type Container = GenericContainer BS.ByteString
340
341 instance HasStringRepr BS.ByteString where
342 fromStringRepr = return . UTF8.fromString
343 toStringRepr = UTF8.toString
344
345 -- | Creates a GenericContainer from a list of key-value pairs.
346 containerFromList :: Ord a => [(a,b)] -> GenericContainer a b
347 containerFromList = GenericContainer . Map.fromList
348
349 -- | Looks up a value in a container with a default value.
350 -- If a key has no value, a given monadic default is returned.
351 -- This allows simple error handling, as the default can be
352 -- 'mzero', 'failError' etc.
353 lookupContainer :: (Monad m, Ord a)
354 => m b -> a -> GenericContainer a b -> m b
355 lookupContainer dflt k = maybe dflt return . Map.lookup k . fromContainer
356
357 -- | Updates a value inside a container.
358 -- The signature of the function is crafted so that it can be directly
359 -- used as a lens.
360 alterContainerL :: (Functor f, Ord a)
361 => a
362 -> (Maybe b -> f (Maybe b))
363 -> GenericContainer a b
364 -> f (GenericContainer a b)
365 alterContainerL key f (GenericContainer m) =
366 fmap (\v -> GenericContainer $ Map.alter (const v) key m)
367 (f $ Map.lookup key m)
368
369 -- | Container loader.
370 readContainer :: (Monad m, HasStringRepr a, Ord a, J.JSON b) =>
371 J.JSObject J.JSValue -> m (GenericContainer a b)
372 readContainer obj = do
373 let kjvlist = J.fromJSObject obj
374 kalist <- mapM (\(k, v) -> do
375 k' <- fromStringRepr k
376 v' <- fromKeyValue k v
377 return (k', v')) kjvlist
378 return $ GenericContainer (Map.fromList kalist)
379
380 {-# ANN showContainer "HLint: ignore Use ***" #-}
381 -- | Container dumper.
382 showContainer :: (HasStringRepr a, J.JSON b) =>
383 GenericContainer a b -> J.JSValue
384 showContainer =
385 J.makeObj . map (\(k, v) -> (toStringRepr k, J.showJSON v)) .
386 Map.toList . fromContainer
387
388 instance (HasStringRepr a, Ord a, J.JSON b) =>
389 J.JSON (GenericContainer a b) where
390 showJSON = showContainer
391 readJSON (J.JSObject o) = readContainer o
392 readJSON v = fail $ "Failed to load container, expected object but got "
393 ++ show (pp_value v)
394
395 -- * Types that (de)serialize in a special form of JSON
396
397 newtype UsedKeys = UsedKeys (Maybe (Set.Set String))
398
399 instance Monoid UsedKeys where
400 mempty = UsedKeys (Just Set.empty)
401 mappend (UsedKeys xs) (UsedKeys ys) = UsedKeys $ liftA2 Set.union xs ys
402
403 mkUsedKeys :: Set.Set String -> UsedKeys
404 mkUsedKeys = UsedKeys . Just
405
406 allUsedKeys :: UsedKeys
407 allUsedKeys = UsedKeys Nothing
408
409 -- | Class of objects that can be converted from and to 'JSObject'
410 -- lists-format.
411 class DictObject a where
412 toDict :: a -> [(String, J.JSValue)]
413 fromDictWKeys :: [(String, J.JSValue)] -> WriterT UsedKeys J.Result a
414 fromDict :: [(String, J.JSValue)] -> J.Result a
415 fromDict = liftM fst . runWriterT . fromDictWKeys
416
417 -- | A default implementation of 'showJSON' using 'toDict'.
418 showJSONtoDict :: (DictObject a) => a -> J.JSValue
419 showJSONtoDict = J.makeObj . toDict
420
421 -- | A default implementation of 'readJSON' using 'fromDict'.
422 -- Checks that the input value is a JSON object and
423 -- converts it using 'fromDict'.
424 -- Also checks the input contains only the used keys returned by 'fromDict'.
425 readJSONfromDict :: (DictObject a)
426 => J.JSValue -> J.Result a
427 readJSONfromDict jsv = do
428 dict <- liftM J.fromJSObject $ J.readJSON jsv
429 (r, UsedKeys keys) <- runWriterT $ fromDictWKeys dict
430 -- check that no superfluous dictionary keys are present
431 case keys of
432 Just allowedSet | not (Set.null superfluous) ->
433 fail $ "Superfluous dictionary keys: "
434 ++ show (Set.toAscList superfluous) ++ ", but only "
435 ++ show (Set.toAscList allowedSet) ++ " allowed."
436 where
437 superfluous = Set.fromList (map fst dict) Set.\\ allowedSet
438 _ -> return ()
439 return r
440
441 -- | Class of objects that can be converted from and to @[JSValue]@ with
442 -- a fixed length and order.
443 class ArrayObject a where
444 toJSArray :: a -> [J.JSValue]
445 fromJSArray :: [J.JSValue] -> J.Result a
446
447 -- * General purpose data types for working with JSON
448
449 -- | A Maybe newtype that allows for serialization more appropriate to the
450 -- semantics of Maybe and JSON in our calls. Does not produce needless
451 -- and confusing dictionaries.
452 --
453 -- In particular, `J.JSNull` corresponds to `Nothing`.
454 -- This also means that this `Maybe a` newtype should not be used with `a`
455 -- values that themselves can serialize to `null`.
456 newtype MaybeForJSON a = MaybeForJSON { unMaybeForJSON :: Maybe a }
457 deriving (Show, Eq, Ord)
458 instance (J.JSON a) => J.JSON (MaybeForJSON a) where
459 readJSON J.JSNull = return $ MaybeForJSON Nothing
460 readJSON x = (MaybeForJSON . Just) `liftM` J.readJSON x
461 showJSON (MaybeForJSON (Just x)) = J.showJSON x
462 showJSON (MaybeForJSON Nothing) = J.JSNull
463
464 newtype TimeAsDoubleJSON
465 = TimeAsDoubleJSON { unTimeAsDoubleJSON :: ClockTime }
466 deriving (Show, Eq, Ord)
467 instance J.JSON TimeAsDoubleJSON where
468 readJSON v = do
469 t <- J.readJSON v :: J.Result Double
470 return . TimeAsDoubleJSON . uncurry TOD
471 $ divMod (round $ t * pico) (pico :: Integer)
472 where
473 pico :: (Num a) => a
474 pico = 10^(12 :: Int)
475 showJSON (TimeAsDoubleJSON (TOD ss ps)) = J.showJSON
476 (fromIntegral ss + fromIntegral ps / 10^(12 :: Int) :: Double)
477
478 -- Text.JSON from the JSON package only has instances for tuples up to size 4.
479 -- We use these newtypes so that we don't get a breakage once the 'json'
480 -- package adds instances for larger tuples (or have to resort to CPP).
481
482 newtype Tuple5 a b c d e = Tuple5 { unTuple5 :: (a, b, c, d, e) }
483
484 instance (J.JSON a, J.JSON b, J.JSON c, J.JSON d, J.JSON e)
485 => J.JSON (Tuple5 a b c d e) where
486 readJSON (J.JSArray [a,b,c,d,e]) =
487 Tuple5 <$> ((,,,,) <$> J.readJSON a
488 <*> J.readJSON b
489 <*> J.readJSON c
490 <*> J.readJSON d
491 <*> J.readJSON e)
492 readJSON _ = fail "Unable to read Tuple5"
493 showJSON (Tuple5 (a, b, c, d, e)) =
494 J.JSArray
495 [ J.showJSON a
496 , J.showJSON b
497 , J.showJSON c
498 , J.showJSON d
499 , J.showJSON e
500 ]
501
502
503 -- | Look up a value in a JSON object. Accessing @["a", "b", "c"]@ on an
504 -- object is equivalent as accessing @myobject.a.b.c@ on a JavaScript object.
505 --
506 -- An error is returned if the object doesn't have such an accessor or if
507 -- any value during the nested access is not an object at all.
508 nestedAccessByKey :: [String] -> J.JSValue -> J.Result J.JSValue
509 nestedAccessByKey keys json = case keys of
510 [] -> return json
511 k:ks -> case json of
512 J.JSObject obj -> J.valFromObj k obj >>= nestedAccessByKey ks
513 _ -> J.Error $ "Cannot access non-object with key '" ++ k ++ "'"
514
515
516 -- | Same as `nestedAccessByKey`, but accessing with a dotted string instead
517 -- (like @nestedAccessByKeyDotted "a.b.c"@).
518 nestedAccessByKeyDotted :: String -> J.JSValue -> J.Result J.JSValue
519 nestedAccessByKeyDotted s =
520 nestedAccessByKey (map T.unpack . T.splitOn (T.pack ".") . T.pack $ s)
521
522
523 -- | Branch decoding on a field in a JSON object.
524 branchOnField :: String -- ^ fieldname to branch on
525 -> (J.JSValue -> J.Result a)
526 -- ^ decoding function if field is present and @true@; field
527 -- will already be removed in the input
528 -> (J.JSValue -> J.Result a)
529 -- ^ decoding function otherwise
530 -> J.JSValue -> J.Result a
531 branchOnField k ifTrue ifFalse (J.JSObject jobj) =
532 let fields = J.fromJSObject jobj
533 jobj' = J.JSObject . J.toJSObject $ filter ((/=) k . fst) fields
534 in if lookup k fields == Just (J.JSBool True)
535 then ifTrue jobj'
536 else ifFalse jobj'
537 branchOnField k _ _ _ = J.Error $ "Need an object to branch on key " ++ k
538
539 -- | Add a field to a JSON object; to nothing, if the argument is not an object.
540 addField :: (String, J.JSValue) -> J.JSValue -> J.JSValue
541 addField (n,v) (J.JSObject obj) = J.JSObject $ JT.set_field obj n v
542 addField _ jsval = jsval
543
544 -- | Maybe obtain a map from a JSON object.
545 maybeParseMap :: J.JSON a => J.JSValue -> Maybe (Map.Map String a)
546 maybeParseMap = liftM fromContainer . readContainer <=< asJSObject