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