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

   1 {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
   2 {-| JSON utility functions. -}
   3
   4 {-
   5
   6 Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
   7
   8 This program is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2 of the License, or
  11 (at your option) any later version.
  12
  13 This program is distributed in the hope that it will be useful, but
  14 WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with this program; if not, write to the Free Software
  20 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  21 02110-1301, USA.
  22
  23 -}
  24
  25 module Ganeti.JSON
  26   ( fromJResult
  27   , readEitherString
  28   , JSRecord
  29   , loadJSArray
  30   , fromObj
  31   , maybeFromObj
  32   , fromObjWithDefault
  33   , fromKeyValue
  34   , fromJVal
  35   , jsonHead
  36   , getMaybeJsonHead
  37   , asJSObject
  38   , asObjectList
  39   , tryFromObj
  40   , toArray
  41   , HasStringRepr(..)
  42   , GenericContainer(..)
  43   , Container
  44   )
  45   where
  46
  47 import Control.Monad (liftM)
  48 import Data.Maybe (fromMaybe)
  49 import qualified Data.Map as Map
  50 import Text.Printf (printf)
  51
  52 import qualified Text.JSON as J
  53 import Text.JSON.Pretty (pp_value)
  54
  55 -- Note: this module should not import any Ganeti-specific modules
  56 -- beside BasicTypes, since it's used in THH which is used itself to
  57 -- build many other modules.
  58
  59 import Ganeti.BasicTypes
  60
  61 -- * JSON-related functions
  62
  63 -- | A type alias for the list-based representation of J.JSObject.
  64 type JSRecord = [(String, J.JSValue)]
  65
  66 -- | Converts a JSON Result into a monadic value.
  67 fromJResult :: Monad m => String -> J.Result a -> m a
  68 fromJResult s (J.Error x) = fail (s ++ ": " ++ x)
  69 fromJResult _ (J.Ok x) = return x
  70
  71 -- | Tries to read a string from a JSON value.
  72 --
  73 -- In case the value was not a string, we fail the read (in the
  74 -- context of the current monad.
  75 readEitherString :: (Monad m) => J.JSValue -> m String
  76 readEitherString v =
  77   case v of
  78     J.JSString s -> return $ J.fromJSString s
  79     _ -> fail "Wrong JSON type"
  80
  81 -- | Converts a JSON message into an array of JSON objects.
  82 loadJSArray :: (Monad m)
  83                => String -- ^ Operation description (for error reporting)
  84                -> String -- ^ Input message
  85                -> m [J.JSObject J.JSValue]
  86 loadJSArray s = fromJResult s . J.decodeStrict
  87
  88 -- | Reads the value of a key in a JSON object.
  89 fromObj :: (J.JSON a, Monad m) => JSRecord -> String -> m a
  90 fromObj o k =
  91   case lookup k o of
  92     Nothing -> fail $ printf "key '%s' not found, object contains only %s"
  93                k (show (map fst o))
  94     Just val -> fromKeyValue k val
  95
  96 -- | Reads the value of an optional key in a JSON object. Missing
  97 -- keys, or keys that have a \'null\' value, will be returned as
  98 -- 'Nothing', otherwise we attempt deserialisation and return a 'Just'
  99 -- value.
 100 maybeFromObj :: (J.JSON a, Monad m) =>
 101                 JSRecord -> String -> m (Maybe a)
 102 maybeFromObj o k =
 103   case lookup k o of
 104     Nothing -> return Nothing
 105     -- a optional key with value JSNull is the same as missing, since
 106     -- we can't convert it meaningfully anyway to a Haskell type, and
 107     -- the Python code can emit 'null' for optional values (depending
 108     -- on usage), and finally our encoding rules treat 'null' values
 109     -- as 'missing'
 110     Just J.JSNull -> return Nothing
 111     Just val -> liftM Just (fromKeyValue k val)
 112
 113 -- | Reads the value of a key in a JSON object with a default if
 114 -- missing. Note that both missing keys and keys with value \'null\'
 115 -- will case the default value to be returned.
 116 fromObjWithDefault :: (J.JSON a, Monad m) =>
 117                       JSRecord -> String -> a -> m a
 118 fromObjWithDefault o k d = liftM (fromMaybe d) $ maybeFromObj o k
 119
 120 -- | Reads a JValue, that originated from an object key.
 121 fromKeyValue :: (J.JSON a, Monad m)
 122               => String     -- ^ The key name
 123               -> J.JSValue  -- ^ The value to read
 124               -> m a
 125 fromKeyValue k val =
 126   fromJResult (printf "key '%s'" k) (J.readJSON val)
 127
 128 -- | Small wrapper over readJSON.
 129 fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a
 130 fromJVal v =
 131   case J.readJSON v of
 132     J.Error s -> fail ("Cannot convert value '" ++ show (pp_value v) ++
 133                        "', error: " ++ s)
 134     J.Ok x -> return x
 135
 136 -- | Helper function that returns Null or first element of the list.
 137 jsonHead :: (J.JSON b) => [a] -> (a -> b) -> J.JSValue
 138 jsonHead [] _ = J.JSNull
 139 jsonHead (x:_) f = J.showJSON $ f x
 140
 141 -- | Helper for extracting Maybe values from a possibly empty list.
 142 getMaybeJsonHead :: (J.JSON b) => [a] -> (a -> Maybe b) -> J.JSValue
 143 getMaybeJsonHead [] _ = J.JSNull
 144 getMaybeJsonHead (x:_) f = maybe J.JSNull J.showJSON (f x)
 145
 146 -- | Converts a JSON value into a JSON object.
 147 asJSObject :: (Monad m) => J.JSValue -> m (J.JSObject J.JSValue)
 148 asJSObject (J.JSObject a) = return a
 149 asJSObject _ = fail "not an object"
 150
 151 -- | Coneverts a list of JSON values into a list of JSON objects.
 152 asObjectList :: (Monad m) => [J.JSValue] -> m [J.JSObject J.JSValue]
 153 asObjectList = mapM asJSObject
 154
 155 -- | Try to extract a key from a object with better error reporting
 156 -- than fromObj.
 157 tryFromObj :: (J.JSON a) =>
 158               String     -- ^ Textual "owner" in error messages
 159            -> JSRecord   -- ^ The object array
 160            -> String     -- ^ The desired key from the object
 161            -> Result a
 162 tryFromObj t o = annotateResult t . fromObj o
 163
 164 -- | Ensure a given JSValue is actually a JSArray.
 165 toArray :: (Monad m) => J.JSValue -> m [J.JSValue]
 166 toArray (J.JSArray arr) = return arr
 167 toArray o =
 168   fail $ "Invalid input, expected array but got " ++ show (pp_value o)
 169
 170 -- * Container type (special type for JSON serialisation)
 171
 172 -- | Class of types that can be converted from Strings. This is
 173 -- similar to the 'Read' class, but it's using a different
 174 -- serialisation format, so we have to define a separate class. Mostly
 175 -- useful for custom key types in JSON dictionaries, which have to be
 176 -- backed by strings.
 177 class HasStringRepr a where
 178   fromStringRepr :: (Monad m) => String -> m a
 179   toStringRepr :: a -> String
 180
 181 -- | Trivial instance 'HasStringRepr' for 'String'.
 182 instance HasStringRepr String where
 183   fromStringRepr = return
 184   toStringRepr = id
 185
 186 -- | The container type, a wrapper over Data.Map
 187 newtype GenericContainer a b =
 188   GenericContainer { fromContainer :: Map.Map a b }
 189   deriving (Show, Read, Eq)
 190
 191 -- | Type alias for string keys.
 192 type Container = GenericContainer String
 193
 194 -- | Container loader.
 195 readContainer :: (Monad m, HasStringRepr a, Ord a, J.JSON b) =>
 196                  J.JSObject J.JSValue -> m (GenericContainer a b)
 197 readContainer obj = do
 198   let kjvlist = J.fromJSObject obj
 199   kalist <- mapM (\(k, v) -> do
 200                     k' <- fromStringRepr k
 201                     v' <- fromKeyValue k v
 202                     return (k', v')) kjvlist
 203   return $ GenericContainer (Map.fromList kalist)
 204
 205 {-# ANN showContainer "HLint: ignore Use ***" #-}
 206 -- | Container dumper.
 207 showContainer :: (HasStringRepr a, J.JSON b) =>
 208                  GenericContainer a b -> J.JSValue
 209 showContainer =
 210   J.makeObj . map (\(k, v) -> (toStringRepr k, J.showJSON v)) .
 211   Map.toList . fromContainer
 212
 213 instance (HasStringRepr a, Ord a, J.JSON b) =>
 214          J.JSON (GenericContainer a b) where
 215   showJSON = showContainer
 216   readJSON (J.JSObject o) = readContainer o
 217   readJSON v = fail $ "Failed to load container, expected object but got "
 218                ++ show (pp_value v)