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

   1 {-| Implementation of the RAPI client interface.
   2
   3 -}
   4
   5 {-
   6
   7 Copyright (C) 2009, 2010, 2011 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 {-# LANGUAGE BangPatterns, CPP #-}
  27
  28 module Ganeti.HTools.Rapi
  29     (
  30       loadData
  31     , parseData
  32     ) where
  33
  34 import Data.Maybe (fromMaybe)
  35 #ifndef NO_CURL
  36 import Network.Curl
  37 import Network.Curl.Types ()
  38 #endif
  39 import Control.Monad
  40 import Text.JSON (JSObject, fromJSObject, decodeStrict)
  41 import Text.JSON.Types (JSValue(..))
  42 import Text.Printf (printf)
  43
  44 import Ganeti.HTools.Utils
  45 import Ganeti.HTools.Loader
  46 import Ganeti.HTools.Types
  47 import qualified Ganeti.HTools.Group as Group
  48 import qualified Ganeti.HTools.Node as Node
  49 import qualified Ganeti.HTools.Instance as Instance
  50 import qualified Ganeti.Constants as C
  51
  52 -- | Read an URL via curl and return the body if successful.
  53 getUrl :: (Monad m) => String -> IO (m String)
  54
  55 #ifdef NO_CURL
  56 getUrl _ = return $ fail "RAPI/curl backend disabled at compile time"
  57
  58 #else
  59
  60 -- | The curl options we use.
  61 curlOpts :: [CurlOption]
  62 curlOpts = [ CurlSSLVerifyPeer False
  63            , CurlSSLVerifyHost 0
  64            , CurlTimeout (fromIntegral queryTimeout)
  65            , CurlConnectTimeout (fromIntegral connTimeout)
  66            ]
  67
  68 getUrl url = do
  69   (code, !body) <- curlGetString url curlOpts
  70   return (case code of
  71             CurlOK -> return body
  72             _ -> fail $ printf "Curl error for '%s', error %s"
  73                  url (show code))
  74 #endif
  75
  76 -- | Append the default port if not passed in.
  77 formatHost :: String -> String
  78 formatHost master =
  79     if ':' `elem` master then  master
  80     else "https://" ++ master ++ ":" ++ show C.defaultRapiPort
  81
  82 -- | Parse a instance list in JSON format.
  83 getInstances :: NameAssoc
  84              -> String
  85              -> Result [(String, Instance.Instance)]
  86 getInstances ktn body =
  87     loadJSArray "Parsing instance data" body >>=
  88     mapM (parseInstance ktn . fromJSObject)
  89
  90 -- | Parse a node list in JSON format.
  91 getNodes :: NameAssoc -> String -> Result [(String, Node.Node)]
  92 getNodes ktg body = loadJSArray "Parsing node data" body >>=
  93                 mapM (parseNode ktg . fromJSObject)
  94
  95 -- | Parse a group list in JSON format.
  96 getGroups :: String -> Result [(String, Group.Group)]
  97 getGroups body = loadJSArray "Parsing group data" body >>=
  98                 mapM (parseGroup . fromJSObject)
  99
 100 -- | Construct an instance from a JSON object.
 101 parseInstance :: NameAssoc
 102               -> JSRecord
 103               -> Result (String, Instance.Instance)
 104 parseInstance ktn a = do
 105   name <- tryFromObj "Parsing new instance" a "name"
 106   let owner_name = "Instance '" ++ name ++ "', error while parsing data"
 107   let extract s x = tryFromObj owner_name x s
 108   disk <- extract "disk_usage" a
 109   beparams <- liftM fromJSObject (extract "beparams" a)
 110   omem <- extract "oper_ram" a
 111   mem <- (case omem of
 112             JSRational _ _ -> annotateResult owner_name (fromJVal omem)
 113             _ -> extract "memory" beparams)
 114   vcpus <- extract "vcpus" beparams
 115   pnode <- extract "pnode" a >>= lookupNode ktn name
 116   snodes <- extract "snodes" a
 117   snode <- (if null snodes then return Node.noSecondary
 118             else readEitherString (head snodes) >>= lookupNode ktn name)
 119   running <- extract "status" a
 120   tags <- extract "tags" a
 121   auto_balance <- extract "auto_balance" beparams
 122   dt <- extract "disk_template" a
 123   let inst = Instance.create name mem disk vcpus running tags
 124              auto_balance pnode snode dt
 125   return (name, inst)
 126
 127 -- | Construct a node from a JSON object.
 128 parseNode :: NameAssoc -> JSRecord -> Result (String, Node.Node)
 129 parseNode ktg a = do
 130   name <- tryFromObj "Parsing new node" a "name"
 131   let desc = "Node '" ++ name ++ "', error while parsing data"
 132       extract s = tryFromObj desc a s
 133   offline <- extract "offline"
 134   drained <- extract "drained"
 135   vm_cap  <- annotateResult desc $ maybeFromObj a "vm_capable"
 136   let vm_cap' = fromMaybe True vm_cap
 137   guuid   <- annotateResult desc $ maybeFromObj a "group.uuid"
 138   guuid' <-  lookupGroup ktg name (fromMaybe defaultGroupID guuid)
 139   node <- (if offline || drained || not vm_cap'
 140            then return $ Node.create name 0 0 0 0 0 0 True guuid'
 141            else do
 142              mtotal  <- extract "mtotal"
 143              mnode   <- extract "mnode"
 144              mfree   <- extract "mfree"
 145              dtotal  <- extract "dtotal"
 146              dfree   <- extract "dfree"
 147              ctotal  <- extract "ctotal"
 148              return $ Node.create name mtotal mnode mfree
 149                     dtotal dfree ctotal False guuid')
 150   return (name, node)
 151
 152 -- | Construct a group from a JSON object.
 153 parseGroup :: JSRecord -> Result (String, Group.Group)
 154 parseGroup a = do
 155   name <- tryFromObj "Parsing new group" a "name"
 156   let extract s = tryFromObj ("Group '" ++ name ++ "'") a s
 157   uuid <- extract "uuid"
 158   apol <- extract "alloc_policy"
 159   return (uuid, Group.create name uuid apol)
 160
 161 -- | Loads the raw cluster data from an URL.
 162 readData :: String -- ^ Cluster or URL to use as source
 163          -> IO (Result String, Result String, Result String, Result String)
 164 readData master = do
 165   let url = formatHost master
 166   group_body <- getUrl $ printf "%s/2/groups?bulk=1" url
 167   node_body <- getUrl $ printf "%s/2/nodes?bulk=1" url
 168   inst_body <- getUrl $ printf "%s/2/instances?bulk=1" url
 169   tags_body <- getUrl $ printf "%s/2/tags" url
 170   return (group_body, node_body, inst_body, tags_body)
 171
 172 -- | Builds the cluster data from the raw Rapi content.
 173 parseData :: (Result String, Result String, Result String, Result String)
 174           -> Result ClusterData
 175 parseData (group_body, node_body, inst_body, tags_body) = do
 176   group_data <- group_body >>= getGroups
 177   let (group_names, group_idx) = assignIndices group_data
 178   node_data <- node_body >>= getNodes group_names
 179   let (node_names, node_idx) = assignIndices node_data
 180   inst_data <- inst_body >>= getInstances node_names
 181   let (_, inst_idx) = assignIndices inst_data
 182   tags_data <- tags_body >>= (fromJResult "Parsing tags data" . decodeStrict)
 183   return (ClusterData group_idx node_idx inst_idx tags_data)
 184
 185 -- | Top level function for data loading.
 186 loadData :: String -- ^ Cluster or URL to use as source
 187          -> IO (Result ClusterData)
 188 loadData = fmap parseData . readData