Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / JSON.hs @ 11e90588

History | View | Annotate | Download (8.4 kB)

1
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
2
{-# OPTIONS_GHC -fno-warn-orphans #-}
3

    
4
{-| JSON utility functions. -}
5

    
6
{-
7

    
8
Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
9

    
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.
14

    
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.
19

    
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
23
02110-1301, USA.
24

    
25
-}
26

    
27
module Ganeti.JSON
28
  ( fromJResult
29
  , readEitherString
30
  , JSRecord
31
  , loadJSArray
32
  , fromObj
33
  , maybeFromObj
34
  , fromObjWithDefault
35
  , fromKeyValue
36
  , fromJVal
37
  , jsonHead
38
  , getMaybeJsonHead
39
  , asJSObject
40
  , asObjectList
41
  , tryFromObj
42
  , toArray
43
  , optionalJSField
44
  , optFieldsToObj
45
  , HasStringRepr(..)
46
  , GenericContainer(..)
47
  , Container
48
  )
49
  where
50

    
51
import Control.DeepSeq
52
import Control.Monad (liftM)
53
import Data.Maybe (fromMaybe, catMaybes)
54
import qualified Data.Map as Map
55
import Text.Printf (printf)
56

    
57
import qualified Text.JSON as J
58
import Text.JSON.Pretty (pp_value)
59

    
60
-- Note: this module should not import any Ganeti-specific modules
61
-- beside BasicTypes, since it's used in THH which is used itself to
62
-- build many other modules.
63

    
64
import Ganeti.BasicTypes
65

    
66
-- * JSON-related functions
67

    
68
instance NFData J.JSValue where
69
  rnf J.JSNull           = ()
70
  rnf (J.JSBool b)       = rnf b
71
  rnf (J.JSRational b r) = rnf b `seq` rnf r
72
  rnf (J.JSString s)     = rnf $ J.fromJSString s
73
  rnf (J.JSArray a)      = rnf a
74
  rnf (J.JSObject o)     = rnf o
75

    
76
instance (NFData a) => NFData (J.JSObject a) where
77
  rnf = rnf . J.fromJSObject
78

    
79
-- | A type alias for a field of a JSRecord.
80
type JSField = (String, J.JSValue)
81

    
82
-- | A type alias for the list-based representation of J.JSObject.
83
type JSRecord = [JSField]
84

    
85
-- | Converts a JSON Result into a monadic value.
86
fromJResult :: Monad m => String -> J.Result a -> m a
87
fromJResult s (J.Error x) = fail (s ++ ": " ++ x)
88
fromJResult _ (J.Ok x) = return x
89

    
90
-- | Tries to read a string from a JSON value.
91
--
92
-- In case the value was not a string, we fail the read (in the
93
-- context of the current monad.
94
readEitherString :: (Monad m) => J.JSValue -> m String
95
readEitherString v =
96
  case v of
97
    J.JSString s -> return $ J.fromJSString s
98
    _ -> fail "Wrong JSON type"
99

    
100
-- | Converts a JSON message into an array of JSON objects.
101
loadJSArray :: (Monad m)
102
               => String -- ^ Operation description (for error reporting)
103
               -> String -- ^ Input message
104
               -> m [J.JSObject J.JSValue]
105
loadJSArray s = fromJResult s . J.decodeStrict
106

    
107
-- | Reads the value of a key in a JSON object.
108
fromObj :: (J.JSON a, Monad m) => JSRecord -> String -> m a
109
fromObj o k =
110
  case lookup k o of
111
    Nothing -> fail $ printf "key '%s' not found, object contains only %s"
112
               k (show (map fst o))
113
    Just val -> fromKeyValue k val
114

    
115
-- | Reads the value of an optional key in a JSON object. Missing
116
-- keys, or keys that have a \'null\' value, will be returned as
117
-- 'Nothing', otherwise we attempt deserialisation and return a 'Just'
118
-- value.
119
maybeFromObj :: (J.JSON a, Monad m) =>
120
                JSRecord -> String -> m (Maybe a)
121
maybeFromObj o k =
122
  case lookup k o of
123
    Nothing -> return Nothing
124
    -- a optional key with value JSNull is the same as missing, since
125
    -- we can't convert it meaningfully anyway to a Haskell type, and
126
    -- the Python code can emit 'null' for optional values (depending
127
    -- on usage), and finally our encoding rules treat 'null' values
128
    -- as 'missing'
129
    Just J.JSNull -> return Nothing
130
    Just val -> liftM Just (fromKeyValue k val)
131

    
132
-- | Reads the value of a key in a JSON object with a default if
133
-- missing. Note that both missing keys and keys with value \'null\'
134
-- will case the default value to be returned.
135
fromObjWithDefault :: (J.JSON a, Monad m) =>
136
                      JSRecord -> String -> a -> m a
137
fromObjWithDefault o k d = liftM (fromMaybe d) $ maybeFromObj o k
138

    
139
-- | Reads a JValue, that originated from an object key.
140
fromKeyValue :: (J.JSON a, Monad m)
141
              => String     -- ^ The key name
142
              -> J.JSValue  -- ^ The value to read
143
              -> m a
144
fromKeyValue k val =
145
  fromJResult (printf "key '%s'" k) (J.readJSON val)
146

    
147
-- | Small wrapper over readJSON.
148
fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a
149
fromJVal v =
150
  case J.readJSON v of
151
    J.Error s -> fail ("Cannot convert value '" ++ show (pp_value v) ++
152
                       "', error: " ++ s)
153
    J.Ok x -> return x
154

    
155
-- | Helper function that returns Null or first element of the list.
156
jsonHead :: (J.JSON b) => [a] -> (a -> b) -> J.JSValue
157
jsonHead [] _ = J.JSNull
158
jsonHead (x:_) f = J.showJSON $ f x
159

    
160
-- | Helper for extracting Maybe values from a possibly empty list.
161
getMaybeJsonHead :: (J.JSON b) => [a] -> (a -> Maybe b) -> J.JSValue
162
getMaybeJsonHead [] _ = J.JSNull
163
getMaybeJsonHead (x:_) f = maybe J.JSNull J.showJSON (f x)
164

    
165
-- | Converts a JSON value into a JSON object.
166
asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue)
167
asJSObject (J.JSObject a) = return a
168
asJSObject _ = fail "not an object"
169

    
170
-- | Coneverts a list of JSON values into a list of JSON objects.
171
asObjectList :: (Monad m) => [J.JSValue] -> m [J.JSObject J.JSValue]
172
asObjectList = mapM asJSObject
173

    
174
-- | Try to extract a key from an object with better error reporting
175
-- than fromObj.
176
tryFromObj :: (J.JSON a) =>
177
              String     -- ^ Textual "owner" in error messages
178
           -> JSRecord   -- ^ The object array
179
           -> String     -- ^ The desired key from the object
180
           -> Result a
181
tryFromObj t o = annotateResult t . fromObj o
182

    
183
-- | Ensure a given JSValue is actually a JSArray.
184
toArray :: (Monad m) => J.JSValue -> m [J.JSValue]
185
toArray (J.JSArray arr) = return arr
186
toArray o =
187
  fail $ "Invalid input, expected array but got " ++ show (pp_value o)
188

    
189
-- | Creates a Maybe JSField. If the value string is Nothing, the JSField
190
-- will be Nothing as well.
191
optionalJSField :: (J.JSON a) => String -> Maybe a -> Maybe JSField
192
optionalJSField name (Just value) = Just (name, J.showJSON value)
193
optionalJSField _ Nothing = Nothing
194

    
195
-- | Creates an object with all the non-Nothing fields of the given list.
196
optFieldsToObj :: [Maybe JSField] -> J.JSValue
197
optFieldsToObj = J.makeObj . catMaybes
198

    
199
-- * Container type (special type for JSON serialisation)
200

    
201
-- | Class of types that can be converted from Strings. This is
202
-- similar to the 'Read' class, but it's using a different
203
-- serialisation format, so we have to define a separate class. Mostly
204
-- useful for custom key types in JSON dictionaries, which have to be
205
-- backed by strings.
206
class HasStringRepr a where
207
  fromStringRepr :: (Monad m) => String -> m a
208
  toStringRepr :: a -> String
209

    
210
-- | Trivial instance 'HasStringRepr' for 'String'.
211
instance HasStringRepr String where
212
  fromStringRepr = return
213
  toStringRepr = id
214

    
215
-- | The container type, a wrapper over Data.Map
216
newtype GenericContainer a b =
217
  GenericContainer { fromContainer :: Map.Map a b }
218
  deriving (Show, Eq)
219

    
220
instance (NFData a, NFData b) => NFData (GenericContainer a b) where
221
  rnf = rnf . Map.toList . fromContainer
222

    
223
-- | Type alias for string keys.
224
type Container = GenericContainer String
225

    
226
-- | Container loader.
227
readContainer :: (Monad m, HasStringRepr a, Ord a, J.JSON b) =>
228
                 J.JSObject J.JSValue -> m (GenericContainer a b)
229
readContainer obj = do
230
  let kjvlist = J.fromJSObject obj
231
  kalist <- mapM (\(k, v) -> do
232
                    k' <- fromStringRepr k
233
                    v' <- fromKeyValue k v
234
                    return (k', v')) kjvlist
235
  return $ GenericContainer (Map.fromList kalist)
236

    
237
{-# ANN showContainer "HLint: ignore Use ***" #-}
238
-- | Container dumper.
239
showContainer :: (HasStringRepr a, J.JSON b) =>
240
                 GenericContainer a b -> J.JSValue
241
showContainer =
242
  J.makeObj . map (\(k, v) -> (toStringRepr k, J.showJSON v)) .
243
  Map.toList . fromContainer
244

    
245
instance (HasStringRepr a, Ord a, J.JSON b) =>
246
         J.JSON (GenericContainer a b) where
247
  showJSON = showContainer
248
  readJSON (J.JSObject o) = readContainer o
249
  readJSON v = fail $ "Failed to load container, expected object but got "
250
               ++ show (pp_value v)