Fix evacuation out of drained node
[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 let live = not xoffline && xvm_capable
198 lvconvert def n d = eitherLive live def $ convert n d
199 xmtotal <- lvconvert 0.0 "mtotal" mtotal
200 xmnode <- lvconvert 0 "mnode" mnode
201 xmfree <- lvconvert 0 "mfree" mfree
202 xdtotal <- lvconvert 0.0 "dtotal" dtotal
203 xdfree <- lvconvert 0 "dfree" dfree
204 xctotal <- lvconvert 0.0 "ctotal" ctotal
205 let node = Node.create xname xmtotal xmnode xmfree xdtotal xdfree
206 xctotal (not live || xdrained) xspindles xgdx
207 return (xname, node)
208
209 parseNode _ v = fail ("Invalid node query result: " ++ show v)
210
211 -- | Parses the cluster tags.
212 getClusterData :: JSValue -> Result ([String], IPolicy, String)
213 getClusterData (JSObject obj) = do
214 let errmsg = "Parsing cluster info"
215 obj' = fromJSObject obj
216 ctags <- tryFromObj errmsg obj' "tags"
217 cpol <- tryFromObj errmsg obj' "ipolicy"
218 master <- tryFromObj errmsg obj' "master"
219 return (ctags, cpol, master)
220
221 getClusterData _ = Bad "Cannot parse cluster info, not a JSON record"
222
223 -- | Parses the cluster groups.
224 getGroups :: JSValue -> Result [(String, Group.Group)]
225 getGroups jsv = extractArray jsv >>= mapM parseGroup
226
227 -- | Parses a given group information.
228 parseGroup :: [(JSValue, JSValue)] -> Result (String, Group.Group)
229 parseGroup [uuid, name, apol, ipol, tags] = do
230 xname <- annotateResult "Parsing new group" (fromJValWithStatus name)
231 let convert a = genericConvert "Group" xname a
232 xuuid <- convert "uuid" uuid
233 xapol <- convert "alloc_policy" apol
234 xipol <- convert "ipolicy" ipol
235 xtags <- convert "tags" tags
236 -- TODO: parse networks to which this group is connected
237 return (xuuid, Group.create xname xuuid xapol [] xipol xtags)
238
239 parseGroup v = fail ("Invalid group query result: " ++ show v)
240
241 -- * Main loader functionality
242
243 -- | Builds the cluster data by querying a given socket name.
244 readData :: String -- ^ Unix socket to use as source
245 -> IO (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
246 readData master =
247 E.bracket
248 (L.getClient master)
249 L.closeClient
250 (\s -> do
251 nodes <- queryNodes s
252 instances <- queryInstances s
253 cinfo <- queryClusterInfo s
254 groups <- queryGroups s
255 return (groups, nodes, instances, cinfo)
256 )
257
258 -- | Converts the output of 'readData' into the internal cluster
259 -- representation.
260 parseData :: (Result JSValue, Result JSValue, Result JSValue, Result JSValue)
261 -> Result ClusterData
262 parseData (groups, nodes, instances, cinfo) = do
263 group_data <- groups >>= getGroups
264 let (group_names, group_idx) = assignIndices group_data
265 node_data <- nodes >>= getNodes group_names
266 let (node_names, node_idx) = assignIndices node_data
267 inst_data <- instances >>= getInstances node_names
268 let (_, inst_idx) = assignIndices inst_data
269 (ctags, cpol, master) <- cinfo >>= getClusterData
270 node_idx' <- setMaster node_names node_idx master
271 return (ClusterData group_idx node_idx' inst_idx ctags cpol)
272
273 -- | Top level function for data loading.
274 loadData :: String -- ^ Unix socket to use as source
275 -> IO (Result ClusterData)
276 loadData = fmap parseData . readData