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

   1 {-| JSON utility functions. -}
   2
   3 {-
   4
   5 Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
   6
   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.
  11
  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.
  16
  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
  20 02110-1301, USA.
  21
  22 -}
  23
  24 module Ganeti.JSON
  25   ( fromJResult
  26   , readEitherString
  27   , JSRecord
  28   , loadJSArray
  29   , fromObj
  30   , maybeFromObj
  31   , fromObjWithDefault
  32   , fromKeyValue
  33   , fromJVal
  34   , jsonHead
  35   , getMaybeJsonHead
  36   , asJSObject
  37   , asObjectList
  38   , tryFromObj
  39   , toArray
  40   , Container(..)
  41   )
  42   where
  43
  44 import Control.Arrow (second)
  45 import Control.Monad (liftM)
  46 import Data.Maybe (fromMaybe)
  47 import qualified Data.Map as Map
  48 import Text.Printf (printf)
  49
  50 import qualified Text.JSON as J
  51 import Text.JSON.Pretty (pp_value)
  52
  53 import Ganeti.BasicTypes
  54
  55 -- * JSON-related functions
  56
  57 -- | A type alias for the list-based representation of J.JSObject.
  58 type JSRecord = [(String, J.JSValue)]
  59
  60 -- | Converts a JSON Result into a monadic value.
  61 fromJResult :: Monad m => String -> J.Result a -> m a
  62 fromJResult s (J.Error x) = fail (s ++ ": " ++ x)
  63 fromJResult _ (J.Ok x) = return x
  64
  65 -- | Tries to read a string from a JSON value.
  66 --
  67 -- In case the value was not a string, we fail the read (in the
  68 -- context of the current monad.
  69 readEitherString :: (Monad m) => J.JSValue -> m String
  70 readEitherString v =
  71   case v of
  72     J.JSString s -> return $ J.fromJSString s
  73     _ -> fail "Wrong JSON type"
  74
  75 -- | Converts a JSON message into an array of JSON objects.
  76 loadJSArray :: (Monad m)
  77                => String -- ^ Operation description (for error reporting)
  78                -> String -- ^ Input message
  79                -> m [J.JSObject J.JSValue]
  80 loadJSArray s = fromJResult s . J.decodeStrict
  81
  82 -- | Reads the value of a key in a JSON object.
  83 fromObj :: (J.JSON a, Monad m) => JSRecord -> String -> m a
  84 fromObj o k =
  85   case lookup k o of
  86     Nothing -> fail $ printf "key '%s' not found, object contains only %s"
  87                k (show (map fst o))
  88     Just val -> fromKeyValue k val
  89
  90 -- | Reads the value of an optional key in a JSON object. Missing
  91 -- keys, or keys that have a \'null\' value, will be returned as
  92 -- 'Nothing', otherwise we attempt deserialisation and return a 'Just'
  93 -- value.
  94 maybeFromObj :: (J.JSON a, Monad m) =>
  95                 JSRecord -> String -> m (Maybe a)
  96 maybeFromObj o k =
  97   case lookup k o of
  98     Nothing -> return Nothing
  99     -- a optional key with value JSNull is the same as missing, since
 100     -- we can't convert it meaningfully anyway to a Haskell type, and
 101     -- the Python code can emit 'null' for optional values (depending
 102     -- on usage), and finally our encoding rules treat 'null' values
 103     -- as 'missing'
 104     Just J.JSNull -> return Nothing
 105     Just val -> liftM Just (fromKeyValue k val)
 106
 107 -- | Reads the value of a key in a JSON object with a default if
 108 -- missing. Note that both missing keys and keys with value \'null\'
 109 -- will case the default value to be returned.
 110 fromObjWithDefault :: (J.JSON a, Monad m) =>
 111                       JSRecord -> String -> a -> m a
 112 fromObjWithDefault o k d = liftM (fromMaybe d) $ maybeFromObj o k
 113
 114 -- | Reads a JValue, that originated from an object key.
 115 fromKeyValue :: (J.JSON a, Monad m)
 116               => String     -- ^ The key name
 117               -> J.JSValue  -- ^ The value to read
 118               -> m a
 119 fromKeyValue k val =
 120   fromJResult (printf "key '%s'" k) (J.readJSON val)
 121
 122 -- | Small wrapper over readJSON.
 123 fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a
 124 fromJVal v =
 125   case J.readJSON v of
 126     J.Error s -> fail ("Cannot convert value '" ++ show (pp_value v) ++
 127                        "', error: " ++ s)
 128     J.Ok x -> return x
 129
 130 -- | Helper function that returns Null or first element of the list.
 131 jsonHead :: (J.JSON b) => [a] -> (a -> b) -> J.JSValue
 132 jsonHead [] _ = J.JSNull
 133 jsonHead (x:_) f = J.showJSON $ f x
 134
 135 -- | Helper for extracting Maybe values from a possibly empty list.
 136 getMaybeJsonHead :: (J.JSON b) => [a] -> (a -> Maybe b) -> J.JSValue
 137 getMaybeJsonHead [] _ = J.JSNull
 138 getMaybeJsonHead (x:_) f = maybe J.JSNull J.showJSON (f x)
 139
 140 -- | Converts a JSON value into a JSON object.
 141 asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue)
 142 asJSObject (J.JSObject a) = return a
 143 asJSObject _ = fail "not an object"
 144
 145 -- | Coneverts a list of JSON values into a list of JSON objects.
 146 asObjectList :: (Monad m) => [J.JSValue] -> m [J.JSObject J.JSValue]
 147 asObjectList = mapM asJSObject
 148
 149 -- | Try to extract a key from a object with better error reporting
 150 -- than fromObj.
 151 tryFromObj :: (J.JSON a) =>
 152               String     -- ^ Textual "owner" in error messages
 153            -> JSRecord   -- ^ The object array
 154            -> String     -- ^ The desired key from the object
 155            -> Result a
 156 tryFromObj t o = annotateResult t . fromObj o
 157
 158 -- | Ensure a given JSValue is actually a JSArray.
 159 toArray :: (Monad m) => J.JSValue -> m [J.JSValue]
 160 toArray (J.JSArray arr) = return arr
 161 toArray o =
 162   fail $ "Invalid input, expected array but got " ++ show (pp_value o)
 163
 164 -- * Container type (special type for JSON serialisation)
 165
 166 -- | The container type, a wrapper over Data.Map
 167 newtype Container a = Container { fromContainer :: Map.Map String a }
 168   deriving (Show, Read, Eq)
 169
 170 -- | Container loader.
 171 readContainer :: (Monad m, J.JSON a) =>
 172                  J.JSObject J.JSValue -> m (Container a)
 173 readContainer obj = do
 174   let kjvlist = J.fromJSObject obj
 175   kalist <- mapM (\(k, v) -> fromKeyValue k v >>= \a -> return (k, a)) kjvlist
 176   return $ Container (Map.fromList kalist)
 177
 178 -- | Container dumper.
 179 showContainer :: (J.JSON a) => Container a -> J.JSValue
 180 showContainer =
 181   J.makeObj . map (second J.showJSON) . Map.toList . fromContainer
 182
 183 instance (J.JSON a) => J.JSON (Container a) where
 184   showJSON = showContainer
 185   readJSON (J.JSObject o) = readContainer o
 186   readJSON v = fail $ "Failed to load container, expected object but got "
 187                ++ show (pp_value v)