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, 2012 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   ( loadData
  28   , parseData
  29   ) where
  30
  31 import qualified Control.Exception as E
  32 import Text.JSON.Types
  33 import qualified Text.JSON
  34
  35 import qualified Ganeti.Luxi as L
  36 import qualified Ganeti.Query.Language as Qlang
  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.JSON
  43
  44 {-# ANN module "HLint: ignore Eta reduce" #-}
  45
  46 -- * Utility functions
  47
  48 -- | Get values behind \"data\" part of the result.
  49 getData :: (Monad m) => JSValue -> m JSValue
  50 getData (JSObject o) = fromObj (fromJSObject o) "data"
  51 getData x = fail $ "Invalid input, expected dict entry but got " ++ show x
  52
  53 -- | Converts a (status, value) into m value, if possible.
  54 parseQueryField :: (Monad m) => JSValue -> m (JSValue, JSValue)
  55 parseQueryField (JSArray [status, result]) = return (status, result)
  56 parseQueryField o =
  57   fail $ "Invalid query field, expected (status, value) but got " ++ show o
  58
  59 -- | Parse a result row.
  60 parseQueryRow :: (Monad m) => JSValue -> m [(JSValue, JSValue)]
  61 parseQueryRow (JSArray arr) = mapM parseQueryField arr
  62 parseQueryRow o =
  63   fail $ "Invalid query row result, expected array but got " ++ show o
  64
  65 -- | Parse an overall query result and get the [(status, value)] list
  66 -- for each element queried.
  67 parseQueryResult :: (Monad m) => JSValue -> m [[(JSValue, JSValue)]]
  68 parseQueryResult (JSArray arr) = mapM parseQueryRow arr
  69 parseQueryResult o =
  70   fail $ "Invalid query result, expected array but got " ++ show o
  71
  72 -- | Prepare resulting output as parsers expect it.
  73 extractArray :: (Monad m) => JSValue -> m [[(JSValue, JSValue)]]
  74 extractArray v =
  75   getData v >>= parseQueryResult
  76
  77 -- | Testing result status for more verbose error message.
  78 fromJValWithStatus :: (Text.JSON.JSON a, Monad m) => (JSValue, JSValue) -> m a
  79 fromJValWithStatus (st, v) = do
  80   st' <- fromJVal st
  81   Qlang.checkRS st' v >>= fromJVal
  82
  83 -- | Annotate errors when converting values with owner/attribute for
  84 -- better debugging.
  85 genericConvert :: (Text.JSON.JSON a) =>
  86                   String             -- ^ The object type
  87                -> String             -- ^ The object name
  88                -> String             -- ^ The attribute we're trying to convert
  89                -> (JSValue, JSValue) -- ^ The value we're trying to convert
  90                -> Result a           -- ^ The annotated result
  91 genericConvert otype oname oattr =
  92   annotateResult (otype ++ " '" ++ oname ++
  93                   "', error while reading attribute '" ++
  94                   oattr ++ "'") . fromJValWithStatus
  95
  96 -- * Data querying functionality
  97
  98 -- | The input data for node query.
  99 queryNodesMsg :: L.LuxiOp
 100 queryNodesMsg =
 101   L.Query Qlang.QRNode ["name", "mtotal", "mnode", "mfree", "dtotal", "dfree",
 102                         "ctotal", "offline", "drained", "vm_capable",
 103                         "ndp/spindle_count", "group.uuid"] Qlang.EmptyFilter
 104
 105 -- | The input data for instance query.
 106 queryInstancesMsg :: L.LuxiOp
 107 queryInstancesMsg =
 108   L.Query Qlang.QRInstance ["name", "disk_usage", "be/memory", "be/vcpus",
 109                             "status", "pnode", "snodes", "tags", "oper_ram",
 110                             "be/auto_balance", "disk_template",
 111                             "be/spindle_use"] Qlang.EmptyFilter
 112
 113 -- | The input data for cluster query.
 114 queryClusterInfoMsg :: L.LuxiOp
 115 queryClusterInfoMsg = L.QueryClusterInfo
 116
 117 -- | The input data for node group query.
 118 queryGroupsMsg :: L.LuxiOp
 119 queryGroupsMsg =
 120   L.Query Qlang.QRGroup ["uuid", "name", "alloc_policy", "ipolicy"]
 121    Qlang.EmptyFilter
 122
 123 -- | Wraper over 'callMethod' doing node query.
 124 queryNodes :: L.Client -> IO (Result JSValue)
 125 queryNodes = L.callMethod queryNodesMsg
 126
 127 -- | Wraper over 'callMethod' doing instance query.
 128 queryInstances :: L.Client -> IO (Result JSValue)
 129 queryInstances = L.callMethod queryInstancesMsg
 130
 131 -- | Wrapper over 'callMethod' doing cluster information query.
 132 queryClusterInfo :: L.Client -> IO (Result JSValue)
 133 queryClusterInfo = L.callMethod queryClusterInfoMsg
 134
 135 -- | Wrapper over callMethod doing group query.
 136 queryGroups :: L.Client -> IO (Result JSValue)
 137 queryGroups = L.callMethod queryGroupsMsg
 138
 139 -- | Parse a instance list in JSON format.
 140 getInstances :: NameAssoc
 141              -> JSValue
 142              -> Result [(String, Instance.Instance)]
 143 getInstances ktn arr = extractArray arr >>= mapM (parseInstance ktn)
 144
 145 -- | Construct an instance from a JSON object.
 146 parseInstance :: NameAssoc
 147               -> [(JSValue, JSValue)]
 148               -> Result (String, Instance.Instance)
 149 parseInstance ktn [ name, disk, mem, vcpus
 150                   , status, pnode, snodes, tags, oram
 151                   , auto_balance, disk_template, su ] = do
 152   xname <- annotateResult "Parsing new instance" (fromJValWithStatus name)
 153   let convert a = genericConvert "Instance" xname a
 154   xdisk <- convert "disk_usage" disk
 155   xmem <- case oram of -- FIXME: remove the "guessing"
 156             (_, JSRational _ _) -> convert "oper_ram" oram
 157             _ -> convert "be/memory" mem
 158   xvcpus <- convert "be/vcpus" vcpus
 159   xpnode <- convert "pnode" pnode >>= lookupNode ktn xname
 160   xsnodes <- convert "snodes" snodes::Result [JSString]
 161   snode <- if null xsnodes
 162              then return Node.noSecondary
 163              else lookupNode ktn xname (fromJSString $ head xsnodes)
 164   xrunning <- convert "status" status
 165   xtags <- convert "tags" tags
 166   xauto_balance <- convert "auto_balance" auto_balance
 167   xdt <- convert "disk_template" disk_template
 168   xsu <- convert "be/spindle_use" su
 169   let inst = Instance.create xname xmem xdisk xvcpus
 170              xrunning xtags xauto_balance xpnode snode xdt xsu
 171   return (xname, inst)
 172
 173 parseInstance _ v = fail ("Invalid instance query result: " ++ show v)
 174
 175 -- | Parse a node list in JSON format.
 176 getNodes :: NameAssoc -> JSValue -> Result [(String, Node.Node)]
 177 getNodes ktg arr = extractArray arr >>= mapM (parseNode ktg)
 178
 179 -- | Construct a node from a JSON object.
 180 parseNode :: NameAssoc -> [(JSValue, JSValue)] -> Result (String, Node.Node)
 181 parseNode ktg [ name, mtotal, mnode, mfree, dtotal, dfree
 182               , ctotal, offline, drained, vm_capable, spindles, g_uuid ]
 183     = do
 184   xname <- annotateResult "Parsing new node" (fromJValWithStatus name)
 185   let convert a = genericConvert "Node" xname a
 186   xoffline <- convert "offline" offline
 187   xdrained <- convert "drained" drained
 188   xvm_capable <- convert "vm_capable" vm_capable
 189   xspindles <- convert "spindles" spindles
 190   xgdx   <- convert "group.uuid" g_uuid >>= lookupGroup ktg xname
 191   node <- if xoffline || xdrained || not xvm_capable
 192             then return $ Node.create xname 0 0 0 0 0 0 True xspindles xgdx
 193             else do
 194               xmtotal  <- convert "mtotal" mtotal
 195               xmnode   <- convert "mnode" mnode
 196               xmfree   <- convert "mfree" mfree
 197               xdtotal  <- convert "dtotal" dtotal
 198               xdfree   <- convert "dfree" dfree
 199               xctotal  <- convert "ctotal" ctotal
 200               return $ Node.create xname xmtotal xmnode xmfree
 201                      xdtotal xdfree xctotal False xspindles xgdx
 202   return (xname, node)
 203
 204 parseNode _ v = fail ("Invalid node query result: " ++ show v)
 205
 206 -- | Parses the cluster tags.
 207 getClusterData :: JSValue -> Result ([String], IPolicy)
 208 getClusterData (JSObject obj) = do
 209   let errmsg = "Parsing cluster info"
 210       obj' = fromJSObject obj
 211   ctags <- tryFromObj errmsg obj' "tags"
 212   cpol <- tryFromObj errmsg obj' "ipolicy"
 213   return (ctags, cpol)
 214
 215 getClusterData _ = Bad $ "Cannot parse cluster info, not a JSON record"
 216
 217 -- | Parses the cluster groups.
 218 getGroups :: JSValue -> Result [(String, Group.Group)]
 219 getGroups jsv = extractArray jsv >>= mapM parseGroup
 220
 221 -- | Parses a given group information.
 222 parseGroup :: [(JSValue, JSValue)] -> Result (String, Group.Group)
 223 parseGroup [uuid, name, apol, ipol] = do
 224   xname <- annotateResult "Parsing new group" (fromJValWithStatus name)
 225   let convert a = genericConvert "Group" xname a
 226   xuuid <- convert "uuid" uuid
 227   xapol <- convert "alloc_policy" apol
 228   xipol <- convert "ipolicy" ipol
 229   return (xuuid, Group.create xname xuuid xapol xipol)
 230
 231 parseGroup v = fail ("Invalid group query result: " ++ show v)
 232
 233 -- * Main loader functionality
 234
 235 -- | Builds the cluster data by querying a given socket name.
 236 readData :: String -- ^ Unix socket to use as source
 237          -> IO (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
 238 readData master =
 239   E.bracket
 240        (L.getClient master)
 241        L.closeClient
 242        (\s -> do
 243           nodes <- queryNodes s
 244           instances <- queryInstances s
 245           cinfo <- queryClusterInfo s
 246           groups <- queryGroups s
 247           return (groups, nodes, instances, cinfo)
 248        )
 249
 250 -- | Converts the output of 'readData' into the internal cluster
 251 -- representation.
 252 parseData :: (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
 253           -> Result ClusterData
 254 parseData (groups, nodes, instances, cinfo) = do
 255   group_data <- groups >>= getGroups
 256   let (group_names, group_idx) = assignIndices group_data
 257   node_data <- nodes >>= getNodes group_names
 258   let (node_names, node_idx) = assignIndices node_data
 259   inst_data <- instances >>= getInstances node_names
 260   let (_, inst_idx) = assignIndices inst_data
 261   (ctags, cpol) <- cinfo >>= getClusterData
 262   return (ClusterData group_idx node_idx inst_idx ctags cpol)
 263
 264 -- | Top level function for data loading.
 265 loadData :: String -- ^ Unix socket to use as source
 266          -> IO (Result ClusterData)
 267 loadData = fmap parseData . readData