1 {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 {-| JSON utility functions. -}
8 Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
10 This program is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 2 of the License, or
13 (at your option) any later version.
15 This program is distributed in the hope that it will be useful, but
16 WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 General Public License for more details.
20 You should have received a copy of the GNU General Public License
21 along with this program; if not, write to the Free Software
22 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
44 , tryArrayMaybeFromObj
49 , GenericContainer(..)
54 import Control.DeepSeq
55 import Control.Monad (liftM)
56 import Data.Maybe (fromMaybe, catMaybes)
57 import qualified Data.Map as Map
58 import Text.Printf (printf)
60 import qualified Text.JSON as J
61 import Text.JSON.Pretty (pp_value)
63 -- Note: this module should not import any Ganeti-specific modules
64 -- beside BasicTypes, since it's used in THH which is used itself to
65 -- build many other modules.
67 import Ganeti.BasicTypes
69 -- * JSON-related functions
71 instance NFData J.JSValue where
73 rnf (J.JSBool b) = rnf b
74 rnf (J.JSRational b r) = rnf b `seq` rnf r
75 rnf (J.JSString s) = rnf $ J.fromJSString s
76 rnf (J.JSArray a) = rnf a
77 rnf (J.JSObject o) = rnf o
79 instance (NFData a) => NFData (J.JSObject a) where
80 rnf = rnf . J.fromJSObject
82 -- | A type alias for a field of a JSRecord.
83 type JSField = (String, J.JSValue)
85 -- | A type alias for the list-based representation of J.JSObject.
86 type JSRecord = [JSField]
88 -- | Converts a JSON Result into a monadic value.
89 fromJResult :: Monad m => String -> J.Result a -> m a
90 fromJResult s (J.Error x) = fail (s ++ ": " ++ x)
91 fromJResult _ (J.Ok x) = return x
93 -- | Tries to read a string from a JSON value.
95 -- In case the value was not a string, we fail the read (in the
96 -- context of the current monad.
97 readEitherString :: (Monad m) => J.JSValue -> m String
100 J.JSString s -> return $ J.fromJSString s
101 _ -> fail "Wrong JSON type"
103 -- | Converts a JSON message into an array of JSON objects.
104 loadJSArray :: (Monad m)
105 => String -- ^ Operation description (for error reporting)
106 -> String -- ^ Input message
107 -> m [J.JSObject J.JSValue]
108 loadJSArray s = fromJResult s . J.decodeStrict
110 -- | Helper function for missing-key errors
111 buildNoKeyError :: JSRecord -> String -> String
112 buildNoKeyError o k =
113 printf "key '%s' not found, object contains only %s" k (show (map fst o))
115 -- | Reads the value of a key in a JSON object.
116 fromObj :: (J.JSON a, Monad m) => JSRecord -> String -> m a
119 Nothing -> fail $ buildNoKeyError o k
120 Just val -> fromKeyValue k val
122 -- | Reads the value of an optional key in a JSON object. Missing
123 -- keys, or keys that have a \'null\' value, will be returned as
124 -- 'Nothing', otherwise we attempt deserialisation and return a 'Just'
126 maybeFromObj :: (J.JSON a, Monad m) =>
127 JSRecord -> String -> m (Maybe a)
130 Nothing -> return Nothing
131 -- a optional key with value JSNull is the same as missing, since
132 -- we can't convert it meaningfully anyway to a Haskell type, and
133 -- the Python code can emit 'null' for optional values (depending
134 -- on usage), and finally our encoding rules treat 'null' values
136 Just J.JSNull -> return Nothing
137 Just val -> liftM Just (fromKeyValue k val)
139 -- | Reads the value of a key in a JSON object with a default if
140 -- missing. Note that both missing keys and keys with value \'null\'
141 -- will cause the default value to be returned.
142 fromObjWithDefault :: (J.JSON a, Monad m) =>
143 JSRecord -> String -> a -> m a
144 fromObjWithDefault o k d = liftM (fromMaybe d) $ maybeFromObj o k
146 arrayMaybeFromJVal :: (J.JSON a, Monad m) => J.JSValue -> m [Maybe a]
147 arrayMaybeFromJVal (J.JSArray xs) =
150 parse J.JSNull = return Nothing
151 parse x = liftM Just $ fromJVal x
152 arrayMaybeFromJVal v =
153 fail $ "Expecting array, got '" ++ show (pp_value v) ++ "'"
155 -- | Reads an array of optional items
156 arrayMaybeFromObj :: (J.JSON a, Monad m) =>
157 JSRecord -> String -> m [Maybe a]
158 arrayMaybeFromObj o k =
160 Just a -> arrayMaybeFromJVal a
161 _ -> fail $ buildNoKeyError o k
163 -- | Wrapper for arrayMaybeFromObj with better diagnostic
164 tryArrayMaybeFromObj :: (J.JSON a)
165 => String -- ^ Textual "owner" in error messages
166 -> JSRecord -- ^ The object array
167 -> String -- ^ The desired key from the object
169 tryArrayMaybeFromObj t o = annotateResult t . arrayMaybeFromObj o
171 -- | Reads a JValue, that originated from an object key.
172 fromKeyValue :: (J.JSON a, Monad m)
173 => String -- ^ The key name
174 -> J.JSValue -- ^ The value to read
177 fromJResult (printf "key '%s'" k) (J.readJSON val)
179 -- | Small wrapper over readJSON.
180 fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a
183 J.Error s -> fail ("Cannot convert value '" ++ show (pp_value v) ++
187 -- | Helper function that returns Null or first element of the list.
188 jsonHead :: (J.JSON b) => [a] -> (a -> b) -> J.JSValue
189 jsonHead [] _ = J.JSNull
190 jsonHead (x:_) f = J.showJSON $ f x
192 -- | Helper for extracting Maybe values from a possibly empty list.
193 getMaybeJsonHead :: (J.JSON b) => [a] -> (a -> Maybe b) -> J.JSValue
194 getMaybeJsonHead [] _ = J.JSNull
195 getMaybeJsonHead (x:_) f = maybe J.JSNull J.showJSON (f x)
197 -- | Helper for extracting Maybe values from a list that might be too short.
198 getMaybeJsonElem :: (J.JSON b) => [a] -> Int -> (a -> Maybe b) -> J.JSValue
199 getMaybeJsonElem [] _ _ = J.JSNull
200 getMaybeJsonElem xs 0 f = getMaybeJsonHead xs f
201 getMaybeJsonElem (_:xs) n f
203 | otherwise = getMaybeJsonElem xs (n - 1) f
205 -- | Converts a JSON value into a JSON object.
206 asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue)
207 asJSObject (J.JSObject a) = return a
208 asJSObject _ = fail "not an object"
210 -- | Coneverts a list of JSON values into a list of JSON objects.
211 asObjectList :: (Monad m) => [J.JSValue] -> m [J.JSObject J.JSValue]
212 asObjectList = mapM asJSObject
214 -- | Try to extract a key from an object with better error reporting
216 tryFromObj :: (J.JSON a) =>
217 String -- ^ Textual "owner" in error messages
218 -> JSRecord -- ^ The object array
219 -> String -- ^ The desired key from the object
221 tryFromObj t o = annotateResult t . fromObj o
223 -- | Ensure a given JSValue is actually a JSArray.
224 toArray :: (Monad m) => J.JSValue -> m [J.JSValue]
225 toArray (J.JSArray arr) = return arr
227 fail $ "Invalid input, expected array but got " ++ show (pp_value o)
229 -- | Creates a Maybe JSField. If the value string is Nothing, the JSField
230 -- will be Nothing as well.
231 optionalJSField :: (J.JSON a) => String -> Maybe a -> Maybe JSField
232 optionalJSField name (Just value) = Just (name, J.showJSON value)
233 optionalJSField _ Nothing = Nothing
235 -- | Creates an object with all the non-Nothing fields of the given list.
236 optFieldsToObj :: [Maybe JSField] -> J.JSValue
237 optFieldsToObj = J.makeObj . catMaybes
239 -- * Container type (special type for JSON serialisation)
241 -- | Class of types that can be converted from Strings. This is
242 -- similar to the 'Read' class, but it's using a different
243 -- serialisation format, so we have to define a separate class. Mostly
244 -- useful for custom key types in JSON dictionaries, which have to be
245 -- backed by strings.
246 class HasStringRepr a where
247 fromStringRepr :: (Monad m) => String -> m a
248 toStringRepr :: a -> String
250 -- | Trivial instance 'HasStringRepr' for 'String'.
251 instance HasStringRepr String where
252 fromStringRepr = return
255 -- | The container type, a wrapper over Data.Map
256 newtype GenericContainer a b =
257 GenericContainer { fromContainer :: Map.Map a b }
260 instance (NFData a, NFData b) => NFData (GenericContainer a b) where
261 rnf = rnf . Map.toList . fromContainer
263 -- | Type alias for string keys.
264 type Container = GenericContainer String
266 -- | Container loader.
267 readContainer :: (Monad m, HasStringRepr a, Ord a, J.JSON b) =>
268 J.JSObject J.JSValue -> m (GenericContainer a b)
269 readContainer obj = do
270 let kjvlist = J.fromJSObject obj
271 kalist <- mapM (\(k, v) -> do
272 k' <- fromStringRepr k
273 v' <- fromKeyValue k v
274 return (k', v')) kjvlist
275 return $ GenericContainer (Map.fromList kalist)
277 {-# ANN showContainer "HLint: ignore Use ***" #-}
278 -- | Container dumper.
279 showContainer :: (HasStringRepr a, J.JSON b) =>
280 GenericContainer a b -> J.JSValue
282 J.makeObj . map (\(k, v) -> (toStringRepr k, J.showJSON v)) .
283 Map.toList . fromContainer
285 instance (HasStringRepr a, Ord a, J.JSON b) =>
286 J.JSON (GenericContainer a b) where
287 showJSON = showContainer
288 readJSON (J.JSObject o) = readContainer o
289 readJSON v = fail $ "Failed to load container, expected object but got "