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 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 a 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)