module Ganeti.HTools.Luxi
(
loadData
, parseData
) where
import qualified Control.Exception as E
import Text.JSON.Types
import qualified Ganeti.Luxi as L
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)
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)
queryNodesMsg :: L.LuxiOp
queryNodesMsg =
L.QueryNodes [] ["name", "mtotal", "mnode", "mfree", "dtotal", "dfree",
"ctotal", "offline", "drained", "vm_capable",
"group.uuid"] False
queryInstancesMsg :: L.LuxiOp
queryInstancesMsg =
L.QueryInstances [] ["name", "disk_usage", "be/memory", "be/vcpus",
"status", "pnode", "snodes", "tags", "oper_ram"] False
queryClusterInfoMsg :: L.LuxiOp
queryClusterInfoMsg = L.QueryClusterInfo
queryGroupsMsg :: L.LuxiOp
queryGroupsMsg =
L.QueryGroups [] ["uuid", "name", "alloc_policy"] False
queryNodes :: L.Client -> IO (Result JSValue)
queryNodes = L.callMethod queryNodesMsg
queryInstances :: L.Client -> IO (Result JSValue)
queryInstances = L.callMethod queryInstancesMsg
queryClusterInfo :: L.Client -> IO (Result JSValue)
queryClusterInfo = L.callMethod queryClusterInfoMsg
queryGroups :: L.Client -> IO (Result JSValue)
queryGroups = L.callMethod queryGroupsMsg
getInstances :: NameAssoc
-> JSValue
-> Result [(String, Instance.Instance)]
getInstances ktn arr = toArray arr >>= mapM (parseInstance ktn)
parseInstance :: NameAssoc
-> JSValue
-> Result (String, Instance.Instance)
parseInstance ktn (JSArray [ name, disk, mem, vcpus
, 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 <- (case oram of
JSRational _ _ -> convert oram
_ -> convert mem)
xvcpus <- convert vcpus
xpnode <- convert pnode >>= lookupNode ktn xname
xsnodes <- convert snodes::Result [JSString]
snode <- (if null xsnodes then return Node.noSecondary
else lookupNode ktn xname (fromJSString $ head xsnodes))
xrunning <- convert status
xtags <- convert tags
let inst = Instance.create xname xmem xdisk xvcpus
xrunning xtags xpnode snode
return (xname, inst)
parseInstance _ v = fail ("Invalid instance query result: " ++ show v)
getNodes :: NameAssoc -> JSValue -> Result [(String, Node.Node)]
getNodes ktg arr = toArray arr >>= mapM (parseNode ktg)
parseNode :: NameAssoc -> JSValue -> Result (String, Node.Node)
parseNode ktg (JSArray [ name, mtotal, mnode, mfree, dtotal, dfree
, 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
xvm_capable <- convert vm_capable
xgdx <- convert 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
xmnode <- convert mnode
xmfree <- convert mfree
xdtotal <- convert dtotal
xdfree <- convert dfree
xctotal <- convert ctotal
return $ Node.create xname xmtotal xmnode xmfree
xdtotal xdfree xctotal False xgdx)
return (xname, node)
parseNode _ v = fail ("Invalid node query result: " ++ show v)
getClusterTags :: JSValue -> Result [String]
getClusterTags v = do
let errmsg = "Parsing cluster info"
obj <- annotateResult errmsg $ asJSObject v
tryFromObj errmsg (fromJSObject obj) "tags"
getGroups :: JSValue -> Result [(String, Group.Group)]
getGroups arr = toArray arr >>= mapM parseGroup
parseGroup :: JSValue -> Result (String, Group.Group)
parseGroup (JSArray [ uuid, name, apol ]) = do
xname <- annotateResult "Parsing new group" (fromJVal name)
let convert v = annotateResult ("Node '" ++ xname ++ "'") (fromJVal v)
xuuid <- convert uuid
xapol <- convert apol
return $ (xuuid, Group.create xname xuuid xapol)
parseGroup v = fail ("Invalid group query result: " ++ show v)
readData :: String
-> IO (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
readData master =
E.bracket
(L.getClient master)
L.closeClient
(\s -> do
nodes <- queryNodes s
instances <- queryInstances s
cinfo <- queryClusterInfo s
groups <- queryGroups s
return (groups, nodes, instances, cinfo)
)
parseData :: (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
-> Result ClusterData
parseData (groups, nodes, instances, cinfo) = do
group_data <- groups >>= getGroups
let (group_names, group_idx) = assignIndices group_data
node_data <- nodes >>= getNodes group_names
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)
loadData :: String
-> IO (Result ClusterData)
loadData master = readData master >>= return . parseData