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

   1 {-| Implementation of the RAPI client interface.
   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.Rapi
  27     (
  28       loadData
  29     , parseData
  30     ) where
  31
  32 import Network.Curl
  33 import Network.Curl.Types ()
  34 import Control.Monad
  35 import Text.JSON (JSObject, JSValue, fromJSObject, decodeStrict)
  36 import Text.JSON.Types (JSValue(..))
  37 import Text.Printf (printf)
  38
  39 import Ganeti.HTools.Utils
  40 import Ganeti.HTools.Loader
  41 import Ganeti.HTools.Types
  42 import qualified Ganeti.HTools.Node as Node
  43 import qualified Ganeti.HTools.Instance as Instance
  44
  45 -- | Read an URL via curl and return the body if successful.
  46 getUrl :: (Monad m) => String -> IO (m String)
  47 getUrl url = do
  48   (code, body) <- curlGetString url [CurlSSLVerifyPeer False,
  49                                      CurlSSLVerifyHost 0,
  50                                      CurlTimeout (fromIntegral queryTimeout),
  51                                      CurlConnectTimeout
  52                                      (fromIntegral connTimeout)]
  53   return (case code of
  54             CurlOK -> return body
  55             _ -> fail $ printf "Curl error for '%s', error %s"
  56                  url (show code))
  57
  58 -- | Append the default port if not passed in.
  59 formatHost :: String -> String
  60 formatHost master =
  61     if ':' `elem` master then  master
  62     else "https://" ++ master ++ ":5080"
  63
  64 -- | Parse a instance list in JSON format.
  65 getInstances :: NameAssoc
  66              -> String
  67              -> Result [(String, Instance.Instance)]
  68 getInstances ktn body =
  69     loadJSArray "Parsing instance data" body >>=
  70     mapM (parseInstance ktn . fromJSObject)
  71
  72 -- | Parse a node list in JSON format.
  73 getNodes :: String -> Result [(String, Node.Node)]
  74 getNodes body = loadJSArray "Parsing node data" body >>=
  75                 mapM (parseNode . fromJSObject)
  76
  77 -- | Construct an instance from a JSON object.
  78 parseInstance :: [(String, Ndx)]
  79               -> [(String, JSValue)]
  80               -> Result (String, Instance.Instance)
  81 parseInstance ktn a = do
  82   name <- tryFromObj "Parsing new instance" a "name"
  83   let owner_name = "Instance '" ++ name ++ "'"
  84   let extract s x = tryFromObj owner_name x s
  85   disk <- extract "disk_usage" a
  86   beparams <- liftM fromJSObject (extract "beparams" a)
  87   omem <- extract "oper_ram" a
  88   mem <- (case omem of
  89             JSRational _ _ -> annotateResult owner_name (fromJVal omem)
  90             _ -> extract "memory" beparams)
  91   vcpus <- extract "vcpus" beparams
  92   pnode <- extract "pnode" a >>= lookupNode ktn name
  93   snodes <- extract "snodes" a
  94   snode <- (if null snodes then return Node.noSecondary
  95             else readEitherString (head snodes) >>= lookupNode ktn name)
  96   running <- extract "status" a
  97   tags <- extract "tags" a
  98   let inst = Instance.create name mem disk vcpus running tags pnode snode
  99   return (name, inst)
 100
 101 -- | Construct a node from a JSON object.
 102 parseNode :: [(String, JSValue)] -> Result (String, Node.Node)
 103 parseNode a = do
 104   name <- tryFromObj "Parsing new node" a "name"
 105   let extract s = tryFromObj ("Node '" ++ name ++ "'") a s
 106   offline <- extract "offline"
 107   drained <- extract "drained"
 108   node <- (if offline || drained
 109            then return $ Node.create name 0 0 0 0 0 0 True
 110            else do
 111              mtotal  <- extract "mtotal"
 112              mnode   <- extract "mnode"
 113              mfree   <- extract "mfree"
 114              dtotal  <- extract "dtotal"
 115              dfree   <- extract "dfree"
 116              ctotal  <- extract "ctotal"
 117              return $ Node.create name mtotal mnode mfree
 118                     dtotal dfree ctotal False)
 119   return (name, node)
 120
 121 -- | Loads the raw cluster data from an URL.
 122 readData :: String -- ^ Cluster or URL to use as source
 123          -> IO (Result String, Result String, Result String)
 124 readData master = do
 125   let url = formatHost master
 126   node_body <- getUrl $ printf "%s/2/nodes?bulk=1" url
 127   inst_body <- getUrl $ printf "%s/2/instances?bulk=1" url
 128   tags_body <- getUrl $ printf "%s/2/tags" url
 129   return (node_body, inst_body, tags_body)
 130
 131 -- | Builds the cluster data from the raw Rapi content
 132 parseData :: (Result String, Result String, Result String)
 133           -> Result (Node.AssocList, Instance.AssocList, [String])
 134 parseData (node_body, inst_body, tags_body) = do
 135   node_data <- node_body >>= getNodes
 136   let (node_names, node_idx) = assignIndices node_data
 137   inst_data <- inst_body >>= getInstances node_names
 138   let (_, inst_idx) = assignIndices inst_data
 139   tags_data <- tags_body >>= (fromJResult "Parsing tags data" . decodeStrict)
 140   return (node_idx, inst_idx, tags_data)
 141
 142 -- | Top level function for data loading
 143 loadData :: String -- ^ Cluster or URL to use as source
 144             -> IO (Result (Node.AssocList, Instance.AssocList, [String]))
 145 loadData master = readData master >>= return . parseData