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
43 import Control.Arrow (second)
44 import Control.Monad (liftM)
45 import Data.Maybe (fromMaybe)
46 import qualified Data.Map as Map
47 import Text.Printf (printf)
49 import qualified Text.JSON as J
50 import Text.JSON.Pretty (pp_value)
52 import Ganeti.BasicTypes
54 -- * JSON-related functions
56 -- | A type alias for the list-based representation of J.JSObject.
57 type JSRecord = [(String, J.JSValue)]
59 -- | Converts a JSON Result into a monadic value.
60 fromJResult :: Monad m => String -> J.Result a -> m a
61 fromJResult s (J.Error x) = fail (s ++ ": " ++ x)
62 fromJResult _ (J.Ok x) = return x
64 -- | Tries to read a string from a JSON value.
66 -- In case the value was not a string, we fail the read (in the
67 -- context of the current monad.
68 readEitherString :: (Monad m) => J.JSValue -> m String
71 J.JSString s -> return $ J.fromJSString s
72 _ -> fail "Wrong JSON type"
74 -- | Converts a JSON message into an array of JSON objects.
75 loadJSArray :: (Monad m)
76 => String -- ^ Operation description (for error reporting)
77 -> String -- ^ Input message
78 -> m [J.JSObject J.JSValue]
79 loadJSArray s = fromJResult s . J.decodeStrict
81 -- | Reads the value of a key in a JSON object.
82 fromObj :: (J.JSON a, Monad m) => JSRecord -> String -> m a
85 Nothing -> fail $ printf "key '%s' not found, object contains only %s"
87 Just val -> fromKeyValue k val
89 -- | Reads the value of an optional key in a JSON object. Missing
90 -- keys, or keys that have a \'null\' value, will be returned as
91 -- 'Nothing', otherwise we attempt deserialisation and return a 'Just'
93 maybeFromObj :: (J.JSON a, Monad m) =>
94 JSRecord -> String -> m (Maybe a)
97 Nothing -> return Nothing
98 -- a optional key with value JSNull is the same as missing, since
99 -- we can't convert it meaningfully anyway to a Haskell type, and
100 -- the Python code can emit 'null' for optional values (depending
101 -- on usage), and finally our encoding rules treat 'null' values
103 Just J.JSNull -> return Nothing
104 Just val -> liftM Just (fromKeyValue k val)
106 -- | Reads the value of a key in a JSON object with a default if
107 -- missing. Note that both missing keys and keys with value \'null\'
108 -- will case the default value to be returned.
109 fromObjWithDefault :: (J.JSON a, Monad m) =>
110 JSRecord -> String -> a -> m a
111 fromObjWithDefault o k d = liftM (fromMaybe d) $ maybeFromObj o k
113 -- | Reads a JValue, that originated from an object key.
114 fromKeyValue :: (J.JSON a, Monad m)
115 => String -- ^ The key name
116 -> J.JSValue -- ^ The value to read
119 fromJResult (printf "key '%s'" k) (J.readJSON val)
121 -- | Small wrapper over readJSON.
122 fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a
125 J.Error s -> fail ("Cannot convert value '" ++ show (pp_value v) ++
129 -- | Helper function that returns Null or first element of the list.
130 jsonHead :: (J.JSON b) => [a] -> (a -> b) -> J.JSValue
131 jsonHead [] _ = J.JSNull
132 jsonHead (x:_) f = J.showJSON $ f x
134 -- | Converts a JSON value into a JSON object.
135 asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue)
136 asJSObject (J.JSObject a) = return a
137 asJSObject _ = fail "not an object"
139 -- | Coneverts a list of JSON values into a list of JSON objects.
140 asObjectList :: (Monad m) => [J.JSValue] -> m [J.JSObject J.JSValue]
141 asObjectList = mapM asJSObject
143 -- | Try to extract a key from a object with better error reporting
145 tryFromObj :: (J.JSON a) =>
146 String -- ^ Textual "owner" in error messages
147 -> JSRecord -- ^ The object array
148 -> String -- ^ The desired key from the object
150 tryFromObj t o = annotateResult t . fromObj o
152 -- | Ensure a given JSValue is actually a JSArray.
153 toArray :: (Monad m) => J.JSValue -> m [J.JSValue]
154 toArray (J.JSArray arr) = return arr
156 fail $ "Invalid input, expected array but got " ++ show (pp_value o)
158 -- * Container type (special type for JSON serialisation)
160 -- | The container type, a wrapper over Data.Map
161 newtype Container a = Container { fromContainer :: Map.Map String a }
162 deriving (Show, Read, Eq)
164 -- | Container loader.
165 readContainer :: (Monad m, J.JSON a) =>
166 J.JSObject J.JSValue -> m (Container a)
167 readContainer obj = do
168 let kjvlist = J.fromJSObject obj
169 kalist <- mapM (\(k, v) -> fromKeyValue k v >>= \a -> return (k, a)) kjvlist
170 return $ Container (Map.fromList kalist)
172 -- | Container dumper.
173 showContainer :: (J.JSON a) => Container a -> J.JSValue
175 J.makeObj . map (second J.showJSON) . Map.toList . fromContainer
177 instance (J.JSON a) => J.JSON (Container a) where
178 showJSON = showContainer
179 readJSON (J.JSObject o) = readContainer o
180 readJSON v = fail $ "Failed to load container, expected object but got "