Add SkipTest in hv_kvm psutil-specific test cases
[ganeti-github.git] / src / Ganeti / HTools / Backend / Rapi.hs
1 {-| Implementation of the RAPI client interface.
2
3 -}
4
5 {-
6
7 Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
8 All rights reserved.
9
10 Redistribution and use in source and binary forms, with or without
11 modification, are permitted provided that the following conditions are
12 met:
13
14 1. Redistributions of source code must retain the above copyright notice,
15 this list of conditions and the following disclaimer.
16
17 2. Redistributions in binary form must reproduce the above copyright
18 notice, this list of conditions and the following disclaimer in the
19 documentation and/or other materials provided with the distribution.
20
21 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
22 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
23 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
24 PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
25 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
26 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
27 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32
33 -}
34
35 {-# LANGUAGE BangPatterns, CPP #-}
36
37 module Ganeti.HTools.Backend.Rapi
38 ( loadData
39 , parseData
40 ) where
41
42 import Control.Exception
43 import Data.List (isPrefixOf)
44 import Data.Maybe (fromMaybe)
45 import Network.Curl
46 import Network.Curl.Types ()
47 import Control.Monad
48 import Text.JSON (JSObject, fromJSObject, decodeStrict)
49 import Text.JSON.Types (JSValue(..))
50 import Text.Printf (printf)
51 import System.FilePath
52
53 import Ganeti.BasicTypes
54 import Ganeti.HTools.Loader
55 import Ganeti.HTools.Types
56 import Ganeti.JSON (loadJSArray, JSRecord, tryFromObj, fromJVal, maybeFromObj, fromJResult, tryArrayMaybeFromObj, readEitherString, fromObjWithDefault, asJSObject, emptyContainer)
57 import qualified Ganeti.HTools.Group as Group
58 import qualified Ganeti.HTools.Node as Node
59 import qualified Ganeti.HTools.Instance as Instance
60 import qualified Ganeti.Constants as C
61
62 {-# ANN module "HLint: ignore Eta reduce" #-}
63
64 -- | File method prefix.
65 filePrefix :: String
66 filePrefix = "file://"
67
68 -- | Read an URL via curl and return the body if successful.
69 getUrl :: (Monad m) => String -> IO (m String)
70
71 -- | Connection timeout (when using non-file methods).
72 connTimeout :: Long
73 connTimeout = 15
74
75 -- | The default timeout for queries (when using non-file methods).
76 queryTimeout :: Long
77 queryTimeout = 60
78
79 -- | The curl options we use.
80 curlOpts :: [CurlOption]
81 curlOpts = [ CurlSSLVerifyPeer False
82 , CurlSSLVerifyHost 0
83 , CurlTimeout queryTimeout
84 , CurlConnectTimeout connTimeout
85 ]
86
87 getUrl url = do
88 (code, !body) <- curlGetString url curlOpts
89 return (case code of
90 CurlOK -> return body
91 _ -> fail $ printf "Curl error for '%s', error %s"
92 url (show code))
93
94 -- | Helper to convert I/O errors in 'Bad' values.
95 ioErrToResult :: IO a -> IO (Result a)
96 ioErrToResult ioaction =
97 Control.Exception.catch (liftM Ok ioaction)
98 (\e -> return . Bad . show $ (e::IOException))
99
100 -- | Append the default port if not passed in.
101 formatHost :: String -> String
102 formatHost master =
103 if ':' `elem` master
104 then master
105 else "https://" ++ master ++ ":" ++ show C.defaultRapiPort
106
107 -- | Parse a instance list in JSON format.
108 getInstances :: NameAssoc
109 -> String
110 -> Result [(String, Instance.Instance)]
111 getInstances ktn body =
112 loadJSArray "Parsing instance data" body >>=
113 mapM (parseInstance ktn . fromJSObject)
114
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)
119
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)
124
125 -- | Construct an instance from a JSON object.
126 parseInstance :: NameAssoc
127 -> JSRecord
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 dsizes <- extract "disk.sizes" a
135 dspindles <- tryArrayMaybeFromObj owner_name a "disk.spindles"
136 beparams <- liftM fromJSObject (extract "beparams" a)
137 omem <- extract "oper_ram" a
138 mem <- case omem of
139 JSRational _ _ -> annotateResult owner_name (fromJVal omem)
140 _ -> extract "memory" beparams `mplus` extract "maxmem" beparams
141 vcpus <- extract "vcpus" beparams
142 pnode <- extract "pnode" a >>= lookupNode ktn name
143 snodes <- extract "snodes" a
144 snode <- case snodes of
145 [] -> return Node.noSecondary
146 x:_ -> readEitherString x >>= lookupNode ktn name
147 running <- extract "status" a
148 tags <- extract "tags" a
149 auto_balance <- extract "auto_balance" beparams
150 dt <- extract "disk_template" a
151 su <- extract "spindle_use" beparams
152 -- Not forthcoming by default.
153 forthcoming <- extract "forthcoming" a `orElse` Ok False
154 let disks = zipWith Instance.Disk dsizes dspindles
155 let inst = Instance.create name mem disk disks vcpus running tags
156 auto_balance pnode snode dt su [] forthcoming
157 return (name, inst)
158
159 -- | Construct a node from a JSON object.
160 parseNode :: NameAssoc -> JSRecord -> Result (String, Node.Node)
161 parseNode ktg a = do
162 name <- tryFromObj "Parsing new node" a "name"
163 let desc = "Node '" ++ name ++ "', error while parsing data"
164 extract key = tryFromObj desc a key
165 extractDef def key = fromObjWithDefault a key def
166 offline <- extract "offline"
167 drained <- extract "drained"
168 vm_cap <- annotateResult desc $ maybeFromObj a "vm_capable"
169 let vm_cap' = fromMaybe True vm_cap
170 ndparams <- extract "ndparams" >>= asJSObject
171 excl_stor <- tryFromObj desc (fromJSObject ndparams) "exclusive_storage"
172 guuid <- annotateResult desc $ maybeFromObj a "group.uuid"
173 guuid' <- lookupGroup ktg name (fromMaybe defaultGroupID guuid)
174 let live = not offline && vm_cap'
175 lvextract def = eitherLive live def . extract
176 lvextractDef def = eitherLive live def . extractDef def
177 sptotal <- if excl_stor
178 then lvextract 0 "sptotal"
179 else tryFromObj desc (fromJSObject ndparams) "spindle_count"
180 spfree <- lvextractDef 0 "spfree"
181 mtotal <- lvextract 0.0 "mtotal"
182 mnode <- lvextract 0 "mnode"
183 mfree <- lvextract 0 "mfree"
184 dtotal <- lvextractDef 0.0 "dtotal"
185 dfree <- lvextractDef 0 "dfree"
186 ctotal <- lvextract 0.0 "ctotal"
187 cnos <- lvextract 0 "cnos"
188 tags <- extract "tags"
189 hv_state <- extractDef emptyContainer "hv_state"
190 let node_mem = obtainNodeMemory hv_state mnode
191 node = flip Node.setNodeTags tags $
192 Node.create name mtotal node_mem mfree dtotal dfree ctotal cnos
193 (not live || drained) sptotal spfree guuid' excl_stor
194 return (name, node)
195
196 -- | Construct a group from a JSON object.
197 parseGroup :: JSRecord -> Result (String, Group.Group)
198 parseGroup a = do
199 name <- tryFromObj "Parsing new group" a "name"
200 let extract s = tryFromObj ("Group '" ++ name ++ "'") a s
201 let extractDef s d = fromObjWithDefault a s d
202 uuid <- extract "uuid"
203 apol <- extract "alloc_policy"
204 ipol <- extract "ipolicy"
205 tags <- extract "tags"
206 nets <- extractDef "networks" []
207 return (uuid, Group.create name uuid apol nets ipol tags)
208
209 -- | Parse cluster data from the info resource.
210 parseCluster :: JSObject JSValue -> Result ([String], IPolicy, String)
211 parseCluster obj = do
212 let obj' = fromJSObject obj
213 extract s = tryFromObj "Parsing cluster data" obj' s
214 master <- extract "master"
215 tags <- extract "tags"
216 ipolicy <- extract "ipolicy"
217 return (tags, ipolicy, master)
218
219 -- | Loads the raw cluster data from an URL.
220 readDataHttp :: String -- ^ Cluster or URL to use as source
221 -> IO (Result String, Result String, Result String, Result String)
222 readDataHttp master = do
223 let url = formatHost master
224 group_body <- getUrl $ printf "%s/2/groups?bulk=1" url
225 node_body <- getUrl $ printf "%s/2/nodes?bulk=1" url
226 inst_body <- getUrl $ printf "%s/2/instances?bulk=1" url
227 info_body <- getUrl $ printf "%s/2/info" url
228 return (group_body, node_body, inst_body, info_body)
229
230 -- | Loads the raw cluster data from the filesystem.
231 readDataFile:: String -- ^ Path to the directory containing the files
232 -> IO (Result String, Result String, Result String, Result String)
233 readDataFile path = do
234 group_body <- ioErrToResult . readFile $ path </> "groups.json"
235 node_body <- ioErrToResult . readFile $ path </> "nodes.json"
236 inst_body <- ioErrToResult . readFile $ path </> "instances.json"
237 info_body <- ioErrToResult . readFile $ path </> "info.json"
238 return (group_body, node_body, inst_body, info_body)
239
240 -- | Loads data via either 'readDataFile' or 'readDataHttp'.
241 readData :: String -- ^ URL to use as source
242 -> IO (Result String, Result String, Result String, Result String)
243 readData url =
244 if filePrefix `isPrefixOf` url
245 then readDataFile (drop (length filePrefix) url)
246 else readDataHttp url
247
248 -- | Builds the cluster data from the raw Rapi content.
249 parseData :: (Result String, Result String, Result String, Result String)
250 -> Result ClusterData
251 parseData (group_body, node_body, inst_body, info_body) = do
252 group_data <- group_body >>= getGroups
253 let (group_names, group_idx) = assignIndices group_data
254 node_data <- node_body >>= getNodes group_names
255 let (node_names, node_idx) = assignIndices node_data
256 inst_data <- inst_body >>= getInstances node_names
257 let (_, inst_idx) = assignIndices inst_data
258 (tags, ipolicy, master) <-
259 info_body >>=
260 (fromJResult "Parsing cluster info" . decodeStrict) >>=
261 parseCluster
262 node_idx' <- setMaster node_names node_idx master
263 return (ClusterData group_idx node_idx' inst_idx tags ipolicy)
264
265 -- | Top level function for data loading.
266 loadData :: String -- ^ Cluster or URL to use as source
267 -> IO (Result ClusterData)
268 loadData = fmap parseData . readData