Parse node group networks
[ganeti-github.git] / src / Ganeti / HTools / Backend / Luxi.hs
1 {-| Implementation of the LUXI loader.
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 module Ganeti.HTools.Backend.Luxi
27 ( loadData
28 , parseData
29 ) where
30
31 import qualified Control.Exception as E
32 import Control.Monad (liftM)
33 import Text.JSON.Types
34 import qualified Text.JSON
35
36 import Ganeti.BasicTypes
37 import Ganeti.Errors
38 import qualified Ganeti.Luxi as L
39 import qualified Ganeti.Query.Language as Qlang
40 import Ganeti.HTools.Loader
41 import Ganeti.HTools.Types
42 import qualified Ganeti.HTools.Group as Group
43 import qualified Ganeti.HTools.Node as Node
44 import qualified Ganeti.HTools.Instance as Instance
45 import Ganeti.JSON
46
47 {-# ANN module "HLint: ignore Eta reduce" #-}
48
49 -- * Utility functions
50
51 -- | Get values behind \"data\" part of the result.
52 getData :: (Monad m) => JSValue -> m JSValue
53 getData (JSObject o) = fromObj (fromJSObject o) "data"
54 getData x = fail $ "Invalid input, expected dict entry but got " ++ show x
55
56 -- | Converts a (status, value) into m value, if possible.
57 parseQueryField :: (Monad m) => JSValue -> m (JSValue, JSValue)
58 parseQueryField (JSArray [status, result]) = return (status, result)
59 parseQueryField o =
60 fail $ "Invalid query field, expected (status, value) but got " ++ show o
61
62 -- | Parse a result row.
63 parseQueryRow :: (Monad m) => JSValue -> m [(JSValue, JSValue)]
64 parseQueryRow (JSArray arr) = mapM parseQueryField arr
65 parseQueryRow o =
66 fail $ "Invalid query row result, expected array but got " ++ show o
67
68 -- | Parse an overall query result and get the [(status, value)] list
69 -- for each element queried.
70 parseQueryResult :: (Monad m) => JSValue -> m [[(JSValue, JSValue)]]
71 parseQueryResult (JSArray arr) = mapM parseQueryRow arr
72 parseQueryResult o =
73 fail $ "Invalid query result, expected array but got " ++ show o
74
75 -- | Prepare resulting output as parsers expect it.
76 extractArray :: (Monad m) => JSValue -> m [[(JSValue, JSValue)]]
77 extractArray v =
78 getData v >>= parseQueryResult
79
80 -- | Testing result status for more verbose error message.
81 fromJValWithStatus :: (Text.JSON.JSON a, Monad m) => (JSValue, JSValue) -> m a
82 fromJValWithStatus (st, v) = do
83 st' <- fromJVal st
84 Qlang.checkRS st' v >>= fromJVal
85
86 -- | Annotate errors when converting values with owner/attribute for
87 -- better debugging.
88 genericConvert :: (Text.JSON.JSON a) =>
89 String -- ^ The object type
90 -> String -- ^ The object name
91 -> String -- ^ The attribute we're trying to convert
92 -> (JSValue, JSValue) -- ^ The value we're trying to convert
93 -> Result a -- ^ The annotated result
94 genericConvert otype oname oattr =
95 annotateResult (otype ++ " '" ++ oname ++
96 "', error while reading attribute '" ++
97 oattr ++ "'") . fromJValWithStatus
98
99 -- * Data querying functionality
100
101 -- | The input data for node query.
102 queryNodesMsg :: L.LuxiOp
103 queryNodesMsg =
104 L.Query (Qlang.ItemTypeOpCode Qlang.QRNode)
105 ["name", "mtotal", "mnode", "mfree", "dtotal", "dfree",
106 "ctotal", "offline", "drained", "vm_capable",
107 "ndp/spindle_count", "group.uuid"] Qlang.EmptyFilter
108
109 -- | The input data for instance query.
110 queryInstancesMsg :: L.LuxiOp
111 queryInstancesMsg =
112 L.Query (Qlang.ItemTypeOpCode Qlang.QRInstance)
113 ["name", "disk_usage", "be/memory", "be/vcpus",
114 "status", "pnode", "snodes", "tags", "oper_ram",
115 "be/auto_balance", "disk_template",
116 "be/spindle_use"] Qlang.EmptyFilter
117
118 -- | The input data for cluster query.
119 queryClusterInfoMsg :: L.LuxiOp
120 queryClusterInfoMsg = L.QueryClusterInfo
121
122 -- | The input data for node group query.
123 queryGroupsMsg :: L.LuxiOp
124 queryGroupsMsg =
125 L.Query (Qlang.ItemTypeOpCode Qlang.QRGroup)
126 ["uuid", "name", "alloc_policy", "ipolicy", "tags"]
127 Qlang.EmptyFilter
128
129 -- | Wraper over 'callMethod' doing node query.
130 queryNodes :: L.Client -> IO (Result JSValue)
131 queryNodes = liftM errToResult . L.callMethod queryNodesMsg
132
133 -- | Wraper over 'callMethod' doing instance query.
134 queryInstances :: L.Client -> IO (Result JSValue)
135 queryInstances = liftM errToResult . L.callMethod queryInstancesMsg
136
137 -- | Wrapper over 'callMethod' doing cluster information query.
138 queryClusterInfo :: L.Client -> IO (Result JSValue)
139 queryClusterInfo = liftM errToResult . L.callMethod queryClusterInfoMsg
140
141 -- | Wrapper over callMethod doing group query.
142 queryGroups :: L.Client -> IO (Result JSValue)
143 queryGroups = liftM errToResult . L.callMethod queryGroupsMsg
144
145 -- | Parse a instance list in JSON format.
146 getInstances :: NameAssoc
147 -> JSValue
148 -> Result [(String, Instance.Instance)]
149 getInstances ktn arr = extractArray arr >>= mapM (parseInstance ktn)
150
151 -- | Construct an instance from a JSON object.
152 parseInstance :: NameAssoc
153 -> [(JSValue, JSValue)]
154 -> Result (String, Instance.Instance)
155 parseInstance ktn [ name, disk, mem, vcpus
156 , status, pnode, snodes, tags, oram
157 , auto_balance, disk_template, su ] = do
158 xname <- annotateResult "Parsing new instance" (fromJValWithStatus name)
159 let convert a = genericConvert "Instance" xname a
160 xdisk <- convert "disk_usage" disk
161 xmem <- case oram of -- FIXME: remove the "guessing"
162 (_, JSRational _ _) -> convert "oper_ram" oram
163 _ -> convert "be/memory" mem
164 xvcpus <- convert "be/vcpus" vcpus
165 xpnode <- convert "pnode" pnode >>= lookupNode ktn xname
166 xsnodes <- convert "snodes" snodes::Result [String]
167 snode <- case xsnodes of
168 [] -> return Node.noSecondary
169 x:_ -> lookupNode ktn xname x
170 xrunning <- convert "status" status
171 xtags <- convert "tags" tags
172 xauto_balance <- convert "auto_balance" auto_balance
173 xdt <- convert "disk_template" disk_template
174 xsu <- convert "be/spindle_use" su
175 let inst = Instance.create xname xmem xdisk [xdisk] xvcpus
176 xrunning xtags xauto_balance xpnode snode xdt xsu
177 return (xname, inst)
178
179 parseInstance _ v = fail ("Invalid instance query result: " ++ show v)
180
181 -- | Parse a node list in JSON format.
182 getNodes :: NameAssoc -> JSValue -> Result [(String, Node.Node)]
183 getNodes ktg arr = extractArray arr >>= mapM (parseNode ktg)
184
185 -- | Construct a node from a JSON object.
186 parseNode :: NameAssoc -> [(JSValue, JSValue)] -> Result (String, Node.Node)
187 parseNode ktg [ name, mtotal, mnode, mfree, dtotal, dfree
188 , ctotal, offline, drained, vm_capable, spindles, g_uuid ]
189 = do
190 xname <- annotateResult "Parsing new node" (fromJValWithStatus name)
191 let convert a = genericConvert "Node" xname a
192 xoffline <- convert "offline" offline
193 xdrained <- convert "drained" drained
194 xvm_capable <- convert "vm_capable" vm_capable
195 xspindles <- convert "spindles" spindles
196 xgdx <- convert "group.uuid" g_uuid >>= lookupGroup ktg xname
197 node <- if xoffline || xdrained || not xvm_capable
198 then return $ Node.create xname 0 0 0 0 0 0 True xspindles xgdx
199 else do
200 xmtotal <- convert "mtotal" mtotal
201 xmnode <- convert "mnode" mnode
202 xmfree <- convert "mfree" mfree
203 xdtotal <- convert "dtotal" dtotal
204 xdfree <- convert "dfree" dfree
205 xctotal <- convert "ctotal" ctotal
206 return $ Node.create xname xmtotal xmnode xmfree
207 xdtotal xdfree xctotal False xspindles xgdx
208 return (xname, node)
209
210 parseNode _ v = fail ("Invalid node query result: " ++ show v)
211
212 -- | Parses the cluster tags.
213 getClusterData :: JSValue -> Result ([String], IPolicy, String)
214 getClusterData (JSObject obj) = do
215 let errmsg = "Parsing cluster info"
216 obj' = fromJSObject obj
217 ctags <- tryFromObj errmsg obj' "tags"
218 cpol <- tryFromObj errmsg obj' "ipolicy"
219 master <- tryFromObj errmsg obj' "master"
220 return (ctags, cpol, master)
221
222 getClusterData _ = Bad "Cannot parse cluster info, not a JSON record"
223
224 -- | Parses the cluster groups.
225 getGroups :: JSValue -> Result [(String, Group.Group)]
226 getGroups jsv = extractArray jsv >>= mapM parseGroup
227
228 -- | Parses a given group information.
229 parseGroup :: [(JSValue, JSValue)] -> Result (String, Group.Group)
230 parseGroup [uuid, name, apol, ipol, tags] = do
231 xname <- annotateResult "Parsing new group" (fromJValWithStatus name)
232 let convert a = genericConvert "Group" xname a
233 xuuid <- convert "uuid" uuid
234 xapol <- convert "alloc_policy" apol
235 xipol <- convert "ipolicy" ipol
236 xtags <- convert "tags" tags
237 -- TODO: parse networks to which this group is connected
238 return (xuuid, Group.create xname xuuid xapol [] xipol xtags)
239
240 parseGroup v = fail ("Invalid group query result: " ++ show v)
241
242 -- * Main loader functionality
243
244 -- | Builds the cluster data by querying a given socket name.
245 readData :: String -- ^ Unix socket to use as source
246 -> IO (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
247 readData master =
248 E.bracket
249 (L.getClient master)
250 L.closeClient
251 (\s -> do
252 nodes <- queryNodes s
253 instances <- queryInstances s
254 cinfo <- queryClusterInfo s
255 groups <- queryGroups s
256 return (groups, nodes, instances, cinfo)
257 )
258
259 -- | Converts the output of 'readData' into the internal cluster
260 -- representation.
261 parseData :: (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
262 -> Result ClusterData
263 parseData (groups, nodes, instances, cinfo) = do
264 group_data <- groups >>= getGroups
265 let (group_names, group_idx) = assignIndices group_data
266 node_data <- nodes >>= getNodes group_names
267 let (node_names, node_idx) = assignIndices node_data
268 inst_data <- instances >>= getInstances node_names
269 let (_, inst_idx) = assignIndices inst_data
270 (ctags, cpol, master) <- cinfo >>= getClusterData
271 node_idx' <- setMaster node_names node_idx master
272 return (ClusterData group_idx node_idx' inst_idx ctags cpol)
273
274 -- | Top level function for data loading.
275 loadData :: String -- ^ Unix socket to use as source
276 -> IO (Result ClusterData)
277 loadData = fmap parseData . readData