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