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