code.grnet.gr Git - ganeti-local/blob - src/Ganeti/JSON.hs

   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, 2013 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   , getMaybeJsonElem
  40   , asJSObject
  41   , asObjectList
  42   , tryFromObj
  43   , arrayMaybeFromJVal
  44   , tryArrayMaybeFromObj
  45   , toArray
  46   , optionalJSField
  47   , optFieldsToObj
  48   , HasStringRepr(..)
  49   , GenericContainer(..)
  50   , Container
  51   )
  52   where
  53
  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)
  59
  60 import qualified Text.JSON as J
  61 import Text.JSON.Pretty (pp_value)
  62
  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.
  66
  67 import Ganeti.BasicTypes
  68
  69 -- * JSON-related functions
  70
  71 instance NFData J.JSValue where
  72   rnf J.JSNull           = ()
  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
  78
  79 instance (NFData a) => NFData (J.JSObject a) where
  80   rnf = rnf . J.fromJSObject
  81
  82 -- | A type alias for a field of a JSRecord.
  83 type JSField = (String, J.JSValue)
  84
  85 -- | A type alias for the list-based representation of J.JSObject.
  86 type JSRecord = [JSField]
  87
  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
  92
  93 -- | Tries to read a string from a JSON value.
  94 --
  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
  98 readEitherString v =
  99   case v of
 100     J.JSString s -> return $ J.fromJSString s
 101     _ -> fail "Wrong JSON type"
 102
 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
 109
 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))
 114
 115 -- | Reads the value of a key in a JSON object.
 116 fromObj :: (J.JSON a, Monad m) => JSRecord -> String -> m a
 117 fromObj o k =
 118   case lookup k o of
 119     Nothing -> fail $ buildNoKeyError o k
 120     Just val -> fromKeyValue k val
 121
 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'
 125 -- value.
 126 maybeFromObj :: (J.JSON a, Monad m) =>
 127                 JSRecord -> String -> m (Maybe a)
 128 maybeFromObj o k =
 129   case lookup k o of
 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
 135     -- as 'missing'
 136     Just J.JSNull -> return Nothing
 137     Just val -> liftM Just (fromKeyValue k val)
 138
 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
 145
 146 arrayMaybeFromJVal :: (J.JSON a, Monad m) => J.JSValue -> m [Maybe a]
 147 arrayMaybeFromJVal (J.JSArray xs) =
 148   mapM parse xs
 149     where
 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) ++ "'"
 154
 155 -- | Reads an array of optional items
 156 arrayMaybeFromObj :: (J.JSON a, Monad m) =>
 157                      JSRecord -> String -> m [Maybe a]
 158 arrayMaybeFromObj o k =
 159   case lookup k o of
 160     Just a -> arrayMaybeFromJVal a
 161     _ -> fail $ buildNoKeyError o k
 162
 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
 168                      -> Result [Maybe a]
 169 tryArrayMaybeFromObj t o = annotateResult t . arrayMaybeFromObj o
 170
 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
 175               -> m a
 176 fromKeyValue k val =
 177   fromJResult (printf "key '%s'" k) (J.readJSON val)
 178
 179 -- | Small wrapper over readJSON.
 180 fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a
 181 fromJVal v =
 182   case J.readJSON v of
 183     J.Error s -> fail ("Cannot convert value '" ++ show (pp_value v) ++
 184                        "', error: " ++ s)
 185     J.Ok x -> return x
 186
 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
 191
 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)
 196
 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
 202   | n < 0 = J.JSNull
 203   | otherwise = getMaybeJsonElem xs (n - 1) f
 204
 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"
 209
 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
 213
 214 -- | Try to extract a key from an object with better error reporting
 215 -- than fromObj.
 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
 220            -> Result a
 221 tryFromObj t o = annotateResult t . fromObj o
 222
 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
 226 toArray o =
 227   fail $ "Invalid input, expected array but got " ++ show (pp_value o)
 228
 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
 234
 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
 238
 239 -- * Container type (special type for JSON serialisation)
 240
 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
 249
 250 -- | Trivial instance 'HasStringRepr' for 'String'.
 251 instance HasStringRepr String where
 252   fromStringRepr = return
 253   toStringRepr = id
 254
 255 -- | The container type, a wrapper over Data.Map
 256 newtype GenericContainer a b =
 257   GenericContainer { fromContainer :: Map.Map a b }
 258   deriving (Show, Eq)
 259
 260 instance (NFData a, NFData b) => NFData (GenericContainer a b) where
 261   rnf = rnf . Map.toList . fromContainer
 262
 263 -- | Type alias for string keys.
 264 type Container = GenericContainer String
 265
 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)
 276
 277 {-# ANN showContainer "HLint: ignore Use ***" #-}
 278 -- | Container dumper.
 279 showContainer :: (HasStringRepr a, J.JSON b) =>
 280                  GenericContainer a b -> J.JSValue
 281 showContainer =
 282   J.makeObj . map (\(k, v) -> (toStringRepr k, J.showJSON v)) .
 283   Map.toList . fromContainer
 284
 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 "
 290                ++ show (pp_value v)