{-
-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 Text.JSON
import qualified Ganeti.Luxi as L
+import qualified Ganeti.Query.Language as Qlang
import Ganeti.HTools.Loader
import Ganeti.HTools.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)
+import Ganeti.JSON
+
+{-# ANN module "HLint: ignore Eta reduce" #-}
-- * Utility functions
--- | Ensure a given JSValue is actually a JSArray.
-toArray :: (Monad m) => JSValue -> m [JSValue]
-toArray v =
- case v of
- JSArray arr -> return arr
- o -> fail ("Invalid input, expected array but got " ++ show o)
+-- | Get values behind \"data\" part of the result.
+getData :: (Monad m) => JSValue -> m JSValue
+getData (JSObject o) = fromObj (fromJSObject o) "data"
+getData x = fail $ "Invalid input, expected dict entry but got " ++ show x
+
+-- | Converts a (status, value) into m value, if possible.
+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
+
+-- | 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
+
+-- | 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
+
+-- | Prepare resulting output as parsers expect it.
+extractArray :: (Monad m) => JSValue -> m [[(JSValue, JSValue)]]
+extractArray v =
+ getData v >>= parseQueryResult
+
+-- | 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
+ Qlang.checkRS st' v >>= fromJVal
-- | Annotate errors when converting values with owner/attribute for
-- better debugging.
genericConvert :: (Text.JSON.JSON a) =>
- String -- ^ The object type
- -> String -- ^ The object name
- -> String -- ^ The attribute we're trying to convert
- -> JSValue -- ^ The value we try to convert
- -> Result a -- ^ The annotated result
+ String -- ^ The object type
+ -> String -- ^ The object name
+ -> String -- ^ The attribute we're trying to convert
+ -> (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 ++ "'") . fromJVal
+ annotateResult (otype ++ " '" ++ oname ++
+ "', error while reading attribute '" ++
+ oattr ++ "'") . fromJValWithStatus
-- * Data querying functionality
-- | The input data for node query.
queryNodesMsg :: L.LuxiOp
queryNodesMsg =
- L.QueryNodes [] ["name", "mtotal", "mnode", "mfree", "dtotal", "dfree",
- "ctotal", "offline", "drained", "vm_capable",
- "group.uuid"] False
+ L.Query Qlang.QRNode ["name", "mtotal", "mnode", "mfree", "dtotal", "dfree",
+ "ctotal", "offline", "drained", "vm_capable",
+ "ndp/spindle_count", "group.uuid"] Qlang.EmptyFilter
-- | The input data for instance query.
queryInstancesMsg :: L.LuxiOp
queryInstancesMsg =
- L.QueryInstances [] ["name", "disk_usage", "be/memory", "be/vcpus",
- "status", "pnode", "snodes", "tags", "oper_ram",
- "be/auto_balance", "disk_template"] False
+ L.Query Qlang.QRInstance ["name", "disk_usage", "be/memory", "be/vcpus",
+ "status", "pnode", "snodes", "tags", "oper_ram",
+ "be/auto_balance", "disk_template",
+ "be/spindle_use"] Qlang.EmptyFilter
-- | The input data for cluster query.
queryClusterInfoMsg :: L.LuxiOp
-- | The input data for node group query.
queryGroupsMsg :: L.LuxiOp
queryGroupsMsg =
- L.QueryGroups [] ["uuid", "name", "alloc_policy"] False
+ L.Query Qlang.QRGroup ["uuid", "name", "alloc_policy", "ipolicy"]
+ Qlang.EmptyFilter
-- | Wraper over 'callMethod' doing node query.
queryNodes :: L.Client -> IO (Result JSValue)
getInstances :: NameAssoc
-> JSValue
-> Result [(String, Instance.Instance)]
-getInstances ktn arr = toArray arr >>= mapM (parseInstance ktn)
+getInstances ktn arr = extractArray arr >>= mapM (parseInstance ktn)
-- | Construct an instance from a JSON object.
parseInstance :: NameAssoc
- -> JSValue
+ -> [(JSValue, JSValue)]
-> Result (String, Instance.Instance)
-parseInstance ktn (JSArray [ name, disk, mem, vcpus
- , status, pnode, snodes, tags, oram
- , auto_balance, disk_template ]) = do
- xname <- annotateResult "Parsing new instance" (fromJVal name)
+parseInstance ktn [ name, disk, mem, vcpus
+ , status, pnode, snodes, tags, oram
+ , auto_balance, disk_template, su ] = do
+ xname <- annotateResult "Parsing new instance" (fromJValWithStatus name)
let convert a = genericConvert "Instance" xname a
xdisk <- convert "disk_usage" disk
- xmem <- (case oram of
- 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
xdt <- convert "disk_template" disk_template
+ xsu <- convert "be/spindle_use" su
let inst = Instance.create xname xmem xdisk xvcpus
- xrunning xtags xauto_balance xpnode snode xdt
+ xrunning xtags xauto_balance xpnode snode xdt xsu
return (xname, inst)
parseInstance _ v = fail ("Invalid instance query result: " ++ show v)
-- | Parse a node list in JSON format.
getNodes :: NameAssoc -> JSValue -> Result [(String, Node.Node)]
-getNodes ktg arr = toArray arr >>= mapM (parseNode ktg)
+getNodes ktg arr = extractArray arr >>= mapM (parseNode ktg)
-- | Construct a node from a JSON object.
-parseNode :: NameAssoc -> JSValue -> Result (String, Node.Node)
-parseNode ktg (JSArray [ name, mtotal, mnode, mfree, dtotal, dfree
- , ctotal, offline, drained, vm_capable, g_uuid ])
+parseNode :: NameAssoc -> [(JSValue, JSValue)] -> Result (String, Node.Node)
+parseNode ktg [ name, mtotal, mnode, mfree, dtotal, dfree
+ , ctotal, offline, drained, vm_capable, spindles, g_uuid ]
= do
- xname <- annotateResult "Parsing new node" (fromJVal name)
+ 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)]
-getGroups arr = toArray arr >>= mapM parseGroup
+getGroups jsv = extractArray jsv >>= mapM parseGroup
-- | Parses a given group information.
-parseGroup :: JSValue -> Result (String, Group.Group)
-parseGroup (JSArray [ uuid, name, apol ]) = do
- xname <- annotateResult "Parsing new group" (fromJVal name)
+parseGroup :: [(JSValue, JSValue)] -> Result (String, Group.Group)
+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