Commit e8230242 authored by Iustin Pop's avatar Iustin Pop
Browse files

JSON functions: change signature of (maybe)fromObj



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.
Signed-off-by: default avatarIustin Pop <iustin@google.com>
Reviewed-by: default avatarBalazs Lecz <leczb@google.com>
parent 1bc47d38
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
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