code.grnet.gr Git - ganeti-local/blob - Ganeti/HTools/Luxi.hs

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