{-
-Copyright (C) 2009 Google Inc.
+Copyright (C) 2009, 2010 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
-import Data.List
import qualified Control.Exception as E
-import Control.Monad
import Text.JSON.Types
import qualified Ganeti.Luxi as L
-- * Data querying functionality
-- | The input data for node query.
-queryNodesMsg :: JSValue
+queryNodesMsg :: L.LuxiOp
queryNodesMsg =
- let nnames = JSArray []
- fnames = ["name",
- "mtotal", "mnode", "mfree",
- "dtotal", "dfree",
- "ctotal",
- "offline", "drained"]
- fields = JSArray $ map (JSString . toJSString) fnames
- use_locking = JSBool False
- in JSArray [nnames, fields, use_locking]
+ L.QueryNodes [] ["name", "mtotal", "mnode", "mfree", "dtotal", "dfree",
+ "ctotal", "offline", "drained", "vm_capable",
+ "group.uuid"] False
-- | The input data for instance query.
-queryInstancesMsg :: JSValue
+queryInstancesMsg :: L.LuxiOp
queryInstancesMsg =
- let nnames = JSArray []
- fnames = ["name",
- "disk_usage", "be/memory", "be/vcpus",
- "status", "pnode", "snodes", "tags"]
- fields = JSArray $ map (JSString . toJSString) fnames
- use_locking = JSBool False
- in JSArray [nnames, fields, use_locking]
+ L.QueryInstances [] ["name", "disk_usage", "be/memory", "be/vcpus",
+ "status", "pnode", "snodes", "tags", "oper_ram"] False
-- | The input data for cluster query
-queryClusterInfoMsg :: JSValue
-queryClusterInfoMsg = JSArray []
+queryClusterInfoMsg :: L.LuxiOp
+queryClusterInfoMsg = L.QueryClusterInfo
-- | Wraper over callMethod doing node query.
queryNodes :: L.Client -> IO (Result JSValue)
-queryNodes = L.callMethod L.QueryNodes queryNodesMsg
+queryNodes = L.callMethod queryNodesMsg
-- | Wraper over callMethod doing instance query.
queryInstances :: L.Client -> IO (Result JSValue)
-queryInstances = L.callMethod L.QueryInstances queryInstancesMsg
+queryInstances = L.callMethod queryInstancesMsg
queryClusterInfo :: L.Client -> IO (Result JSValue)
-queryClusterInfo = L.callMethod L.QueryClusterInfo queryClusterInfoMsg
+queryClusterInfo = L.callMethod queryClusterInfoMsg
-- | Parse a instance list in JSON format.
getInstances :: NameAssoc
getInstances ktn arr = toArray arr >>= mapM (parseInstance ktn)
-- | Construct an instance from a JSON object.
-parseInstance :: [(String, Ndx)]
+parseInstance :: NameAssoc
-> JSValue
-> Result (String, Instance.Instance)
parseInstance ktn (JSArray [ name, disk, mem, vcpus
- , status, pnode, snodes, tags ]) = do
+ , status, pnode, snodes, tags, oram ]) = do
xname <- annotateResult "Parsing new instance" (fromJVal name)
let convert v = annotateResult ("Instance '" ++ xname ++ "'") (fromJVal v)
xdisk <- convert disk
- xmem <- convert mem
+ xmem <- (case oram of
+ JSRational _ _ -> convert oram
+ _ -> convert mem)
xvcpus <- convert vcpus
xpnode <- convert pnode >>= lookupNode ktn xname
xsnodes <- convert snodes::Result [JSString]
-- | Construct a node from a JSON object.
parseNode :: JSValue -> Result (String, Node.Node)
parseNode (JSArray [ name, mtotal, mnode, mfree, dtotal, dfree
- , ctotal, offline, drained ])
+ , ctotal, offline, drained, vm_capable, g_uuid ])
= do
xname <- annotateResult "Parsing new node" (fromJVal name)
let convert v = annotateResult ("Node '" ++ xname ++ "'") (fromJVal v)
xoffline <- convert offline
xdrained <- convert drained
- node <- (if xoffline || xdrained
- then return $ Node.create xname 0 0 0 0 0 0 True
+ xvm_capable <- convert vm_capable
+ xguuid <- convert g_uuid
+ node <- (if xoffline || xdrained || not xvm_capable
+ then return $ Node.create xname 0 0 0 0 0 0 True xguuid
else do
xmtotal <- convert mtotal
xmnode <- convert mnode
xdfree <- convert dfree
xctotal <- convert ctotal
return $ Node.create xname xmtotal xmnode xmfree
- xdtotal xdfree xctotal False)
+ xdtotal xdfree xctotal False xguuid)
return (xname, node)
parseNode v = fail ("Invalid node query result: " ++ show v)
getClusterTags v = do
let errmsg = "Parsing cluster info"
obj <- annotateResult errmsg $ asJSObject v
- tags <- tryFromObj errmsg (fromJSObject obj) "tags"
- return tags
+ tryFromObj errmsg (fromJSObject obj) "tags"
-- * Main loader functionality
-- | Builds the cluster data from an URL.
-loadData :: String -- ^ Unix socket to use as source
- -> IO (Result (Node.AssocList, Instance.AssocList, [String]))
-loadData master =
+readData :: String -- ^ Unix socket to use as source
+ -> IO (Result JSValue, Result JSValue, Result JSValue)
+readData master =
E.bracket
(L.getClient master)
L.closeClient
nodes <- queryNodes s
instances <- queryInstances s
cinfo <- queryClusterInfo s
- return $ do -- Result monad
- node_data <- nodes >>= getNodes
- let (node_names, node_idx) = assignIndices node_data
- inst_data <- instances >>= getInstances node_names
- let (_, inst_idx) = assignIndices inst_data
- ctags <- cinfo >>= getClusterTags
- return (node_idx, inst_idx, ctags)
+ return (nodes, instances, cinfo)
)
+
+parseData :: (Result JSValue, Result JSValue, Result JSValue)
+ -> Result (Node.List, Instance.List, [String])
+parseData (nodes, instances, cinfo) = do
+ node_data <- nodes >>= getNodes
+ let (node_names, node_idx) = assignIndices node_data
+ inst_data <- instances >>= getInstances node_names
+ let (_, inst_idx) = assignIndices inst_data
+ ctags <- cinfo >>= getClusterTags
+ return (node_idx, inst_idx, ctags)
+
+-- | Top level function for data loading
+loadData :: String -- ^ Unix socket to use as source
+ -> IO (Result (Node.List, Instance.List, [String]))
+loadData master = readData master >>= return . parseData
projects / ganeti-local / blobdiff