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