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 v =
+ case v of
+ JSObject o ->
+ case fromJSObject o of
+ [("data", jsdata), ("fields", _)] -> return jsdata
+ x -> fail $ "Invalid input, expected two-element list but got "
+ ++ show x
+ x -> fail ("Invalid input, expected dict entry but got " ++ show x)
+
+-- | Get [(status, value)] list for each element queried.
+toPairs :: (Monad m) => JSValue -> m [[(JSValue, JSValue)]]
+toPairs (JSArray arr) = do
+ arr' <- mapM toArray arr -- list of resulting elements
+ arr'' <- mapM (mapM toArray) arr' -- list of list of [status, value]
+ return $ map (map (\a -> (a!!0, a!!1))) arr'' -- FIXME: hackish
+toPairs o = fail ("Invalid input, expected array but got " ++ show o)
+
+-- | Prepare resulting output as parsers expect it.
+extractArray :: (Monad m) => JSValue -> m [JSValue]
+extractArray v = do
+ arr <- getData v >>= toPairs
+ return $ map (JSArray. map snd) arr
+
-- | Annotate errors when converting values with owner/attribute for
-- better debugging.
genericConvert :: (Text.JSON.JSON a) =>
-> JSValue -- ^ The value we try to convert
-> Result a -- ^ The annotated result
genericConvert otype oname oattr =
- annotateResult (otype ++ " '" ++ oname ++ "', attribute '" ++
+ annotateResult (otype ++ " '" ++ oname ++
+ "', error while reading attribute '" ++
oattr ++ "'") . fromJVal
-- * 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 L.QRNode ["name", "mtotal", "mnode", "mfree", "dtotal", "dfree",
+ "ctotal", "offline", "drained", "vm_capable",
+ "group.uuid"] ()
-- | 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"] False
+ 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.QueryGroups [] ["uuid", "name", "alloc_policy"] False
+ L.Query L.QRGroup ["uuid", "name", "alloc_policy"] ()
--- | Wraper over callMethod doing node query.
+-- | Wraper over 'callMethod' doing node query.
queryNodes :: L.Client -> IO (Result JSValue)
queryNodes = L.callMethod queryNodesMsg
--- | Wraper over callMethod doing instance query.
+-- | Wraper over 'callMethod' doing instance query.
queryInstances :: L.Client -> IO (Result JSValue)
queryInstances = L.callMethod queryInstancesMsg
+-- | Wrapper over 'callMethod' doing cluster information query.
queryClusterInfo :: L.Client -> IO (Result JSValue)
queryClusterInfo = L.callMethod queryClusterInfoMsg
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
-> Result (String, Instance.Instance)
parseInstance ktn (JSArray [ name, disk, mem, vcpus
, status, pnode, snodes, tags, oram
- , auto_balance ]) = do
+ , auto_balance, disk_template ]) = do
xname <- annotateResult "Parsing new instance" (fromJVal name)
let convert a = genericConvert "Instance" xname a
xdisk <- convert "disk_usage" disk
xrunning <- convert "status" status
xtags <- convert "tags" tags
xauto_balance <- convert "auto_balance" auto_balance
+ xdt <- convert "disk_template" disk_template
let inst = Instance.create xname xmem xdisk xvcpus
- xrunning xtags xauto_balance xpnode snode
+ xrunning xtags xauto_balance xpnode snode xdt
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 _ v = fail ("Invalid node query result: " ++ show v)
+-- | Parses the cluster tags.
getClusterTags :: JSValue -> Result [String]
getClusterTags v = do
let errmsg = "Parsing cluster info"
obj <- annotateResult errmsg $ asJSObject v
tryFromObj errmsg (fromJSObject obj) "tags"
+-- | 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
+parseGroup (JSArray [uuid, name, apol]) = do
xname <- annotateResult "Parsing new group" (fromJVal name)
let convert a = genericConvert "Group" xname a
xuuid <- convert "uuid" uuid
-- * Main loader functionality
--- | Builds the cluster data from an URL.
+-- | Builds the cluster data by querying a given socket name.
readData :: String -- ^ Unix socket to use as source
-> IO (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
readData master =
return (groups, nodes, instances, cinfo)
)
+-- | Converts the output of 'readData' into the internal cluster
+-- representation.
parseData :: (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
-> Result ClusterData
parseData (groups, nodes, instances, cinfo) = do
ctags <- cinfo >>= getClusterTags
return (ClusterData group_idx node_idx inst_idx ctags)
--- | Top level function for data loading
+-- | Top level function for data loading.
loadData :: String -- ^ Unix socket to use as source
-> IO (Result ClusterData)
loadData = fmap parseData . readData
projects / ganeti-local / blobdiff