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"] 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 queryClusterInfo :: L.Client -> IO (Result JSValue)
 100 queryClusterInfo = L.callMethod queryClusterInfoMsg
 101
 102 -- | Wrapper over callMethod doing group query.
 103 queryGroups :: L.Client -> IO (Result JSValue)
 104 queryGroups = L.callMethod queryGroupsMsg
 105
 106 -- | Parse a instance list in JSON format.
 107 getInstances :: NameAssoc
 108              -> JSValue
 109              -> Result [(String, Instance.Instance)]
 110 getInstances ktn arr = toArray arr >>= mapM (parseInstance ktn)
 111
 112 -- | Construct an instance from a JSON object.
 113 parseInstance :: NameAssoc
 114               -> JSValue
 115               -> Result (String, Instance.Instance)
 116 parseInstance ktn (JSArray [ name, disk, mem, vcpus
 117                            , status, pnode, snodes, tags, oram
 118                            , auto_balance ]) = do
 119   xname <- annotateResult "Parsing new instance" (fromJVal name)
 120   let convert a = genericConvert "Instance" xname a
 121   xdisk <- convert "disk_usage" disk
 122   xmem <- (case oram of
 123              JSRational _ _ -> convert "oper_ram" oram
 124              _ -> convert "be/memory" mem)
 125   xvcpus <- convert "be/vcpus" vcpus
 126   xpnode <- convert "pnode" pnode >>= lookupNode ktn xname
 127   xsnodes <- convert "snodes" snodes::Result [JSString]
 128   snode <- (if null xsnodes then return Node.noSecondary
 129             else lookupNode ktn xname (fromJSString $ head xsnodes))
 130   xrunning <- convert "status" status
 131   xtags <- convert "tags" tags
 132   xauto_balance <- convert "auto_balance" auto_balance
 133   let inst = Instance.create xname xmem xdisk xvcpus
 134              xrunning xtags xauto_balance xpnode snode DTDrbd8
 135   return (xname, inst)
 136
 137 parseInstance _ v = fail ("Invalid instance query result: " ++ show v)
 138
 139 -- | Parse a node list in JSON format.
 140 getNodes :: NameAssoc -> JSValue -> Result [(String, Node.Node)]
 141 getNodes ktg arr = toArray arr >>= mapM (parseNode ktg)
 142
 143 -- | Construct a node from a JSON object.
 144 parseNode :: NameAssoc -> JSValue -> Result (String, Node.Node)
 145 parseNode ktg (JSArray [ name, mtotal, mnode, mfree, dtotal, dfree
 146                        , ctotal, offline, drained, vm_capable, g_uuid ])
 147     = do
 148   xname <- annotateResult "Parsing new node" (fromJVal name)
 149   let convert a = genericConvert "Node" xname a
 150   xoffline <- convert "offline" offline
 151   xdrained <- convert "drained" drained
 152   xvm_capable <- convert "vm_capable" vm_capable
 153   xgdx   <- convert "group.uuid" g_uuid >>= lookupGroup ktg xname
 154   node <- (if xoffline || xdrained || not xvm_capable
 155            then return $ Node.create xname 0 0 0 0 0 0 True xgdx
 156            else do
 157              xmtotal  <- convert "mtotal" mtotal
 158              xmnode   <- convert "mnode" mnode
 159              xmfree   <- convert "mfree" mfree
 160              xdtotal  <- convert "dtotal" dtotal
 161              xdfree   <- convert "dfree" dfree
 162              xctotal  <- convert "ctotal" ctotal
 163              return $ Node.create xname xmtotal xmnode xmfree
 164                     xdtotal xdfree xctotal False xgdx)
 165   return (xname, node)
 166
 167 parseNode _ v = fail ("Invalid node query result: " ++ show v)
 168
 169 getClusterTags :: JSValue -> Result [String]
 170 getClusterTags v = do
 171   let errmsg = "Parsing cluster info"
 172   obj <- annotateResult errmsg $ asJSObject v
 173   tryFromObj errmsg (fromJSObject obj) "tags"
 174
 175 getGroups :: JSValue -> Result [(String, Group.Group)]
 176 getGroups arr = toArray arr >>= mapM parseGroup
 177
 178 parseGroup :: JSValue -> Result (String, Group.Group)
 179 parseGroup (JSArray [ uuid, name, apol ]) = do
 180   xname <- annotateResult "Parsing new group" (fromJVal name)
 181   let convert a = genericConvert "Group" xname a
 182   xuuid <- convert "uuid" uuid
 183   xapol <- convert "alloc_policy" apol
 184   return (xuuid, Group.create xname xuuid xapol)
 185
 186 parseGroup v = fail ("Invalid group query result: " ++ show v)
 187
 188 -- * Main loader functionality
 189
 190 -- | Builds the cluster data by querying a given socket name.
 191 readData :: String -- ^ Unix socket to use as source
 192          -> IO (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
 193 readData master =
 194   E.bracket
 195        (L.getClient master)
 196        L.closeClient
 197        (\s -> do
 198           nodes <- queryNodes s
 199           instances <- queryInstances s
 200           cinfo <- queryClusterInfo s
 201           groups <- queryGroups s
 202           return (groups, nodes, instances, cinfo)
 203        )
 204
 205 -- | Converts the output of 'readData' into the internal cluster
 206 -- representation.
 207 parseData :: (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
 208           -> Result ClusterData
 209 parseData (groups, nodes, instances, cinfo) = do
 210   group_data <- groups >>= getGroups
 211   let (group_names, group_idx) = assignIndices group_data
 212   node_data <- nodes >>= getNodes group_names
 213   let (node_names, node_idx) = assignIndices node_data
 214   inst_data <- instances >>= getInstances node_names
 215   let (_, inst_idx) = assignIndices inst_data
 216   ctags <- cinfo >>= getClusterTags
 217   return (ClusterData group_idx node_idx inst_idx ctags)
 218
 219 -- | Top level function for data loading.
 220 loadData :: String -- ^ Unix socket to use as source
 221          -> IO (Result ClusterData)
 222 loadData = fmap parseData . readData