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     ) where
  30
  31 import Network.Curl
  32 import Network.Curl.Types ()
  33 import Network.Curl.Code
  34 import Data.List
  35 import Control.Monad
  36 import Text.JSON (JSObject, JSValue, fromJSObject, decodeStrict)
  37 import Text.JSON.Types (JSValue(..))
  38 import Text.Printf (printf)
  39
  40 import Ganeti.HTools.Utils
  41 import Ganeti.HTools.Loader
  42 import Ganeti.HTools.Types
  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 body >>= mapM (parseInstance ktn . fromJSObject)
  71
  72 -- | Parse a node list in JSON format.
  73 getNodes :: String -> Result [(String, Node.Node)]
  74 getNodes body = loadJSArray body >>= mapM (parseNode . fromJSObject)
  75
  76 -- | Construct an instance from a JSON object.
  77 parseInstance :: [(String, Ndx)]
  78               -> [(String, JSValue)]
  79               -> Result (String, Instance.Instance)
  80 parseInstance ktn a = do
  81   name <- tryFromObj "Parsing new instance" a "name"
  82   let owner_name = "Instance '" ++ name ++ "'"
  83   let extract s x = tryFromObj owner_name x s
  84   disk <- extract "disk_usage" a
  85   beparams <- liftM fromJSObject (extract "beparams" a)
  86   omem <- extract "oper_ram" a
  87   mem <- (case omem of
  88             JSRational _ _ -> annotateResult owner_name (fromJVal omem)
  89             _ -> extract "memory" beparams)
  90   vcpus <- extract "vcpus" beparams
  91   pnode <- extract "pnode" a >>= lookupNode ktn name
  92   snodes <- extract "snodes" a
  93   snode <- (if null snodes then return Node.noSecondary
  94             else readEitherString (head snodes) >>= lookupNode ktn name)
  95   running <- extract "status" a
  96   tags <- extract "tags" a
  97   let inst = Instance.create name mem disk vcpus running tags pnode snode
  98   return (name, inst)
  99
 100 -- | Construct a node from a JSON object.
 101 parseNode :: [(String, JSValue)] -> Result (String, Node.Node)
 102 parseNode a = do
 103   name <- tryFromObj "Parsing new node" a "name"
 104   let extract s = tryFromObj ("Node '" ++ name ++ "'") a s
 105   offline <- extract "offline"
 106   drained <- extract "drained"
 107   node <- (if offline || drained
 108            then return $ Node.create name 0 0 0 0 0 0 True
 109            else do
 110              mtotal  <- extract "mtotal"
 111              mnode   <- extract "mnode"
 112              mfree   <- extract "mfree"
 113              dtotal  <- extract "dtotal"
 114              dfree   <- extract "dfree"
 115              ctotal  <- extract "ctotal"
 116              return $ Node.create name mtotal mnode mfree
 117                     dtotal dfree ctotal False)
 118   return (name, node)
 119
 120 -- | Builds the cluster data from an URL.
 121 loadData :: String -- ^ Cluster or URL to use as source
 122          -> IO (Result (Node.AssocList, Instance.AssocList, [String]))
 123 loadData master = do -- IO monad
 124   let url = formatHost master
 125   node_body <- getUrl $ printf "%s/2/nodes?bulk=1" url
 126   inst_body <- getUrl $ printf "%s/2/instances?bulk=1" url
 127   tags_body <- getUrl $ printf "%s/2/tags" url
 128   return $ do -- Result monad
 129     node_data <- node_body >>= getNodes
 130     let (node_names, node_idx) = assignIndices node_data
 131     inst_data <- inst_body >>= getInstances node_names
 132     let (_, inst_idx) = assignIndices inst_data
 133     tags_data <- tags_body >>= (fromJResult . decodeStrict)
 134     return (node_idx, inst_idx, tags_data)