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