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.HTools.Loader
48 import Ganeti.HTools.Types
50 import qualified Ganeti.HTools.Group as Group
51 import qualified Ganeti.HTools.Node as Node
52 import qualified Ganeti.HTools.Instance as Instance
53 import qualified Ganeti.Constants as C
55 {-# ANN module "HLint: ignore Eta reduce" #-}
57 -- | File method prefix.
59 filePrefix = "file://"
61 -- | Read an URL via curl and return the body if successful.
62 getUrl :: (Monad m) => String -> IO (m String)
65 getUrl _ = return $ fail "RAPI/curl backend disabled at compile time"
69 -- | The curl options we use.
70 curlOpts :: [CurlOption]
71 curlOpts = [ CurlSSLVerifyPeer False
73 , CurlTimeout (fromIntegral queryTimeout)
74 , CurlConnectTimeout (fromIntegral connTimeout)
78 (code, !body) <- curlGetString url curlOpts
81 _ -> fail $ printf "Curl error for '%s', error %s"
85 -- | Helper to convert I/O errors in 'Bad' values.
86 ioErrToResult :: IO a -> IO (Result a)
87 ioErrToResult ioaction =
88 catch (liftM Ok ioaction)
89 (\e -> return . Bad . show $ (e::IOException))
91 -- | Append the default port if not passed in.
92 formatHost :: String -> String
96 else "https://" ++ master ++ ":" ++ show C.defaultRapiPort
98 -- | Parse a instance list in JSON format.
99 getInstances :: NameAssoc
101 -> Result [(String, Instance.Instance)]
102 getInstances ktn body =
103 loadJSArray "Parsing instance data" body >>=
104 mapM (parseInstance ktn . fromJSObject)
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)
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)
116 -- | Construct an instance from a JSON object.
117 parseInstance :: NameAssoc
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
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 <- if null snodes
134 then return Node.noSecondary
135 else readEitherString (head snodes) >>= 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
145 -- | Construct a node from a JSON object.
146 parseNode :: NameAssoc -> JSRecord -> Result (String, Node.Node)
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'
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'
172 -- | Construct a group from a JSON object.
173 parseGroup :: JSRecord -> Result (String, Group.Group)
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 return (uuid, Group.create name uuid apol ipol)
182 -- | Parse cluster data from the info resource.
183 parseCluster :: JSObject JSValue -> Result ([String], IPolicy)
184 parseCluster obj = do
185 let obj' = fromJSObject obj
186 extract s = tryFromObj "Parsing cluster data" obj' s
187 tags <- extract "tags"
188 ipolicy <- extract "ipolicy"
189 return (tags, ipolicy)
191 -- | Loads the raw cluster data from an URL.
192 readDataHttp :: String -- ^ Cluster or URL to use as source
193 -> IO (Result String, Result String, Result String, Result String)
194 readDataHttp master = do
195 let url = formatHost master
196 group_body <- getUrl $ printf "%s/2/groups?bulk=1" url
197 node_body <- getUrl $ printf "%s/2/nodes?bulk=1" url
198 inst_body <- getUrl $ printf "%s/2/instances?bulk=1" url
199 info_body <- getUrl $ printf "%s/2/info" url
200 return (group_body, node_body, inst_body, info_body)
202 -- | Loads the raw cluster data from the filesystem.
203 readDataFile:: String -- ^ Path to the directory containing the files
204 -> IO (Result String, Result String, Result String, Result String)
205 readDataFile path = do
206 group_body <- ioErrToResult . readFile $ path </> "groups.json"
207 node_body <- ioErrToResult . readFile $ path </> "nodes.json"
208 inst_body <- ioErrToResult . readFile $ path </> "instances.json"
209 info_body <- ioErrToResult . readFile $ path </> "info.json"
210 return (group_body, node_body, inst_body, info_body)
212 -- | Loads data via either 'readDataFile' or 'readDataHttp'.
213 readData :: String -- ^ URL to use as source
214 -> IO (Result String, Result String, Result String, Result String)
216 if filePrefix `isPrefixOf` url
217 then readDataFile (drop (length filePrefix) url)
218 else readDataHttp url
220 -- | Builds the cluster data from the raw Rapi content.
221 parseData :: (Result String, Result String, Result String, Result String)
222 -> Result ClusterData
223 parseData (group_body, node_body, inst_body, info_body) = do
224 group_data <- group_body >>= getGroups
225 let (group_names, group_idx) = assignIndices group_data
226 node_data <- node_body >>= getNodes group_names
227 let (node_names, node_idx) = assignIndices node_data
228 inst_data <- inst_body >>= getInstances node_names
229 let (_, inst_idx) = assignIndices inst_data
230 (tags, ipolicy) <- info_body >>=
231 (fromJResult "Parsing cluster info" . decodeStrict) >>=
233 return (ClusterData group_idx node_idx inst_idx tags ipolicy)
235 -- | Top level function for data loading.
236 loadData :: String -- ^ Cluster or URL to use as source
237 -> IO (Result ClusterData)
238 loadData = fmap parseData . readData