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 Ganeti.HTools.Loader
  37 import Ganeti.HTools.Types
  38 import qualified Ganeti.HTools.Group as Group
  39 import qualified Ganeti.HTools.Node as Node
  40 import qualified Ganeti.HTools.Instance as Instance
  41 import Ganeti.HTools.JSON
  42
  43 {-# ANN module "HLint: ignore Eta reduce" #-}
  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                     "ndp/spindle_count", "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                         "be/spindle_use"] ()
 111
 112 -- | The input data for cluster query.
 113 queryClusterInfoMsg :: L.LuxiOp
 114 queryClusterInfoMsg = L.QueryClusterInfo
 115
 116 -- | The input data for node group query.
 117 queryGroupsMsg :: L.LuxiOp
 118 queryGroupsMsg =
 119   L.Query L.QRGroup ["uuid", "name", "alloc_policy", "ipolicy"] ()
 120
 121 -- | Wraper over 'callMethod' doing node query.
 122 queryNodes :: L.Client -> IO (Result JSValue)
 123 queryNodes = L.callMethod queryNodesMsg
 124
 125 -- | Wraper over 'callMethod' doing instance query.
 126 queryInstances :: L.Client -> IO (Result JSValue)
 127 queryInstances = L.callMethod queryInstancesMsg
 128
 129 -- | Wrapper over 'callMethod' doing cluster information query.
 130 queryClusterInfo :: L.Client -> IO (Result JSValue)
 131 queryClusterInfo = L.callMethod queryClusterInfoMsg
 132
 133 -- | Wrapper over callMethod doing group query.
 134 queryGroups :: L.Client -> IO (Result JSValue)
 135 queryGroups = L.callMethod queryGroupsMsg
 136
 137 -- | Parse a instance list in JSON format.
 138 getInstances :: NameAssoc
 139              -> JSValue
 140              -> Result [(String, Instance.Instance)]
 141 getInstances ktn arr = extractArray arr >>= mapM (parseInstance ktn)
 142
 143 -- | Construct an instance from a JSON object.
 144 parseInstance :: NameAssoc
 145               -> [(JSValue, JSValue)]
 146               -> Result (String, Instance.Instance)
 147 parseInstance ktn [ name, disk, mem, vcpus
 148                   , status, pnode, snodes, tags, oram
 149                   , auto_balance, disk_template, su ] = do
 150   xname <- annotateResult "Parsing new instance" (fromJValWithStatus name)
 151   let convert a = genericConvert "Instance" xname a
 152   xdisk <- convert "disk_usage" disk
 153   xmem <- case oram of -- FIXME: remove the "guessing"
 154             (_, JSRational _ _) -> convert "oper_ram" oram
 155             _ -> convert "be/memory" mem
 156   xvcpus <- convert "be/vcpus" vcpus
 157   xpnode <- convert "pnode" pnode >>= lookupNode ktn xname
 158   xsnodes <- convert "snodes" snodes::Result [JSString]
 159   snode <- if null xsnodes
 160              then return Node.noSecondary
 161              else lookupNode ktn xname (fromJSString $ head xsnodes)
 162   xrunning <- convert "status" status
 163   xtags <- convert "tags" tags
 164   xauto_balance <- convert "auto_balance" auto_balance
 165   xdt <- convert "disk_template" disk_template
 166   xsu <- convert "be/spindle_use" su
 167   let inst = Instance.create xname xmem xdisk xvcpus
 168              xrunning xtags xauto_balance xpnode snode xdt xsu
 169   return (xname, inst)
 170
 171 parseInstance _ v = fail ("Invalid instance query result: " ++ show v)
 172
 173 -- | Parse a node list in JSON format.
 174 getNodes :: NameAssoc -> JSValue -> Result [(String, Node.Node)]
 175 getNodes ktg arr = extractArray arr >>= mapM (parseNode ktg)
 176
 177 -- | Construct a node from a JSON object.
 178 parseNode :: NameAssoc -> [(JSValue, JSValue)] -> Result (String, Node.Node)
 179 parseNode ktg [ name, mtotal, mnode, mfree, dtotal, dfree
 180               , ctotal, offline, drained, vm_capable, spindles, g_uuid ]
 181     = do
 182   xname <- annotateResult "Parsing new node" (fromJValWithStatus name)
 183   let convert a = genericConvert "Node" xname a
 184   xoffline <- convert "offline" offline
 185   xdrained <- convert "drained" drained
 186   xvm_capable <- convert "vm_capable" vm_capable
 187   xspindles <- convert "spindles" spindles
 188   xgdx   <- convert "group.uuid" g_uuid >>= lookupGroup ktg xname
 189   node <- if xoffline || xdrained || not xvm_capable
 190             then return $ Node.create xname 0 0 0 0 0 0 True xspindles xgdx
 191             else do
 192               xmtotal  <- convert "mtotal" mtotal
 193               xmnode   <- convert "mnode" mnode
 194               xmfree   <- convert "mfree" mfree
 195               xdtotal  <- convert "dtotal" dtotal
 196               xdfree   <- convert "dfree" dfree
 197               xctotal  <- convert "ctotal" ctotal
 198               return $ Node.create xname xmtotal xmnode xmfree
 199                      xdtotal xdfree xctotal False xspindles xgdx
 200   return (xname, node)
 201
 202 parseNode _ v = fail ("Invalid node query result: " ++ show v)
 203
 204 -- | Parses the cluster tags.
 205 getClusterData :: JSValue -> Result ([String], IPolicy)
 206 getClusterData (JSObject obj) = do
 207   let errmsg = "Parsing cluster info"
 208       obj' = fromJSObject obj
 209   ctags <- tryFromObj errmsg obj' "tags"
 210   cpol <- tryFromObj errmsg obj' "ipolicy"
 211   return (ctags, cpol)
 212
 213 getClusterData _ = Bad $ "Cannot parse cluster info, not a JSON record"
 214
 215 -- | Parses the cluster groups.
 216 getGroups :: JSValue -> Result [(String, Group.Group)]
 217 getGroups jsv = extractArray jsv >>= mapM parseGroup
 218
 219 -- | Parses a given group information.
 220 parseGroup :: [(JSValue, JSValue)] -> Result (String, Group.Group)
 221 parseGroup [uuid, name, apol, ipol] = do
 222   xname <- annotateResult "Parsing new group" (fromJValWithStatus name)
 223   let convert a = genericConvert "Group" xname a
 224   xuuid <- convert "uuid" uuid
 225   xapol <- convert "alloc_policy" apol
 226   xipol <- convert "ipolicy" ipol
 227   return (xuuid, Group.create xname xuuid xapol xipol)
 228
 229 parseGroup v = fail ("Invalid group query result: " ++ show v)
 230
 231 -- * Main loader functionality
 232
 233 -- | Builds the cluster data by querying a given socket name.
 234 readData :: String -- ^ Unix socket to use as source
 235          -> IO (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
 236 readData master =
 237   E.bracket
 238        (L.getClient master)
 239        L.closeClient
 240        (\s -> do
 241           nodes <- queryNodes s
 242           instances <- queryInstances s
 243           cinfo <- queryClusterInfo s
 244           groups <- queryGroups s
 245           return (groups, nodes, instances, cinfo)
 246        )
 247
 248 -- | Converts the output of 'readData' into the internal cluster
 249 -- representation.
 250 parseData :: (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
 251           -> Result ClusterData
 252 parseData (groups, nodes, instances, cinfo) = do
 253   group_data <- groups >>= getGroups
 254   let (group_names, group_idx) = assignIndices group_data
 255   node_data <- nodes >>= getNodes group_names
 256   let (node_names, node_idx) = assignIndices node_data
 257   inst_data <- instances >>= getInstances node_names
 258   let (_, inst_idx) = assignIndices inst_data
 259   (ctags, cpol) <- cinfo >>= getClusterData
 260   return (ClusterData group_idx node_idx inst_idx ctags cpol)
 261
 262 -- | Top level function for data loading.
 263 loadData :: String -- ^ Unix socket to use as source
 264          -> IO (Result ClusterData)
 265 loadData = fmap parseData . readData