Currently, fromObj/maybeFromObj take first the key, and then the
object. This is suboptimal, as this form is not easy to use with
partial functional application.
To make it easier to switch between tryFromObj, fromObj and
maybeFromObj, we unify the latter two functions to the same order
(object and then key) like the first one. The code churn in the other
modules is due to this, but the main change in this patch is in
Utils.hs.
Furthermore, since we change anyway the calls, we do replace fromObj
with tryFromObj in IAllocator.hs so that we get better error messages.
---
Ganeti/HTools/IAlloc.hs | 66 +++++++++++++++++++++++++----------------------
Ganeti/HTools/Utils.hs | 14 +++++-----
Ganeti/Luxi.hs | 8 +++---
Ganeti/OpCodes.hs | 31 +++++++++++----------
4 files changed, 62 insertions(+), 57 deletions(-)
diff --git a/Ganeti/HTools/IAlloc.hs b/Ganeti/HTools/IAlloc.hs
index 903801a..228b408 100644
--- a/Ganeti/HTools/IAlloc.hs
+++ b/Ganeti/HTools/IAlloc.hs
@@ -4,7 +4,7 @@
{-
-Copyright (C) 2009, 2010 Google Inc.
+Copyright (C) 2009, 2010, 2011 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -50,10 +50,11 @@ parseBaseInstance :: String
-> [(String, JSValue)]
-> Result (String, Instance.Instance)
parseBaseInstance n a = do
- disk <- fromObj "disk_space_total" a
- mem <- fromObj "memory" a
- vcpus <- fromObj "vcpus" a
- tags <- fromObj "tags" a
+ let extract x = tryFromObj ("invalid data for instance '" ++ n ++ "'") a x
+ disk <- extract "disk_space_total"
+ mem <- extract "memory"
+ vcpus <- extract "vcpus"
+ tags <- extract "tags"
let running = "running"
return (n, Instance.create n mem disk vcpus running tags 0 0)
@@ -64,7 +65,7 @@ parseInstance :: NameAssoc -- ^ The node name-to-index
association list
-> Result (String, Instance.Instance)
parseInstance ktn n a = do
base <- parseBaseInstance n a
- nodes <- fromObj "nodes" a
+ nodes <- fromObj a "nodes"
pnode <- if null nodes
then Bad $ "empty node list for instance " ++ n
else readEitherString $ head nodes
@@ -80,19 +81,20 @@ parseNode :: NameAssoc -- ^ The group association
-> [(String, JSValue)] -- ^ The JSON object
-> Result (String, Node.Node)
parseNode ktg n a = do
- offline <- fromObj "offline" a
- drained <- fromObj "drained" a
- guuid <- fromObj "group" a
+ let extract x = tryFromObj ("invalid data for node '" ++ n ++ "'") a x
+ offline <- extract "offline"
+ drained <- extract "drained"
+ guuid <- extract "group"
gidx <- lookupGroup ktg n guuid
node <- (if offline || drained
then return $ Node.create n 0 0 0 0 0 0 True gidx
else do
- mtotal <- fromObj "total_memory" a
- mnode <- fromObj "reserved_memory" a
- mfree <- fromObj "free_memory" a
- dtotal <- fromObj "total_disk" a
- dfree <- fromObj "free_disk" a
- ctotal <- fromObj "total_cpus" a
+ mtotal <- extract "total_memory"
+ mnode <- extract "reserved_memory"
+ mfree <- extract "free_memory"
+ dtotal <- extract "total_disk"
+ dfree <- extract "free_disk"
+ ctotal <- extract "total_cpus"
return $ Node.create n mtotal mnode mfree
dtotal dfree ctotal False gidx)
return (n, node)
@@ -102,7 +104,7 @@ parseGroup :: String -- ^ The group UUID
-> [(String, JSValue)] -- ^ The JSON object
-> Result (String, Group.Group)
parseGroup u a = do
- name <- fromObj "name" a
+ name <- fromObj a "name"
return (u, Group.create name u AllocPreferred)
-- | Top-level parser.
@@ -111,48 +113,50 @@ parseData :: String -- ^ The JSON message as
received from Ganeti
parseData body = do
decoded <- fromJResult "Parsing input IAllocator message" (decodeStrict body)
let obj = fromJSObject decoded
+ extrObj x = tryFromObj "invalid iallocator message" obj x
-- request parser
- request <- liftM fromJSObject (fromObj "request" obj)
+ request <- liftM fromJSObject (extrObj "request")
+ let extrReq x = tryFromObj "invalid request dict" request x
-- existing group parsing
- glist <- liftM fromJSObject (fromObj "nodegroups" obj)
+ glist <- liftM fromJSObject (extrObj "nodegroups")
gobj <- mapM (\(x, y) -> asJSObject y >>= parseGroup x . fromJSObject) glist
let (ktg, gl) = assignIndices gobj
-- existing node parsing
- nlist <- liftM fromJSObject (fromObj "nodes" obj)
+ nlist <- liftM fromJSObject (extrObj "nodes")
nobj <- mapM (\(x,y) ->
asJSObject y >>= parseNode ktg x . fromJSObject) nlist
let (ktn, nl) = assignIndices nobj
-- existing instance parsing
- ilist <- fromObj "instances" obj
+ ilist <- extrObj "instances"
let idata = fromJSObject ilist
iobj <- mapM (\(x,y) ->
asJSObject y >>= parseInstance ktn x . fromJSObject) idata
let (kti, il) = assignIndices iobj
-- cluster tags
- ctags <- fromObj "cluster_tags" obj
+ ctags <- extrObj "cluster_tags"
cdata <- mergeData [] [] [] (ClusterData gl nl il ctags)
let map_n = cdNodes cdata
- optype <- fromObj "type" request
+ optype <- extrReq "type"
rqtype <-
case optype of
"allocate" ->
do
- rname <- fromObj "name" request
- req_nodes <- fromObj "required_nodes" request
- inew <- parseBaseInstance rname request
+ rname <- extrReq "name"
+ req_nodes <- extrReq "required_nodes"
+ inew <- parseBaseInstance rname request
let io = snd inew
return $ Allocate io req_nodes
"relocate" ->
do
- rname <- fromObj "name" request
- ridx <- lookupInstance kti rname
- req_nodes <- fromObj "required_nodes" request
- ex_nodes <- fromObj "relocate_from" request
- ex_idex <- mapM (Container.findByName map_n) ex_nodes
+ rname <- extrReq "name"
+ ridx <- lookupInstance kti rname
+ req_nodes <- extrReq "required_nodes"
+ ex_nodes <- extrReq "relocate_from"
+ ex_idex <- mapM (Container.findByName map_n) ex_nodes
return $ Relocate ridx req_nodes (map Node.idx ex_idex)
"multi-evacuate" ->
do
- ex_names <- fromObj "evac_nodes" request
+ ex_names <- extrReq "evac_nodes"
ex_nodes <- mapM (Container.findByName map_n) ex_names
let ex_ndx = map Node.idx ex_nodes
return $ Evacuate ex_ndx
diff --git a/Ganeti/HTools/Utils.hs b/Ganeti/HTools/Utils.hs
index 6091858..1e58bc3 100644
--- a/Ganeti/HTools/Utils.hs
+++ b/Ganeti/HTools/Utils.hs
@@ -2,7 +2,7 @@
{-
-Copyright (C) 2009, 2010 Google Inc.
+Copyright (C) 2009, 2010, 2011 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -127,16 +127,16 @@ 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 -> [(String, J.JSValue)] -> m a
-fromObj k o =
+fromObj :: (J.JSON a, Monad m) => [(String, J.JSValue)] -> String -> m a
+fromObj o k =
case lookup k o of
Nothing -> fail $ printf "key '%s' not found in %s" k (show o)
Just val -> fromKeyValue k val
-- | Reads the value of an optional key in a JSON object.
-maybeFromObj :: (J.JSON a, Monad m) => String -> [(String, J.JSValue)]
- -> m (Maybe a)
-maybeFromObj k o =
+maybeFromObj :: (J.JSON a, Monad m) =>
+ [(String, J.JSValue)] -> String -> m (Maybe a)
+maybeFromObj o k =
case lookup k o of
Nothing -> return Nothing
Just val -> liftM Just (fromKeyValue k val)
@@ -161,7 +161,7 @@ tryFromObj :: (J.JSON a) =>
-> [(String, J.JSValue)] -- ^ The object array
-> String -- ^ The desired key from the object
-> Result a
-tryFromObj t o k = annotateResult t (fromObj k o)
+tryFromObj t o = annotateResult t . fromObj o
-- | Small wrapper over readJSON.
fromJVal :: (Monad m, J.JSON a) => J.JSValue -> m a
diff --git a/Ganeti/Luxi.hs b/Ganeti/Luxi.hs
index 1f65f1e..56024a5 100644
--- a/Ganeti/Luxi.hs
+++ b/Ganeti/Luxi.hs
@@ -4,7 +4,7 @@
{-
-Copyright (C) 2009, 2010 Google Inc.
+Copyright (C) 2009, 2010, 2011 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -201,11 +201,11 @@ validateResult s = do
oarr <- fromJResult "Parsing LUXI response"
(decodeStrict s)::Result (JSObject JSValue)
let arr = J.fromJSObject oarr
- status <- fromObj (strOfKey Success) arr::Result Bool
+ status <- fromObj arr (strOfKey Success)::Result Bool
let rkey = strOfKey Result
(if status
- then fromObj rkey arr
- else fromObj rkey arr >>= fail)
+ then fromObj arr rkey
+ else fromObj arr rkey >>= fail)
-- | Generic luxi method call.
callMethod :: LuxiOp -> Client -> IO (Result JSValue)
diff --git a/Ganeti/OpCodes.hs b/Ganeti/OpCodes.hs
index 7b3e434..972a2dc 100644
--- a/Ganeti/OpCodes.hs
+++ b/Ganeti/OpCodes.hs
@@ -4,7 +4,7 @@
{-
-Copyright (C) 2009, 2010 Google Inc.
+Copyright (C) 2009, 2010, 2011 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
@@ -72,28 +72,29 @@ opID (OpMigrateInstance _ _ _) = "OP_INSTANCE_MIGRATE"
loadOpCode :: JSValue -> J.Result OpCode
loadOpCode v = do
o <- liftM J.fromJSObject (readJSON v)
- op_id <- fromObj "OP_ID" o
+ let extract x = fromObj o x
+ op_id <- extract "OP_ID"
case op_id of
"OP_TEST_DELAY" -> do
- on_nodes <- fromObj "on_nodes" o
- on_master <- fromObj "on_master" o
- duration <- fromObj "duration" o
+ on_nodes <- extract "on_nodes"
+ on_master <- extract "on_master"
+ duration <- extract "duration"
return $ OpTestDelay duration on_master on_nodes
"OP_INSTANCE_REPLACE_DISKS" -> do
- inst <- fromObj "instance_name" o
- node <- maybeFromObj "remote_node" o
- mode <- fromObj "mode" o
- disks <- fromObj "disks" o
- ialloc <- maybeFromObj "iallocator" o
+ inst <- extract "instance_name"
+ node <- maybeFromObj o "remote_node"
+ mode <- extract "mode"
+ disks <- extract "disks"
+ ialloc <- maybeFromObj o "iallocator"
return $ OpReplaceDisks inst node mode disks ialloc
"OP_INSTANCE_FAILOVER" -> do
- inst <- fromObj "instance_name" o
- consist <- fromObj "ignore_consistency" o
+ inst <- extract "instance_name"
+ consist <- extract "ignore_consistency"
return $ OpFailoverInstance inst consist
"OP_INSTANCE_MIGRATE" -> do
- inst <- fromObj "instance_name" o
- live <- fromObj "live" o
- cleanup <- fromObj "cleanup" o
+ inst <- extract "instance_name"
+ live <- extract "live"
+ cleanup <- extract "cleanup"
return $ OpMigrateInstance inst live cleanup
_ -> J.Error $ "Unknown opcode " ++ op_id
--
1.7.3.1
