This makes the type definitions a bit more readable/simpler.
---
htools/Ganeti/HTools/IAlloc.hs | 22 +++++++++++-----------
htools/Ganeti/HTools/Rapi.hs | 8 ++++----
htools/Ganeti/HTools/Utils.hs | 16 ++++++++++------
3 files changed, 25 insertions(+), 21 deletions(-)
diff --git a/htools/Ganeti/HTools/IAlloc.hs b/htools/Ganeti/HTools/IAlloc.hs
index 6e55e0d..f06d984 100644
--- a/htools/Ganeti/HTools/IAlloc.hs
+++ b/htools/Ganeti/HTools/IAlloc.hs
@@ -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" []
diff --git a/htools/Ganeti/HTools/Rapi.hs b/htools/Ganeti/HTools/Rapi.hs
index 589c9f7..444934d 100644
--- a/htools/Ganeti/HTools/Rapi.hs
+++ b/htools/Ganeti/HTools/Rapi.hs
@@ -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
diff --git a/htools/Ganeti/HTools/Utils.hs b/htools/Ganeti/HTools/Utils.hs
index b26f858..efac41e 100644
--- a/htools/Ganeti/HTools/Utils.hs
+++ b/htools/Ganeti/HTools/Utils.hs
@@ -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
--
1.7.3.1
