code.grnet.gr Git - ganeti-local/blob - htools/Ganeti/HTools/Luxi.hs

   1 {-| Implementation of the LUXI loader.
   2
   3 -}
   4
   5 {-
   6
   7 Copyright (C) 2009, 2010, 2011 Google Inc.
   8
   9 This program is free software; you can redistribute it and/or modify
  10 it under the terms of the GNU General Public License as published by
  11 the Free Software Foundation; either version 2 of the License, or
  12 (at your option) any later version.
  13
  14 This program is distributed in the hope that it will be useful, but
  15 WITHOUT ANY WARRANTY; without even the implied warranty of
  16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 General Public License for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with this program; if not, write to the Free Software
  21 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  22 02110-1301, USA.
  23
  24 -}
  25
  26 module Ganeti.HTools.Luxi
  27     (
  28       loadData
  29     , parseData
  30     ) where
  31
  32 import qualified Control.Exception as E
  33 import Text.JSON.Types
  34 import qualified Text.JSON
  35
  36 import qualified Ganeti.Luxi as L
  37 import Ganeti.HTools.Loader
  38 import Ganeti.HTools.Types
  39 import qualified Ganeti.HTools.Group as Group
  40 import qualified Ganeti.HTools.Node as Node
  41 import qualified Ganeti.HTools.Instance as Instance
  42 import Ganeti.HTools.Utils (fromJVal, annotateResult, tryFromObj, asJSObject,
  43                             fromObj)
  44
  45 -- * Utility functions
  46
  47 -- | Get values behind \"data\" part of the result.
  48 getData :: (Monad m) => JSValue -> m JSValue
  49 getData (JSObject o) = fromObj (fromJSObject o) "data"
  50 getData x = fail $ "Invalid input, expected dict entry but got " ++ show x
  51
  52 -- | Converts a (status, value) into m value, if possible.
  53 parseQueryField :: (Monad m) => JSValue -> m (JSValue, JSValue)
  54 parseQueryField (JSArray [status, result]) = return (status, result)
  55 parseQueryField o =
  56     fail $ "Invalid query field, expected (status, value) but got " ++ show o
  57
  58 -- | Parse a result row.
  59 parseQueryRow :: (Monad m) => JSValue -> m [(JSValue, JSValue)]
  60 parseQueryRow (JSArray arr) = mapM parseQueryField arr
  61 parseQueryRow o =
  62     fail $ "Invalid query row result, expected array but got " ++ show o
  63
  64 -- | Parse an overall query result and get the [(status, value)] list
  65 -- for each element queried.
  66 parseQueryResult :: (Monad m) => JSValue -> m [[(JSValue, JSValue)]]
  67 parseQueryResult (JSArray arr) = mapM parseQueryRow arr
  68 parseQueryResult o =
  69     fail $ "Invalid query result, expected array but got " ++ show o
  70
  71 -- | Prepare resulting output as parsers expect it.
  72 extractArray :: (Monad m) => JSValue -> m [[(JSValue, JSValue)]]
  73 extractArray v =
  74   getData v >>= parseQueryResult
  75
  76 -- | Testing result status for more verbose error message.
  77 fromJValWithStatus :: (Text.JSON.JSON a, Monad m) => (JSValue, JSValue) -> m a
  78 fromJValWithStatus (st, v) = do
  79     st' <- fromJVal st
  80     L.checkRS st' v >>= fromJVal
  81
  82 -- | Annotate errors when converting values with owner/attribute for
  83 -- better debugging.
  84 genericConvert :: (Text.JSON.JSON a) =>
  85                   String             -- ^ The object type
  86                -> String             -- ^ The object name
  87                -> String             -- ^ The attribute we're trying to convert
  88                -> (JSValue, JSValue) -- ^ The value we're trying to convert
  89                -> Result a           -- ^ The annotated result
  90 genericConvert otype oname oattr =
  91     annotateResult (otype ++ " '" ++ oname ++
  92                     "', error while reading attribute '" ++
  93                     oattr ++ "'") . fromJValWithStatus
  94
  95 -- * Data querying functionality
  96
  97 -- | The input data for node query.
  98 queryNodesMsg :: L.LuxiOp
  99 queryNodesMsg =
 100   L.Query L.QRNode ["name", "mtotal", "mnode", "mfree", "dtotal", "dfree",
 101                     "ctotal", "offline", "drained", "vm_capable",
 102                     "group.uuid"] ()
 103
 104 -- | The input data for instance query.
 105 queryInstancesMsg :: L.LuxiOp
 106 queryInstancesMsg =
 107     L.Query L.QRInstance ["name", "disk_usage", "be/memory", "be/vcpus",
 108                           "status", "pnode", "snodes", "tags", "oper_ram",
 109                           "be/auto_balance", "disk_template"] ()
 110
 111 -- | The input data for cluster query.
 112 queryClusterInfoMsg :: L.LuxiOp
 113 queryClusterInfoMsg = L.QueryClusterInfo
 114
 115 -- | The input data for node group query.
 116 queryGroupsMsg :: L.LuxiOp
 117 queryGroupsMsg =
 118   L.Query L.QRGroup ["uuid", "name", "alloc_policy"] ()
 119
 120 -- | Wraper over 'callMethod' doing node query.
 121 queryNodes :: L.Client -> IO (Result JSValue)
 122 queryNodes = L.callMethod queryNodesMsg
 123
 124 -- | Wraper over 'callMethod' doing instance query.
 125 queryInstances :: L.Client -> IO (Result JSValue)
 126 queryInstances = L.callMethod queryInstancesMsg
 127
 128 -- | Wrapper over 'callMethod' doing cluster information query.
 129 queryClusterInfo :: L.Client -> IO (Result JSValue)
 130 queryClusterInfo = L.callMethod queryClusterInfoMsg
 131
 132 -- | Wrapper over callMethod doing group query.
 133 queryGroups :: L.Client -> IO (Result JSValue)
 134 queryGroups = L.callMethod queryGroupsMsg
 135
 136 -- | Parse a instance list in JSON format.
 137 getInstances :: NameAssoc
 138              -> JSValue
 139              -> Result [(String, Instance.Instance)]
 140 getInstances ktn arr = extractArray arr >>= mapM (parseInstance ktn)
 141
 142 -- | Construct an instance from a JSON object.
 143 parseInstance :: NameAssoc
 144               -> [(JSValue, JSValue)]
 145               -> Result (String, Instance.Instance)
 146 parseInstance ktn [ name, disk, mem, vcpus
 147                   , status, pnode, snodes, tags, oram
 148                   , auto_balance, disk_template ] = do
 149   xname <- annotateResult "Parsing new instance" (fromJValWithStatus name)
 150   let convert a = genericConvert "Instance" xname a
 151   xdisk <- convert "disk_usage" disk
 152   xmem <- (case oram of -- FIXME: remove the "guessing"
 153              (_, JSRational _ _) -> convert "oper_ram" oram
 154              _ -> convert "be/memory" mem)
 155   xvcpus <- convert "be/vcpus" vcpus
 156   xpnode <- convert "pnode" pnode >>= lookupNode ktn xname
 157   xsnodes <- convert "snodes" snodes::Result [JSString]
 158   snode <- (if null xsnodes then return Node.noSecondary
 159             else lookupNode ktn xname (fromJSString $ head xsnodes))
 160   xrunning <- convert "status" status
 161   xtags <- convert "tags" tags
 162   xauto_balance <- convert "auto_balance" auto_balance
 163   xdt <- convert "disk_template" disk_template
 164   let inst = Instance.create xname xmem xdisk xvcpus
 165              xrunning xtags xauto_balance xpnode snode xdt
 166   return (xname, inst)
 167
 168 parseInstance _ v = fail ("Invalid instance query result: " ++ show v)
 169
 170 -- | Parse a node list in JSON format.
 171 getNodes :: NameAssoc -> JSValue -> Result [(String, Node.Node)]
 172 getNodes ktg arr = extractArray arr >>= mapM (parseNode ktg)
 173
 174 -- | Construct a node from a JSON object.
 175 parseNode :: NameAssoc -> [(JSValue, JSValue)] -> Result (String, Node.Node)
 176 parseNode ktg [ name, mtotal, mnode, mfree, dtotal, dfree
 177               , ctotal, offline, drained, vm_capable, g_uuid ]
 178     = do
 179   xname <- annotateResult "Parsing new node" (fromJValWithStatus name)
 180   let convert a = genericConvert "Node" xname a
 181   xoffline <- convert "offline" offline
 182   xdrained <- convert "drained" drained
 183   xvm_capable <- convert "vm_capable" vm_capable
 184   xgdx   <- convert "group.uuid" g_uuid >>= lookupGroup ktg xname
 185   node <- (if xoffline || xdrained || not xvm_capable
 186            then return $ Node.create xname 0 0 0 0 0 0 True xgdx
 187            else do
 188              xmtotal  <- convert "mtotal" mtotal
 189              xmnode   <- convert "mnode" mnode
 190              xmfree   <- convert "mfree" mfree
 191              xdtotal  <- convert "dtotal" dtotal
 192              xdfree   <- convert "dfree" dfree
 193              xctotal  <- convert "ctotal" ctotal
 194              return $ Node.create xname xmtotal xmnode xmfree
 195                     xdtotal xdfree xctotal False xgdx)
 196   return (xname, node)
 197
 198 parseNode _ v = fail ("Invalid node query result: " ++ show v)
 199
 200 -- | Parses the cluster tags.
 201 getClusterTags :: JSValue -> Result [String]
 202 getClusterTags v = do
 203   let errmsg = "Parsing cluster info"
 204   obj <- annotateResult errmsg $ asJSObject v
 205   tryFromObj errmsg (fromJSObject obj) "tags"
 206
 207 -- | Parses the cluster groups.
 208 getGroups :: JSValue -> Result [(String, Group.Group)]
 209 getGroups jsv = extractArray jsv >>= mapM parseGroup
 210
 211 -- | Parses a given group information.
 212 parseGroup :: [(JSValue, JSValue)] -> Result (String, Group.Group)
 213 parseGroup [uuid, name, apol] = do
 214   xname <- annotateResult "Parsing new group" (fromJValWithStatus name)
 215   let convert a = genericConvert "Group" xname a
 216   xuuid <- convert "uuid" uuid
 217   xapol <- convert "alloc_policy" apol
 218   return (xuuid, Group.create xname xuuid xapol)
 219
 220 parseGroup v = fail ("Invalid group query result: " ++ show v)
 221
 222 -- * Main loader functionality
 223
 224 -- | Builds the cluster data by querying a given socket name.
 225 readData :: String -- ^ Unix socket to use as source
 226          -> IO (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
 227 readData master =
 228   E.bracket
 229        (L.getClient master)
 230        L.closeClient
 231        (\s -> do
 232           nodes <- queryNodes s
 233           instances <- queryInstances s
 234           cinfo <- queryClusterInfo s
 235           groups <- queryGroups s
 236           return (groups, nodes, instances, cinfo)
 237        )
 238
 239 -- | Converts the output of 'readData' into the internal cluster
 240 -- representation.
 241 parseData :: (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
 242           -> Result ClusterData
 243 parseData (groups, nodes, instances, cinfo) = do
 244   group_data <- groups >>= getGroups
 245   let (group_names, group_idx) = assignIndices group_data
 246   node_data <- nodes >>= getNodes group_names
 247   let (node_names, node_idx) = assignIndices node_data
 248   inst_data <- instances >>= getInstances node_names
 249   let (_, inst_idx) = assignIndices inst_data
 250   ctags <- cinfo >>= getClusterTags
 251   return (ClusterData group_idx node_idx inst_idx ctags)
 252
 253 -- | Top level function for data loading.
 254 loadData :: String -- ^ Unix socket to use as source
 255          -> IO (Result ClusterData)
 256 loadData = fmap parseData . readData