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   ( 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                     "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", "ipolicy"] ()
 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
 159              then return Node.noSecondary
 160              else lookupNode ktn xname (fromJSString $ head xsnodes)
 161   xrunning <- convert "status" status
 162   xtags <- convert "tags" tags
 163   xauto_balance <- convert "auto_balance" auto_balance
 164   xdt <- convert "disk_template" disk_template
 165   let inst = Instance.create xname xmem xdisk xvcpus
 166              xrunning xtags xauto_balance xpnode snode xdt
 167   return (xname, inst)
 168
 169 parseInstance _ v = fail ("Invalid instance query result: " ++ show v)
 170
 171 -- | Parse a node list in JSON format.
 172 getNodes :: NameAssoc -> JSValue -> Result [(String, Node.Node)]
 173 getNodes ktg arr = extractArray arr >>= mapM (parseNode ktg)
 174
 175 -- | Construct a node from a JSON object.
 176 parseNode :: NameAssoc -> [(JSValue, JSValue)] -> Result (String, Node.Node)
 177 parseNode ktg [ name, mtotal, mnode, mfree, dtotal, dfree
 178               , ctotal, offline, drained, vm_capable, g_uuid ]
 179     = do
 180   xname <- annotateResult "Parsing new node" (fromJValWithStatus name)
 181   let convert a = genericConvert "Node" xname a
 182   xoffline <- convert "offline" offline
 183   xdrained <- convert "drained" drained
 184   xvm_capable <- convert "vm_capable" vm_capable
 185   xgdx   <- convert "group.uuid" g_uuid >>= lookupGroup ktg xname
 186   node <- if xoffline || xdrained || not xvm_capable
 187             then return $ Node.create xname 0 0 0 0 0 0 True xgdx
 188             else do
 189               xmtotal  <- convert "mtotal" mtotal
 190               xmnode   <- convert "mnode" mnode
 191               xmfree   <- convert "mfree" mfree
 192               xdtotal  <- convert "dtotal" dtotal
 193               xdfree   <- convert "dfree" dfree
 194               xctotal  <- convert "ctotal" ctotal
 195               return $ Node.create xname xmtotal xmnode xmfree
 196                      xdtotal xdfree xctotal False xgdx
 197   return (xname, node)
 198
 199 parseNode _ v = fail ("Invalid node query result: " ++ show v)
 200
 201 -- | Parses the cluster tags.
 202 getClusterData :: JSValue -> Result ([String], IPolicy)
 203 getClusterData (JSObject obj) = do
 204   let errmsg = "Parsing cluster info"
 205       obj' = fromJSObject obj
 206   ctags <- tryFromObj errmsg obj' "tags"
 207   cpol <- tryFromObj errmsg obj' "ipolicy"
 208   return (ctags, cpol)
 209
 210 getClusterData _ = Bad $ "Cannot parse cluster info, not a JSON record"
 211
 212 -- | Parses the cluster groups.
 213 getGroups :: JSValue -> Result [(String, Group.Group)]
 214 getGroups jsv = extractArray jsv >>= mapM parseGroup
 215
 216 -- | Parses a given group information.
 217 parseGroup :: [(JSValue, JSValue)] -> Result (String, Group.Group)
 218 parseGroup [uuid, name, apol, ipol] = do
 219   xname <- annotateResult "Parsing new group" (fromJValWithStatus name)
 220   let convert a = genericConvert "Group" xname a
 221   xuuid <- convert "uuid" uuid
 222   xapol <- convert "alloc_policy" apol
 223   xipol <- convert "ipolicy" ipol
 224   return (xuuid, Group.create xname xuuid xapol xipol)
 225
 226 parseGroup v = fail ("Invalid group query result: " ++ show v)
 227
 228 -- * Main loader functionality
 229
 230 -- | Builds the cluster data by querying a given socket name.
 231 readData :: String -- ^ Unix socket to use as source
 232          -> IO (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
 233 readData master =
 234   E.bracket
 235        (L.getClient master)
 236        L.closeClient
 237        (\s -> do
 238           nodes <- queryNodes s
 239           instances <- queryInstances s
 240           cinfo <- queryClusterInfo s
 241           groups <- queryGroups s
 242           return (groups, nodes, instances, cinfo)
 243        )
 244
 245 -- | Converts the output of 'readData' into the internal cluster
 246 -- representation.
 247 parseData :: (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
 248           -> Result ClusterData
 249 parseData (groups, nodes, instances, cinfo) = do
 250   group_data <- groups >>= getGroups
 251   let (group_names, group_idx) = assignIndices group_data
 252   node_data <- nodes >>= getNodes group_names
 253   let (node_names, node_idx) = assignIndices node_data
 254   inst_data <- instances >>= getInstances node_names
 255   let (_, inst_idx) = assignIndices inst_data
 256   (ctags, cpol) <- cinfo >>= getClusterData
 257   return (ClusterData group_idx node_idx inst_idx ctags cpol)
 258
 259 -- | Top level function for data loading.
 260 loadData :: String -- ^ Unix socket to use as source
 261          -> IO (Result ClusterData)
 262 loadData = fmap parseData . readData