Commit 28f19313 authored by Iustin Pop's avatar Iustin Pop
Browse files

htools: introduce a type alias for JSON objects



This makes the type definitions a bit more readable/simpler.
Signed-off-by: default avatarIustin Pop <iustin@google.com>
Reviewed-by: default avatarMichael Hanselmann <hansmi@google.com>
parent b5cec17a
......@@ -49,7 +49,7 @@ import Ganeti.HTools.Types
-- 'Allocate' request share some common properties, which are read by
-- this function.
parseBaseInstance :: String
-> [(String, JSValue)]
-> JSRecord
-> Result (String, Instance.Instance)
parseBaseInstance n a = do
let extract x = tryFromObj ("invalid data for instance '" ++ n ++ "'") a x
......@@ -61,9 +61,9 @@ parseBaseInstance n a = do
return (n, Instance.create n mem disk vcpus running tags True 0 0)
-- | Parses an instance as found in the cluster instance listg.
parseInstance :: NameAssoc -- ^ The node name-to-index association list
-> String -- ^ The name of the instance
-> [(String, JSValue)] -- ^ The JSON object
parseInstance :: NameAssoc -- ^ The node name-to-index association list
-> String -- ^ The name of the instance
-> JSRecord -- ^ The JSON object
-> Result (String, Instance.Instance)
parseInstance ktn n a = do
base <- parseBaseInstance n a
......@@ -78,9 +78,9 @@ parseInstance ktn n a = do
return (n, Instance.setBoth (snd base) pidx sidx)
-- | Parses a node as found in the cluster node list.
parseNode :: NameAssoc -- ^ The group association
-> String -- ^ The node's name
-> [(String, JSValue)] -- ^ The JSON object
parseNode :: NameAssoc -- ^ The group association
-> String -- ^ The node's name
-> JSRecord -- ^ The JSON object
-> Result (String, Node.Node)
parseNode ktg n a = do
let desc = "invalid data for node '" ++ n ++ "'"
......@@ -105,8 +105,8 @@ parseNode ktg n a = do
return (n, node)
-- | Parses a group as found in the cluster group list.
parseGroup :: String -- ^ The group UUID
-> [(String, JSValue)] -- ^ The JSON object
parseGroup :: String -- ^ The group UUID
-> JSRecord -- ^ The JSON object
-> Result (String, Group.Group)
parseGroup u a = do
let extract x = tryFromObj ("invalid data for group '" ++ u ++ "'") a x
......@@ -114,8 +114,8 @@ parseGroup u a = do
apol <- extract "alloc_policy"
return (u, Group.create name u apol)
parseTargetGroups :: [(String, JSValue)] -- ^ The JSON object (request dict)
-> Group.List -- ^ The existing groups
parseTargetGroups :: JSRecord -- ^ The JSON object (request dict)
-> Group.List -- ^ The existing groups
-> Result [Gdx]
parseTargetGroups req map_g = do
group_uuids <- fromObjWithDefault req "target_groups" []
......
......@@ -37,7 +37,7 @@ import Network.Curl
import Network.Curl.Types ()
#endif
import Control.Monad
import Text.JSON (JSObject, JSValue, fromJSObject, decodeStrict)
import Text.JSON (JSObject, fromJSObject, decodeStrict)
import Text.JSON.Types (JSValue(..))
import Text.Printf (printf)
......@@ -104,7 +104,7 @@ getFakeGroups =
-- | Construct an instance from a JSON object.
parseInstance :: NameAssoc
-> [(String, JSValue)]
-> JSRecord
-> Result (String, Instance.Instance)
parseInstance ktn a = do
name <- tryFromObj "Parsing new instance" a "name"
......@@ -129,7 +129,7 @@ parseInstance ktn a = do
return (name, inst)
-- | Construct a node from a JSON object.
parseNode :: NameAssoc -> [(String, JSValue)] -> Result (String, Node.Node)
parseNode :: NameAssoc -> JSRecord -> Result (String, Node.Node)
parseNode ktg a = do
name <- tryFromObj "Parsing new node" a "name"
let desc = "Node '" ++ name ++ "', error while parsing data"
......@@ -154,7 +154,7 @@ parseNode ktg a = do
return (name, node)
-- | Construct a group from a JSON object.
parseGroup :: [(String, JSValue)] -> Result (String, Group.Group)
parseGroup :: JSRecord -> Result (String, Group.Group)
parseGroup a = do
name <- tryFromObj "Parsing new group" a "name"
let extract s = tryFromObj ("Group '" ++ name ++ "'") a s
......
......@@ -30,6 +30,7 @@ module Ganeti.HTools.Utils
, stdDev
, commaJoin
, readEitherString
, JSRecord
, loadJSArray
, fromObj
, fromObjWithDefault
......@@ -106,6 +107,9 @@ stdDev lst =
-- * JSON-related functions
-- | A type alias for the list-based representation of J.JSObject
type JSRecord = [(String, J.JSValue)]
-- | Converts a JSON Result into a monadic value.
fromJResult :: Monad m => String -> J.Result a -> m a
fromJResult s (J.Error x) = fail (s ++ ": " ++ x)
......@@ -129,7 +133,7 @@ loadJSArray :: (Monad m)
loadJSArray s = fromJResult s . J.decodeStrict
-- | Reads the value of a key in a JSON object.
fromObj :: (J.JSON a, Monad m) => [(String, J.JSValue)] -> String -> m a
fromObj :: (J.JSON a, Monad m) => JSRecord -> String -> m a
fromObj o k =
case lookup k o of
Nothing -> fail $ printf "key '%s' not found, object contains only %s"
......@@ -138,7 +142,7 @@ fromObj o k =
-- | Reads the value of an optional key in a JSON object.
maybeFromObj :: (J.JSON a, Monad m) =>
[(String, J.JSValue)] -> String -> m (Maybe a)
JSRecord -> String -> m (Maybe a)
maybeFromObj o k =
case lookup k o of
Nothing -> return Nothing
......@@ -146,7 +150,7 @@ maybeFromObj o k =
-- | Reads the value of a key in a JSON object with a default if missing.
fromObjWithDefault :: (J.JSON a, Monad m) =>
[(String, J.JSValue)] -> String -> a -> m a
JSRecord -> String -> a -> m a
fromObjWithDefault o k d = liftM (fromMaybe d) $ maybeFromObj o k
-- | Reads a JValue, that originated from an object key
......@@ -165,9 +169,9 @@ annotateResult _ v = v
-- | Try to extract a key from a object with better error reporting
-- than fromObj
tryFromObj :: (J.JSON a) =>
String -- ^ Textual "owner" in error messages
-> [(String, J.JSValue)] -- ^ The object array
-> String -- ^ The desired key from the object
String -- ^ Textual "owner" in error messages
-> JSRecord -- ^ The object array
-> String -- ^ The desired key from the object
-> Result a
tryFromObj t o = annotateResult t . fromObj o
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment