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