{-
-Copyright (C) 2009, 2010, 2011 Google Inc.
+Copyright (C) 2009, 2010, 2011, 2012 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
-}
module Ganeti.HTools.Luxi
- (
- loadData
- , parseData
- ) where
+ ( loadData
+ , parseData
+ ) where
import qualified Control.Exception as E
import Text.JSON.Types
import qualified Ganeti.HTools.Group as Group
import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.HTools.Instance as Instance
-import Ganeti.HTools.Utils (fromJVal, annotateResult, tryFromObj, asJSObject,
- fromObj)
+import Ganeti.HTools.JSON
+
+{-# ANN module "HLint: ignore Eta reduce" #-}
-- * Utility functions
parseQueryField :: (Monad m) => JSValue -> m (JSValue, JSValue)
parseQueryField (JSArray [status, result]) = return (status, result)
parseQueryField o =
- fail $ "Invalid query field, expected (status, value) but got " ++ show o
+ fail $ "Invalid query field, expected (status, value) but got " ++ show o
-- | Parse a result row.
parseQueryRow :: (Monad m) => JSValue -> m [(JSValue, JSValue)]
parseQueryRow (JSArray arr) = mapM parseQueryField arr
parseQueryRow o =
- fail $ "Invalid query row result, expected array but got " ++ show o
+ fail $ "Invalid query row result, expected array but got " ++ show o
-- | Parse an overall query result and get the [(status, value)] list
-- for each element queried.
parseQueryResult :: (Monad m) => JSValue -> m [[(JSValue, JSValue)]]
parseQueryResult (JSArray arr) = mapM parseQueryRow arr
parseQueryResult o =
- fail $ "Invalid query result, expected array but got " ++ show o
+ fail $ "Invalid query result, expected array but got " ++ show o
-- | Prepare resulting output as parsers expect it.
extractArray :: (Monad m) => JSValue -> m [[(JSValue, JSValue)]]
-- | Testing result status for more verbose error message.
fromJValWithStatus :: (Text.JSON.JSON a, Monad m) => (JSValue, JSValue) -> m a
fromJValWithStatus (st, v) = do
- st' <- fromJVal st
- L.checkRS st' v >>= fromJVal
+ st' <- fromJVal st
+ L.checkRS st' v >>= fromJVal
-- | Annotate errors when converting values with owner/attribute for
-- better debugging.
-> (JSValue, JSValue) -- ^ The value we're trying to convert
-> Result a -- ^ The annotated result
genericConvert otype oname oattr =
- annotateResult (otype ++ " '" ++ oname ++
- "', error while reading attribute '" ++
- oattr ++ "'") . fromJValWithStatus
+ annotateResult (otype ++ " '" ++ oname ++
+ "', error while reading attribute '" ++
+ oattr ++ "'") . fromJValWithStatus
-- * Data querying functionality
queryNodesMsg =
L.Query L.QRNode ["name", "mtotal", "mnode", "mfree", "dtotal", "dfree",
"ctotal", "offline", "drained", "vm_capable",
- "group.uuid"] ()
+ "ndp/spindle_count", "group.uuid"] ()
-- | The input data for instance query.
queryInstancesMsg :: L.LuxiOp
queryInstancesMsg =
- L.Query L.QRInstance ["name", "disk_usage", "be/memory", "be/vcpus",
- "status", "pnode", "snodes", "tags", "oper_ram",
- "be/auto_balance", "disk_template"] ()
+ L.Query L.QRInstance ["name", "disk_usage", "be/memory", "be/vcpus",
+ "status", "pnode", "snodes", "tags", "oper_ram",
+ "be/auto_balance", "disk_template"] ()
-- | The input data for cluster query.
queryClusterInfoMsg :: L.LuxiOp
-- | The input data for node group query.
queryGroupsMsg :: L.LuxiOp
queryGroupsMsg =
- L.Query L.QRGroup ["uuid", "name", "alloc_policy"] ()
+ L.Query L.QRGroup ["uuid", "name", "alloc_policy", "ipolicy"] ()
-- | Wraper over 'callMethod' doing node query.
queryNodes :: L.Client -> IO (Result JSValue)
xname <- annotateResult "Parsing new instance" (fromJValWithStatus name)
let convert a = genericConvert "Instance" xname a
xdisk <- convert "disk_usage" disk
- xmem <- (case oram of -- FIXME: remove the "guessing"
- (_, JSRational _ _) -> convert "oper_ram" oram
- _ -> convert "be/memory" mem)
+ xmem <- case oram of -- FIXME: remove the "guessing"
+ (_, JSRational _ _) -> convert "oper_ram" oram
+ _ -> convert "be/memory" mem
xvcpus <- convert "be/vcpus" vcpus
xpnode <- convert "pnode" pnode >>= lookupNode ktn xname
xsnodes <- convert "snodes" snodes::Result [JSString]
- snode <- (if null xsnodes then return Node.noSecondary
- else lookupNode ktn xname (fromJSString $ head xsnodes))
+ snode <- if null xsnodes
+ then return Node.noSecondary
+ else lookupNode ktn xname (fromJSString $ head xsnodes)
xrunning <- convert "status" status
xtags <- convert "tags" tags
xauto_balance <- convert "auto_balance" auto_balance
-- | Construct a node from a JSON object.
parseNode :: NameAssoc -> [(JSValue, JSValue)] -> Result (String, Node.Node)
parseNode ktg [ name, mtotal, mnode, mfree, dtotal, dfree
- , ctotal, offline, drained, vm_capable, g_uuid ]
+ , ctotal, offline, drained, vm_capable, spindles, g_uuid ]
= do
xname <- annotateResult "Parsing new node" (fromJValWithStatus name)
let convert a = genericConvert "Node" xname a
xoffline <- convert "offline" offline
xdrained <- convert "drained" drained
xvm_capable <- convert "vm_capable" vm_capable
+ xspindles <- convert "spindles" spindles
xgdx <- convert "group.uuid" g_uuid >>= lookupGroup ktg xname
- node <- (if xoffline || xdrained || not xvm_capable
- then return $ Node.create xname 0 0 0 0 0 0 True xgdx
- else do
- xmtotal <- convert "mtotal" mtotal
- xmnode <- convert "mnode" mnode
- xmfree <- convert "mfree" mfree
- xdtotal <- convert "dtotal" dtotal
- xdfree <- convert "dfree" dfree
- xctotal <- convert "ctotal" ctotal
- return $ Node.create xname xmtotal xmnode xmfree
- xdtotal xdfree xctotal False xgdx)
+ node <- if xoffline || xdrained || not xvm_capable
+ then return $ Node.create xname 0 0 0 0 0 0 True xspindles xgdx
+ else do
+ xmtotal <- convert "mtotal" mtotal
+ xmnode <- convert "mnode" mnode
+ xmfree <- convert "mfree" mfree
+ xdtotal <- convert "dtotal" dtotal
+ xdfree <- convert "dfree" dfree
+ xctotal <- convert "ctotal" ctotal
+ return $ Node.create xname xmtotal xmnode xmfree
+ xdtotal xdfree xctotal False xspindles xgdx
return (xname, node)
parseNode _ v = fail ("Invalid node query result: " ++ show v)
-- | Parses the cluster tags.
-getClusterTags :: JSValue -> Result [String]
-getClusterTags v = do
+getClusterData :: JSValue -> Result ([String], IPolicy)
+getClusterData (JSObject obj) = do
let errmsg = "Parsing cluster info"
- obj <- annotateResult errmsg $ asJSObject v
- tryFromObj errmsg (fromJSObject obj) "tags"
+ obj' = fromJSObject obj
+ ctags <- tryFromObj errmsg obj' "tags"
+ cpol <- tryFromObj errmsg obj' "ipolicy"
+ return (ctags, cpol)
+
+getClusterData _ = Bad $ "Cannot parse cluster info, not a JSON record"
-- | Parses the cluster groups.
getGroups :: JSValue -> Result [(String, Group.Group)]
-- | Parses a given group information.
parseGroup :: [(JSValue, JSValue)] -> Result (String, Group.Group)
-parseGroup [uuid, name, apol] = do
+parseGroup [uuid, name, apol, ipol] = do
xname <- annotateResult "Parsing new group" (fromJValWithStatus name)
let convert a = genericConvert "Group" xname a
xuuid <- convert "uuid" uuid
xapol <- convert "alloc_policy" apol
- return (xuuid, Group.create xname xuuid xapol)
+ xipol <- convert "ipolicy" ipol
+ return (xuuid, Group.create xname xuuid xapol xipol)
parseGroup v = fail ("Invalid group query result: " ++ show v)
let (node_names, node_idx) = assignIndices node_data
inst_data <- instances >>= getInstances node_names
let (_, inst_idx) = assignIndices inst_data
- ctags <- cinfo >>= getClusterTags
- return (ClusterData group_idx node_idx inst_idx ctags)
+ (ctags, cpol) <- cinfo >>= getClusterData
+ return (ClusterData group_idx node_idx inst_idx ctags cpol)
-- | Top level function for data loading.
loadData :: String -- ^ Unix socket to use as source
projects / ganeti-local / blobdiff