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 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     ) where
  30
  31 import Data.List
  32 import qualified Control.Exception as E
  33 import Control.Monad
  34 import Text.JSON.Types
  35
  36 import qualified Ganeti.Luxi as L
  37 import Ganeti.HTools.Loader
  38 import Ganeti.HTools.Types
  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 :: JSValue
  56 queryNodesMsg =
  57     let nnames = JSArray []
  58         fnames = ["name",
  59                   "mtotal", "mnode", "mfree",
  60                   "dtotal", "dfree",
  61                   "ctotal",
  62                   "offline", "drained"]
  63         fields = JSArray $ map (JSString . toJSString) fnames
  64         use_locking = JSBool False
  65     in JSArray [nnames, fields, use_locking]
  66
  67 -- | The input data for instance query.
  68 queryInstancesMsg :: JSValue
  69 queryInstancesMsg =
  70     let nnames = JSArray []
  71         fnames = ["name",
  72                   "disk_usage", "be/memory", "be/vcpus",
  73                   "status", "pnode", "snodes", "tags"]
  74         fields = JSArray $ map (JSString . toJSString) fnames
  75         use_locking = JSBool False
  76     in JSArray [nnames, fields, use_locking]
  77
  78 -- | The input data for cluster query
  79 queryClusterInfoMsg :: JSValue
  80 queryClusterInfoMsg = JSArray []
  81
  82 -- | Wraper over callMethod doing node query.
  83 queryNodes :: L.Client -> IO (Result JSValue)
  84 queryNodes = L.callMethod L.QueryNodes queryNodesMsg
  85
  86 -- | Wraper over callMethod doing instance query.
  87 queryInstances :: L.Client -> IO (Result JSValue)
  88 queryInstances = L.callMethod L.QueryInstances queryInstancesMsg
  89
  90 queryClusterInfo :: L.Client -> IO (Result JSValue)
  91 queryClusterInfo = L.callMethod L.QueryClusterInfo queryClusterInfoMsg
  92
  93 -- | Parse a instance list in JSON format.
  94 getInstances :: NameAssoc
  95              -> JSValue
  96              -> Result [(String, Instance.Instance)]
  97 getInstances ktn arr = toArray arr >>= mapM (parseInstance ktn)
  98
  99 -- | Construct an instance from a JSON object.
 100 parseInstance :: [(String, Ndx)]
 101               -> JSValue
 102               -> Result (String, Instance.Instance)
 103 parseInstance ktn (JSArray [ name, disk, mem, vcpus
 104                            , status, pnode, snodes, tags ]) = do
 105   xname <- annotateResult "Parsing new instance" (fromJVal name)
 106   let convert v = annotateResult ("Instance '" ++ xname ++ "'") (fromJVal v)
 107   xdisk <- convert disk
 108   xmem <- 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 :: JSValue -> Result [(String, Node.Node)]
 124 getNodes arr = toArray arr >>= mapM parseNode
 125
 126 -- | Construct a node from a JSON object.
 127 parseNode :: JSValue -> Result (String, Node.Node)
 128 parseNode (JSArray [ name, mtotal, mnode, mfree, dtotal, dfree
 129                    , ctotal, offline, drained ])
 130     = do
 131   xname <- annotateResult "Parsing new node" (fromJVal name)
 132   let convert v = annotateResult ("Node '" ++ xname ++ "'") (fromJVal v)
 133   xoffline <- convert offline
 134   node <- (if xoffline
 135            then return $ Node.create xname 0 0 0 0 0 0 True
 136            else do
 137              xdrained <- convert drained
 138              xmtotal  <- convert mtotal
 139              xmnode   <- convert mnode
 140              xmfree   <- convert mfree
 141              xdtotal  <- convert dtotal
 142              xdfree   <- convert dfree
 143              xctotal  <- convert ctotal
 144              return $ Node.create xname xmtotal xmnode xmfree
 145                     xdtotal xdfree xctotal (xoffline || xdrained))
 146   return (xname, node)
 147
 148 parseNode v = fail ("Invalid node query result: " ++ show v)
 149
 150 getClusterTags :: JSValue -> Result [String]
 151 getClusterTags v = do
 152   let errmsg = "Parsing cluster info"
 153   obj <- annotateResult errmsg $ asJSObject v
 154   tags <- tryFromObj errmsg (fromJSObject obj) "tag"
 155   return tags
 156
 157 -- * Main loader functionality
 158
 159 -- | Builds the cluster data from an URL.
 160 loadData :: String -- ^ Unix socket to use as source
 161          -> IO (Result (Node.AssocList, Instance.AssocList, [String]))
 162 loadData master =
 163   E.bracket
 164        (L.getClient master)
 165        L.closeClient
 166        (\s -> do
 167           nodes <- queryNodes s
 168           instances <- queryInstances s
 169           cinfo <- queryClusterInfo s
 170           return $ do -- Result monad
 171             node_data <- nodes >>= getNodes
 172             let (node_names, node_idx) = assignIndices node_data
 173             inst_data <- instances >>= getInstances node_names
 174             let (_, inst_idx) = assignIndices inst_data
 175             ctags <- cinfo >>= getClusterTags
 176             return (node_idx, inst_idx, ctags)
 177        )