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