1 {-| JSON utility functions. -}
5 Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2 of the License, or
10 (at your option) any later version.
12 This program is distributed in the hope that it will be useful, but
13 WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program; if not, write to the Free Software
19 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
42 import Control.Arrow (second)
43 import Control.Monad (liftM)
44 import Data.Maybe (fromMaybe)
45 import qualified Data.Map as Map
46 import Text.Printf (printf)
48 import qualified Text.JSON as J
49 import Text.JSON.Pretty (pp_value)
51 import Ganeti.BasicTypes
53 -- * JSON-related functions
55 -- | A type alias for the list-based representation of J.JSObject.
56 type JSRecord = [(String, J.JSValue)]
58 -- | Converts a JSON Result into a monadic value.
59 fromJResult :: Monad m => String -> J.Result a -> m a
60 fromJResult s (J.Error x) = fail (s ++ ": " ++ x)
61 fromJResult _ (J.Ok x) = return x
63 -- | Tries to read a string from a JSON value.
65 -- In case the value was not a string, we fail the read (in the
66 -- context of the current monad.
67 readEitherString :: (Monad m) => J.JSValue -> m String
70 J.JSString s -> return $ J.fromJSString s
71 _ -> fail "Wrong JSON type"
73 -- | Converts a JSON message into an array of JSON objects.
74 loadJSArray :: (Monad m)
75 => String -- ^ Operation description (for error reporting)
76 -> String -- ^ Input message
77 -> m [J.JSObject J.JSValue]
78 loadJSArray s = fromJResult s . J.decodeStrict
80 -- | Reads the value of a key in a JSON object.
81 fromObj :: (J.JSON a, Monad m) => JSRecord -> String -> m a
84 Nothing -> fail $ printf "key '%s' not found, object contains only %s"
86 Just val -> fromKeyValue k val
88 -- | Reads the value of an optional key in a JSON object. Missing
89 -- keys, or keys that have a \'null\' value, will be returned as
90 -- 'Nothing', otherwise we attempt deserialisation and return a 'Just'
92 maybeFromObj :: (J.JSON a, Monad m) =>
93 JSRecord -> String -> m (Maybe a)
96 Nothing -> return Nothing
97 -- a optional key with value JSNull is the same as missing, since
98 -- we can't convert it meaningfully anyway to a Haskell type, and
99 -- the Python code can emit 'null' for optional values (depending
100 -- on usage), and finally our encoding rules treat 'null' values
102 Just J.JSNull -> return Nothing
103 Just val -> liftM Just (fromKeyValue k val)
105 -- | Reads the value of a key in a JSON object with a default if
106 -- missing. Note that both missing keys and keys with value \'null\'
107 -- will case the default value to be returned.
108 fromObjWithDefault :: (J.JSON a, Monad m) =>
109 JSRecord -> String -> a -> m a
110 fromObjWithDefault o k d = liftM (fromMaybe d) $ maybeFromObj o k
112 -- | Reads a JValue, that originated from an object key.
113 fromKeyValue :: (J.JSON a, Monad m)
114 => String -- ^ The key name
115 -> J.JSValue -- ^ The value to read
118 fromJResult (printf "key '%s'" k) (J.readJSON val)
120 -- | Small wrapper over readJSON.
121 fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a
124 J.Error s -> fail ("Cannot convert value '" ++ show (pp_value v) ++
128 -- | Converts a JSON value into a JSON object.
129 asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue)
130 asJSObject (J.JSObject a) = return a
131 asJSObject _ = fail "not an object"
133 -- | Coneverts a list of JSON values into a list of JSON objects.
134 asObjectList :: (Monad m) => [J.JSValue] -> m [J.JSObject J.JSValue]
135 asObjectList = mapM asJSObject
137 -- | Try to extract a key from a object with better error reporting
139 tryFromObj :: (J.JSON a) =>
140 String -- ^ Textual "owner" in error messages
141 -> JSRecord -- ^ The object array
142 -> String -- ^ The desired key from the object
144 tryFromObj t o = annotateResult t . fromObj o
146 -- | Ensure a given JSValue is actually a JSArray.
147 toArray :: (Monad m) => J.JSValue -> m [J.JSValue]
148 toArray (J.JSArray arr) = return arr
150 fail $ "Invalid input, expected array but got " ++ show (pp_value o)
152 -- * Container type (special type for JSON serialisation)
154 -- | The container type, a wrapper over Data.Map
155 newtype Container a = Container { fromContainer :: Map.Map String a }
156 deriving (Show, Read, Eq)
158 -- | Container loader.
159 readContainer :: (Monad m, J.JSON a) =>
160 J.JSObject J.JSValue -> m (Container a)
161 readContainer obj = do
162 let kjvlist = J.fromJSObject obj
163 kalist <- mapM (\(k, v) -> fromKeyValue k v >>= \a -> return (k, a)) kjvlist
164 return $ Container (Map.fromList kalist)
166 -- | Container dumper.
167 showContainer :: (J.JSON a) => Container a -> J.JSValue
169 J.makeObj . map (second J.showJSON) . Map.toList . fromContainer
171 instance (J.JSON a) => J.JSON (Container a) where
172 showJSON = showContainer
173 readJSON (J.JSObject o) = readContainer o
174 readJSON v = fail $ "Failed to load container, expected object but got "