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