Switch the curl bindings from optional to required
[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
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.Backend.Rapi
29 ( loadData
30 , parseData
31 ) where
32
33 import Control.Exception
34 import Data.List (isPrefixOf)
35 import Data.Maybe (fromMaybe)
36 import Network.Curl
37 import Network.Curl.Types ()
38 import Control.Monad
39 import Text.JSON (JSObject, fromJSObject, decodeStrict)
40 import Text.JSON.Types (JSValue(..))
41 import Text.Printf (printf)
42 import System.FilePath
43
44 import Ganeti.BasicTypes
45 import Ganeti.HTools.Loader
46 import Ganeti.HTools.Types
47 import Ganeti.JSON
48 import qualified Ganeti.HTools.Group as Group
49 import qualified Ganeti.HTools.Node as Node
50 import qualified Ganeti.HTools.Instance as Instance
51 import qualified Ganeti.Constants as C
52
53 {-# ANN module "HLint: ignore Eta reduce" #-}
54
55 -- | File method prefix.
56 filePrefix :: String
57 filePrefix = "file://"
58
59 -- | Read an URL via curl and return the body if successful.
60 getUrl :: (Monad m) => String -> IO (m String)
61
62 -- | Connection timeout (when using non-file methods).
63 connTimeout :: Long
64 connTimeout = 15
65
66 -- | The default timeout for queries (when using non-file methods).
67 queryTimeout :: Long
68 queryTimeout = 60
69
70 -- | The curl options we use.
71 curlOpts :: [CurlOption]
72 curlOpts = [ CurlSSLVerifyPeer False
73 , CurlSSLVerifyHost 0
74 , CurlTimeout queryTimeout
75 , CurlConnectTimeout connTimeout
76 ]
77
78 getUrl url = do
79 (code, !body) <- curlGetString url curlOpts
80 return (case code of
81 CurlOK -> return body
82 _ -> fail $ printf "Curl error for '%s', error %s"
83 url (show code))
84
85 -- | Helper to convert I/O errors in 'Bad' values.
86 ioErrToResult :: IO a -> IO (Result a)
87 ioErrToResult ioaction =
88 Control.Exception.catch (liftM Ok ioaction)
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 <- case snodes of
134 [] -> return Node.noSecondary
135 x:_ -> readEitherString x >>= 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 tags <- extract "tags"
181 return (uuid, Group.create name uuid apol ipol tags)
182
183 -- | Parse cluster data from the info resource.
184 parseCluster :: JSObject JSValue -> Result ([String], IPolicy)
185 parseCluster obj = do
186 let obj' = fromJSObject obj
187 extract s = tryFromObj "Parsing cluster data" obj' s
188 tags <- extract "tags"
189 ipolicy <- extract "ipolicy"
190 return (tags, ipolicy)
191
192 -- | Loads the raw cluster data from an URL.
193 readDataHttp :: String -- ^ Cluster or URL to use as source
194 -> IO (Result String, Result String, Result String, Result String)
195 readDataHttp master = do
196 let url = formatHost master
197 group_body <- getUrl $ printf "%s/2/groups?bulk=1" url
198 node_body <- getUrl $ printf "%s/2/nodes?bulk=1" url
199 inst_body <- getUrl $ printf "%s/2/instances?bulk=1" url
200 info_body <- getUrl $ printf "%s/2/info" url
201 return (group_body, node_body, inst_body, info_body)
202
203 -- | Loads the raw cluster data from the filesystem.
204 readDataFile:: String -- ^ Path to the directory containing the files
205 -> IO (Result String, Result String, Result String, Result String)
206 readDataFile path = do
207 group_body <- ioErrToResult . readFile $ path </> "groups.json"
208 node_body <- ioErrToResult . readFile $ path </> "nodes.json"
209 inst_body <- ioErrToResult . readFile $ path </> "instances.json"
210 info_body <- ioErrToResult . readFile $ path </> "info.json"
211 return (group_body, node_body, inst_body, info_body)
212
213 -- | Loads data via either 'readDataFile' or 'readDataHttp'.
214 readData :: String -- ^ URL to use as source
215 -> IO (Result String, Result String, Result String, Result String)
216 readData url =
217 if filePrefix `isPrefixOf` url
218 then readDataFile (drop (length filePrefix) url)
219 else readDataHttp url
220
221 -- | Builds the cluster data from the raw Rapi content.
222 parseData :: (Result String, Result String, Result String, Result String)
223 -> Result ClusterData
224 parseData (group_body, node_body, inst_body, info_body) = do
225 group_data <- group_body >>= getGroups
226 let (group_names, group_idx) = assignIndices group_data
227 node_data <- node_body >>= getNodes group_names
228 let (node_names, node_idx) = assignIndices node_data
229 inst_data <- inst_body >>= getInstances node_names
230 let (_, inst_idx) = assignIndices inst_data
231 (tags, ipolicy) <- info_body >>=
232 (fromJResult "Parsing cluster info" . decodeStrict) >>=
233 parseCluster
234 return (ClusterData group_idx node_idx inst_idx tags ipolicy)
235
236 -- | Top level function for data loading.
237 loadData :: String -- ^ Cluster or URL to use as source
238 -> IO (Result ClusterData)
239 loadData = fmap parseData . readData