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]
  73 extractArray v =
  74   getData v >>= parseQueryResult >>= (return . map (JSArray . map snd))
  75
  76 -- | Annotate errors when converting values with owner/attribute for
  77 -- better debugging.
  78 genericConvert :: (Text.JSON.JSON a) =>
  79                   String     -- ^ The object type
  80                -> String     -- ^ The object name
  81                -> String     -- ^ The attribute we're trying to convert
  82                -> JSValue    -- ^ The value we try to convert
  83                -> Result a   -- ^ The annotated result
  84 genericConvert otype oname oattr =
  85     annotateResult (otype ++ " '" ++ oname ++
  86                     "', error while reading attribute '" ++
  87                     oattr ++ "'") . fromJVal
  88
  89 -- * Data querying functionality
  90
  91 -- | The input data for node query.
  92 queryNodesMsg :: L.LuxiOp
  93 queryNodesMsg =
  94   L.Query L.QRNode ["name", "mtotal", "mnode", "mfree", "dtotal", "dfree",
  95                     "ctotal", "offline", "drained", "vm_capable",
  96                     "group.uuid"] ()
  97
  98 -- | The input data for instance query.
  99 queryInstancesMsg :: L.LuxiOp
 100 queryInstancesMsg =
 101     L.Query L.QRInstance ["name", "disk_usage", "be/memory", "be/vcpus",
 102                           "status", "pnode", "snodes", "tags", "oper_ram",
 103                           "be/auto_balance", "disk_template"] ()
 104
 105 -- | The input data for cluster query.
 106 queryClusterInfoMsg :: L.LuxiOp
 107 queryClusterInfoMsg = L.QueryClusterInfo
 108
 109 -- | The input data for node group query.
 110 queryGroupsMsg :: L.LuxiOp
 111 queryGroupsMsg =
 112   L.Query L.QRGroup ["uuid", "name", "alloc_policy"] ()
 113
 114 -- | Wraper over 'callMethod' doing node query.
 115 queryNodes :: L.Client -> IO (Result JSValue)
 116 queryNodes = L.callMethod queryNodesMsg
 117
 118 -- | Wraper over 'callMethod' doing instance query.
 119 queryInstances :: L.Client -> IO (Result JSValue)
 120 queryInstances = L.callMethod queryInstancesMsg
 121
 122 -- | Wrapper over 'callMethod' doing cluster information query.
 123 queryClusterInfo :: L.Client -> IO (Result JSValue)
 124 queryClusterInfo = L.callMethod queryClusterInfoMsg
 125
 126 -- | Wrapper over callMethod doing group query.
 127 queryGroups :: L.Client -> IO (Result JSValue)
 128 queryGroups = L.callMethod queryGroupsMsg
 129
 130 -- | Parse a instance list in JSON format.
 131 getInstances :: NameAssoc
 132              -> JSValue
 133              -> Result [(String, Instance.Instance)]
 134 getInstances ktn arr = extractArray arr >>= mapM (parseInstance ktn)
 135
 136 -- | Construct an instance from a JSON object.
 137 parseInstance :: NameAssoc
 138               -> JSValue
 139               -> Result (String, Instance.Instance)
 140 parseInstance ktn (JSArray [ name, disk, mem, vcpus
 141                            , status, pnode, snodes, tags, oram
 142                            , auto_balance, disk_template ]) = do
 143   xname <- annotateResult "Parsing new instance" (fromJVal name)
 144   let convert a = genericConvert "Instance" xname a
 145   xdisk <- convert "disk_usage" disk
 146   xmem <- (case oram of
 147              JSRational _ _ -> convert "oper_ram" oram
 148              _ -> convert "be/memory" mem)
 149   xvcpus <- convert "be/vcpus" vcpus
 150   xpnode <- convert "pnode" pnode >>= lookupNode ktn xname
 151   xsnodes <- convert "snodes" snodes::Result [JSString]
 152   snode <- (if null xsnodes then return Node.noSecondary
 153             else lookupNode ktn xname (fromJSString $ head xsnodes))
 154   xrunning <- convert "status" status
 155   xtags <- convert "tags" tags
 156   xauto_balance <- convert "auto_balance" auto_balance
 157   xdt <- convert "disk_template" disk_template
 158   let inst = Instance.create xname xmem xdisk xvcpus
 159              xrunning xtags xauto_balance xpnode snode xdt
 160   return (xname, inst)
 161
 162 parseInstance _ v = fail ("Invalid instance query result: " ++ show v)
 163
 164 -- | Parse a node list in JSON format.
 165 getNodes :: NameAssoc -> JSValue -> Result [(String, Node.Node)]
 166 getNodes ktg arr = extractArray arr >>= mapM (parseNode ktg)
 167
 168 -- | Construct a node from a JSON object.
 169 parseNode :: NameAssoc -> JSValue -> Result (String, Node.Node)
 170 parseNode ktg (JSArray [ name, mtotal, mnode, mfree, dtotal, dfree
 171                        , ctotal, offline, drained, vm_capable, g_uuid ])
 172     = do
 173   xname <- annotateResult "Parsing new node" (fromJVal name)
 174   let convert a = genericConvert "Node" xname a
 175   xoffline <- convert "offline" offline
 176   xdrained <- convert "drained" drained
 177   xvm_capable <- convert "vm_capable" vm_capable
 178   xgdx   <- convert "group.uuid" g_uuid >>= lookupGroup ktg xname
 179   node <- (if xoffline || xdrained || not xvm_capable
 180            then return $ Node.create xname 0 0 0 0 0 0 True xgdx
 181            else do
 182              xmtotal  <- convert "mtotal" mtotal
 183              xmnode   <- convert "mnode" mnode
 184              xmfree   <- convert "mfree" mfree
 185              xdtotal  <- convert "dtotal" dtotal
 186              xdfree   <- convert "dfree" dfree
 187              xctotal  <- convert "ctotal" ctotal
 188              return $ Node.create xname xmtotal xmnode xmfree
 189                     xdtotal xdfree xctotal False xgdx)
 190   return (xname, node)
 191
 192 parseNode _ v = fail ("Invalid node query result: " ++ show v)
 193
 194 -- | Parses the cluster tags.
 195 getClusterTags :: JSValue -> Result [String]
 196 getClusterTags v = do
 197   let errmsg = "Parsing cluster info"
 198   obj <- annotateResult errmsg $ asJSObject v
 199   tryFromObj errmsg (fromJSObject obj) "tags"
 200
 201 -- | Parses the cluster groups.
 202 getGroups :: JSValue -> Result [(String, Group.Group)]
 203 getGroups jsv = extractArray jsv >>= mapM parseGroup
 204
 205 -- | Parses a given group information.
 206 parseGroup :: JSValue -> Result (String, Group.Group)
 207 parseGroup (JSArray [uuid, name, apol]) = do
 208   xname <- annotateResult "Parsing new group" (fromJVal name)
 209   let convert a = genericConvert "Group" xname a
 210   xuuid <- convert "uuid" uuid
 211   xapol <- convert "alloc_policy" apol
 212   return (xuuid, Group.create xname xuuid xapol)
 213
 214 parseGroup v = fail ("Invalid group query result: " ++ show v)
 215
 216 -- * Main loader functionality
 217
 218 -- | Builds the cluster data by querying a given socket name.
 219 readData :: String -- ^ Unix socket to use as source
 220          -> IO (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
 221 readData master =
 222   E.bracket
 223        (L.getClient master)
 224        L.closeClient
 225        (\s -> do
 226           nodes <- queryNodes s
 227           instances <- queryInstances s
 228           cinfo <- queryClusterInfo s
 229           groups <- queryGroups s
 230           return (groups, nodes, instances, cinfo)
 231        )
 232
 233 -- | Converts the output of 'readData' into the internal cluster
 234 -- representation.
 235 parseData :: (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
 236           -> Result ClusterData
 237 parseData (groups, nodes, instances, cinfo) = do
 238   group_data <- groups >>= getGroups
 239   let (group_names, group_idx) = assignIndices group_data
 240   node_data <- nodes >>= getNodes group_names
 241   let (node_names, node_idx) = assignIndices node_data
 242   inst_data <- instances >>= getInstances node_names
 243   let (_, inst_idx) = assignIndices inst_data
 244   ctags <- cinfo >>= getClusterTags
 245   return (ClusterData group_idx node_idx inst_idx ctags)
 246
 247 -- | Top level function for data loading.
 248 loadData :: String -- ^ Unix socket to use as source
 249          -> IO (Result ClusterData)
 250 loadData = fmap parseData . readData