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)
  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"]
  74         fields = JSArray $ map (JSString . toJSString) fnames
  75         use_locking = JSBool False
  76     in JSArray [nnames, fields, use_locking]
  77
  78 -- | Wraper over callMethod doing node query.
  79 queryNodes :: L.Client -> IO (Result JSValue)
  80 queryNodes = L.callMethod L.QueryNodes queryNodesMsg
  81
  82 -- | Wraper over callMethod doing instance query.
  83 queryInstances :: L.Client -> IO (Result JSValue)
  84 queryInstances = L.callMethod L.QueryInstances queryInstancesMsg
  85
  86 -- | Parse a instance list in JSON format.
  87 getInstances :: NameAssoc
  88              -> JSValue
  89              -> Result [(String, Instance.Instance)]
  90 getInstances ktn arr = toArray arr >>= mapM (parseInstance ktn)
  91
  92 -- | Construct an instance from a JSON object.
  93 parseInstance :: [(String, Ndx)]
  94               -> JSValue
  95               -> Result (String, Instance.Instance)
  96 parseInstance ktn (JSArray [ name, disk, mem, vcpus
  97                            , status, pnode, snodes ]) = do
  98   xname <- annotateResult "Parsing new instance" (fromJVal name)
  99   let convert v = annotateResult ("Instance '" ++ xname ++ "'") (fromJVal v)
 100   xdisk <- convert disk
 101   xmem <- convert mem
 102   xvcpus <- convert vcpus
 103   xpnode <- convert pnode >>= lookupNode ktn xname
 104   xsnodes <- convert snodes::Result [JSString]
 105   snode <- (if null xsnodes then return Node.noSecondary
 106             else lookupNode ktn xname (fromJSString $ head xsnodes))
 107   xrunning <- convert status
 108   let inst = Instance.create xname xmem xdisk xvcpus xrunning xpnode snode
 109   return (xname, inst)
 110
 111 parseInstance _ v = fail ("Invalid instance query result: " ++ show v)
 112
 113 -- | Parse a node list in JSON format.
 114 getNodes :: JSValue -> Result [(String, Node.Node)]
 115 getNodes arr = toArray arr >>= mapM parseNode
 116
 117 -- | Construct a node from a JSON object.
 118 parseNode :: JSValue -> Result (String, Node.Node)
 119 parseNode (JSArray [ name, mtotal, mnode, mfree, dtotal, dfree
 120                    , ctotal, offline, drained ])
 121     = do
 122   xname <- annotateResult "Parsing new node" (fromJVal name)
 123   let convert v = annotateResult ("Node '" ++ xname ++ "'") (fromJVal v)
 124   xoffline <- convert offline
 125   node <- (if xoffline
 126            then return $ Node.create xname 0 0 0 0 0 0 True
 127            else do
 128              xdrained <- convert drained
 129              xmtotal  <- convert mtotal
 130              xmnode   <- convert mnode
 131              xmfree   <- convert mfree
 132              xdtotal  <- convert dtotal
 133              xdfree   <- convert dfree
 134              xctotal  <- convert ctotal
 135              return $ Node.create xname xmtotal xmnode xmfree
 136                     xdtotal xdfree xctotal (xoffline || xdrained))
 137   return (xname, node)
 138
 139 parseNode v = fail ("Invalid node query result: " ++ show v)
 140
 141 -- * Main loader functionality
 142
 143 -- | Builds the cluster data from an URL.
 144 loadData :: String -- ^ Unix socket to use as source
 145          -> IO (Result (Node.AssocList, Instance.AssocList))
 146 loadData master =
 147   E.bracket
 148        (L.getClient master)
 149        L.closeClient
 150        (\s -> do
 151           nodes <- queryNodes s
 152           instances <- queryInstances s
 153           return $ do -- Result monad
 154             node_data <- nodes >>= getNodes
 155             let (node_names, node_idx) = assignIndices node_data
 156             inst_data <- instances >>= getInstances node_names
 157             let (_, inst_idx) = assignIndices inst_data
 158             return (node_idx, inst_idx)
 159        )