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 qualified Control.Exception as E
  32 import Text.JSON.Types
  33
  34 import qualified Ganeti.Luxi as L
  35 import Ganeti.HTools.Loader
  36 import Ganeti.HTools.Types
  37 import qualified Ganeti.HTools.Node as Node
  38 import qualified Ganeti.HTools.Instance as Instance
  39 import Ganeti.HTools.Utils (fromJVal, annotateResult, tryFromObj, asJSObject)
  40
  41 -- * Utility functions
  42
  43 -- | Ensure a given JSValue is actually a JSArray.
  44 toArray :: (Monad m) => JSValue -> m [JSValue]
  45 toArray v =
  46     case v of
  47       JSArray arr -> return arr
  48       o -> fail ("Invalid input, expected array but got " ++ show o)
  49
  50 -- * Data querying functionality
  51
  52 -- | The input data for node query.
  53 queryNodesMsg :: JSValue
  54 queryNodesMsg =
  55     let nnames = JSArray []
  56         fnames = ["name",
  57                   "mtotal", "mnode", "mfree",
  58                   "dtotal", "dfree",
  59                   "ctotal",
  60                   "offline", "drained"]
  61         fields = JSArray $ map (JSString . toJSString) fnames
  62         use_locking = JSBool False
  63     in JSArray [nnames, fields, use_locking]
  64
  65 -- | The input data for instance query.
  66 queryInstancesMsg :: JSValue
  67 queryInstancesMsg =
  68     let nnames = JSArray []
  69         fnames = ["name",
  70                   "disk_usage", "be/memory", "be/vcpus",
  71                   "status", "pnode", "snodes", "tags", "oper_ram"]
  72         fields = JSArray $ map (JSString . toJSString) fnames
  73         use_locking = JSBool False
  74     in JSArray [nnames, fields, use_locking]
  75
  76 -- | The input data for cluster query
  77 queryClusterInfoMsg :: JSValue
  78 queryClusterInfoMsg = JSArray []
  79
  80 -- | Wraper over callMethod doing node query.
  81 queryNodes :: L.Client -> IO (Result JSValue)
  82 queryNodes = L.callMethod L.QueryNodes queryNodesMsg
  83
  84 -- | Wraper over callMethod doing instance query.
  85 queryInstances :: L.Client -> IO (Result JSValue)
  86 queryInstances = L.callMethod L.QueryInstances queryInstancesMsg
  87
  88 queryClusterInfo :: L.Client -> IO (Result JSValue)
  89 queryClusterInfo = L.callMethod L.QueryClusterInfo queryClusterInfoMsg
  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 :: [(String, Ndx)]
  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 :: 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   xdrained <- convert drained
 135   node <- (if xoffline || xdrained
 136            then return $ Node.create xname 0 0 0 0 0 0 True
 137            else do
 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 False)
 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   tryFromObj errmsg (fromJSObject obj) "tags"
 155
 156 -- * Main loader functionality
 157
 158 -- | Builds the cluster data from an URL.
 159 loadData :: String -- ^ Unix socket to use as source
 160          -> IO (Result (Node.AssocList, Instance.AssocList, [String]))
 161 loadData master =
 162   E.bracket
 163        (L.getClient master)
 164        L.closeClient
 165        (\s -> do
 166           nodes <- queryNodes s
 167           instances <- queryInstances s
 168           cinfo <- queryClusterInfo s
 169           return $ do -- Result monad
 170             node_data <- nodes >>= getNodes
 171             let (node_names, node_idx) = assignIndices node_data
 172             inst_data <- instances >>= getInstances node_names
 173             let (_, inst_idx) = assignIndices inst_data
 174             ctags <- cinfo >>= getClusterTags
 175             return (node_idx, inst_idx, ctags)
 176        )