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