1 {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
2 {-| JSON utility functions. -}
6 Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
8 This program is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2 of the License, or
11 (at your option) any later version.
13 This program is distributed in the hope that it will be useful, but
14 WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with this program; if not, write to the Free Software
20 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
44 , GenericContainer(..)
49 import Control.Monad (liftM)
50 import Data.Maybe (fromMaybe, catMaybes)
51 import qualified Data.Map as Map
52 import Text.Printf (printf)
54 import qualified Text.JSON as J
55 import Text.JSON.Pretty (pp_value)
57 -- Note: this module should not import any Ganeti-specific modules
58 -- beside BasicTypes, since it's used in THH which is used itself to
59 -- build many other modules.
61 import Ganeti.BasicTypes
63 -- * JSON-related functions
65 -- | A type alias for a field of a JSRecord.
66 type JSField = (String, J.JSValue)
68 -- | A type alias for the list-based representation of J.JSObject.
69 type JSRecord = [JSField]
71 -- | Converts a JSON Result into a monadic value.
72 fromJResult :: Monad m => String -> J.Result a -> m a
73 fromJResult s (J.Error x) = fail (s ++ ": " ++ x)
74 fromJResult _ (J.Ok x) = return x
76 -- | Tries to read a string from a JSON value.
78 -- In case the value was not a string, we fail the read (in the
79 -- context of the current monad.
80 readEitherString :: (Monad m) => J.JSValue -> m String
83 J.JSString s -> return $ J.fromJSString s
84 _ -> fail "Wrong JSON type"
86 -- | Converts a JSON message into an array of JSON objects.
87 loadJSArray :: (Monad m)
88 => String -- ^ Operation description (for error reporting)
89 -> String -- ^ Input message
90 -> m [J.JSObject J.JSValue]
91 loadJSArray s = fromJResult s . J.decodeStrict
93 -- | Reads the value of a key in a JSON object.
94 fromObj :: (J.JSON a, Monad m) => JSRecord -> String -> m a
97 Nothing -> fail $ printf "key '%s' not found, object contains only %s"
99 Just val -> fromKeyValue k val
101 -- | Reads the value of an optional key in a JSON object. Missing
102 -- keys, or keys that have a \'null\' value, will be returned as
103 -- 'Nothing', otherwise we attempt deserialisation and return a 'Just'
105 maybeFromObj :: (J.JSON a, Monad m) =>
106 JSRecord -> String -> m (Maybe a)
109 Nothing -> return Nothing
110 -- a optional key with value JSNull is the same as missing, since
111 -- we can't convert it meaningfully anyway to a Haskell type, and
112 -- the Python code can emit 'null' for optional values (depending
113 -- on usage), and finally our encoding rules treat 'null' values
115 Just J.JSNull -> return Nothing
116 Just val -> liftM Just (fromKeyValue k val)
118 -- | Reads the value of a key in a JSON object with a default if
119 -- missing. Note that both missing keys and keys with value \'null\'
120 -- will case the default value to be returned.
121 fromObjWithDefault :: (J.JSON a, Monad m) =>
122 JSRecord -> String -> a -> m a
123 fromObjWithDefault o k d = liftM (fromMaybe d) $ maybeFromObj o k
125 -- | Reads a JValue, that originated from an object key.
126 fromKeyValue :: (J.JSON a, Monad m)
127 => String -- ^ The key name
128 -> J.JSValue -- ^ The value to read
131 fromJResult (printf "key '%s'" k) (J.readJSON val)
133 -- | Small wrapper over readJSON.
134 fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a
137 J.Error s -> fail ("Cannot convert value '" ++ show (pp_value v) ++
141 -- | Helper function that returns Null or first element of the list.
142 jsonHead :: (J.JSON b) => [a] -> (a -> b) -> J.JSValue
143 jsonHead [] _ = J.JSNull
144 jsonHead (x:_) f = J.showJSON $ f x
146 -- | Helper for extracting Maybe values from a possibly empty list.
147 getMaybeJsonHead :: (J.JSON b) => [a] -> (a -> Maybe b) -> J.JSValue
148 getMaybeJsonHead [] _ = J.JSNull
149 getMaybeJsonHead (x:_) f = maybe J.JSNull J.showJSON (f x)
151 -- | Converts a JSON value into a JSON object.
152 asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue)
153 asJSObject (J.JSObject a) = return a
154 asJSObject _ = fail "not an object"
156 -- | Coneverts a list of JSON values into a list of JSON objects.
157 asObjectList :: (Monad m) => [J.JSValue] -> m [J.JSObject J.JSValue]
158 asObjectList = mapM asJSObject
160 -- | Try to extract a key from a object with better error reporting
162 tryFromObj :: (J.JSON a) =>
163 String -- ^ Textual "owner" in error messages
164 -> JSRecord -- ^ The object array
165 -> String -- ^ The desired key from the object
167 tryFromObj t o = annotateResult t . fromObj o
169 -- | Ensure a given JSValue is actually a JSArray.
170 toArray :: (Monad m) => J.JSValue -> m [J.JSValue]
171 toArray (J.JSArray arr) = return arr
173 fail $ "Invalid input, expected array but got " ++ show (pp_value o)
175 -- | Creates a Maybe JSField. If the value string is Nothing, the JSField
176 -- will be Nothing as well.
177 optionalJSField :: (J.JSON a) => String -> Maybe a -> Maybe JSField
178 optionalJSField name (Just value) = Just (name, J.showJSON value)
179 optionalJSField _ Nothing = Nothing
181 -- | Creates an object with all the non-Nothing fields of the given list.
182 optFieldsToObj :: [Maybe JSField] -> J.JSValue
183 optFieldsToObj = J.makeObj . catMaybes
185 -- * Container type (special type for JSON serialisation)
187 -- | Class of types that can be converted from Strings. This is
188 -- similar to the 'Read' class, but it's using a different
189 -- serialisation format, so we have to define a separate class. Mostly
190 -- useful for custom key types in JSON dictionaries, which have to be
191 -- backed by strings.
192 class HasStringRepr a where
193 fromStringRepr :: (Monad m) => String -> m a
194 toStringRepr :: a -> String
196 -- | Trivial instance 'HasStringRepr' for 'String'.
197 instance HasStringRepr String where
198 fromStringRepr = return
201 -- | The container type, a wrapper over Data.Map
202 newtype GenericContainer a b =
203 GenericContainer { fromContainer :: Map.Map a b }
206 -- | Type alias for string keys.
207 type Container = GenericContainer String
209 -- | Container loader.
210 readContainer :: (Monad m, HasStringRepr a, Ord a, J.JSON b) =>
211 J.JSObject J.JSValue -> m (GenericContainer a b)
212 readContainer obj = do
213 let kjvlist = J.fromJSObject obj
214 kalist <- mapM (\(k, v) -> do
215 k' <- fromStringRepr k
216 v' <- fromKeyValue k v
217 return (k', v')) kjvlist
218 return $ GenericContainer (Map.fromList kalist)
220 {-# ANN showContainer "HLint: ignore Use ***" #-}
221 -- | Container dumper.
222 showContainer :: (HasStringRepr a, J.JSON b) =>
223 GenericContainer a b -> J.JSValue
225 J.makeObj . map (\(k, v) -> (toStringRepr k, J.showJSON v)) .
226 Map.toList . fromContainer
228 instance (HasStringRepr a, Ord a, J.JSON b) =>
229 J.JSON (GenericContainer a b) where
230 showJSON = showContainer
231 readJSON (J.JSObject o) = readContainer o
232 readJSON v = fail $ "Failed to load container, expected object but got "