On Fri, Jan 7, 2011 at 15:02, Iustin Pop <[email protected]> wrote:
> 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
>
>
LGTM++
