root / src / Ganeti / Query / Instance.hs @ 3b89cb1b
History | View | Annotate | Download (28.1 kB)
1 |
{-| Implementation of the Ganeti Query2 instance queries. |
---|---|
2 |
|
3 |
-} |
4 |
|
5 |
{- |
6 |
|
7 |
Copyright (C) 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.Query.Instance |
27 |
( Runtime |
28 |
, fieldsMap |
29 |
, collectLiveData |
30 |
) where |
31 |
|
32 |
import Control.Applicative |
33 |
import Data.List |
34 |
import Data.Maybe |
35 |
import Data.Monoid |
36 |
import qualified Data.Map as Map |
37 |
import qualified Text.JSON as J |
38 |
import Text.Printf |
39 |
|
40 |
import Ganeti.BasicTypes |
41 |
import Ganeti.Common |
42 |
import Ganeti.Config |
43 |
import qualified Ganeti.Constants as C |
44 |
import qualified Ganeti.ConstantUtils as C |
45 |
import Ganeti.Errors |
46 |
import Ganeti.JSON |
47 |
import Ganeti.Objects |
48 |
import Ganeti.Query.Common |
49 |
import Ganeti.Query.Language |
50 |
import Ganeti.Query.Types |
51 |
import Ganeti.Rpc |
52 |
import Ganeti.Storage.Utils |
53 |
import Ganeti.Types |
54 |
import Ganeti.Utils (formatOrdinal) |
55 |
|
56 |
-- | The LiveInfo structure packs additional information beside the |
57 |
-- 'InstanceInfo'. We also need to know whether the instance information was |
58 |
-- found on the primary node, and encode this as a Bool. |
59 |
type LiveInfo = (InstanceInfo, Bool) |
60 |
|
61 |
-- | Runtime possibly containing the 'LiveInfo'. See the genericQuery function |
62 |
-- in the Query.hs file for an explanation of the terms used. |
63 |
type Runtime = Either RpcError (Maybe LiveInfo) |
64 |
|
65 |
-- | The instance fields map. |
66 |
fieldsMap :: FieldMap Instance Runtime |
67 |
fieldsMap = Map.fromList [(fdefName f, v) | v@(f, _, _) <- instanceFields] |
68 |
|
69 |
-- | The instance fields |
70 |
instanceFields :: FieldList Instance Runtime |
71 |
instanceFields = |
72 |
-- Simple fields |
73 |
[ (FieldDefinition "admin_state" "InstanceState" QFTText |
74 |
"Desired state of instance", |
75 |
FieldSimple (rsNormal . adminStateToRaw . instAdminState), QffNormal) |
76 |
, (FieldDefinition "admin_up" "Autostart" QFTBool |
77 |
"Desired state of instance", |
78 |
FieldSimple (rsNormal . (== AdminUp) . instAdminState), QffNormal) |
79 |
, (FieldDefinition "disk_template" "Disk_template" QFTText |
80 |
"Instance disk template", |
81 |
FieldSimple (rsNormal . instDiskTemplate), QffNormal) |
82 |
, (FieldDefinition "disks_active" "DisksActive" QFTBool |
83 |
"Desired state of instance disks", |
84 |
FieldSimple (rsNormal . instDisksActive), QffNormal) |
85 |
, (FieldDefinition "name" "Instance" QFTText |
86 |
"Instance name", |
87 |
FieldSimple (rsNormal . instName), QffHostname) |
88 |
, (FieldDefinition "hypervisor" "Hypervisor" QFTText |
89 |
"Hypervisor name", |
90 |
FieldSimple (rsNormal . instHypervisor), QffNormal) |
91 |
, (FieldDefinition "network_port" "Network_port" QFTOther |
92 |
"Instance network port if available (e.g. for VNC console)", |
93 |
FieldSimple (rsMaybeUnavail . instNetworkPort), QffNormal) |
94 |
, (FieldDefinition "os" "OS" QFTText |
95 |
"Operating system", |
96 |
FieldSimple (rsNormal . instOs), QffNormal) |
97 |
, (FieldDefinition "pnode" "Primary_node" QFTText |
98 |
"Primary node", |
99 |
FieldConfig getPrimaryNodeName, QffHostname) |
100 |
, (FieldDefinition "pnode.group" "PrimaryNodeGroup" QFTText |
101 |
"Primary node's group", |
102 |
FieldConfig getPrimaryNodeGroup, QffNormal) |
103 |
, (FieldDefinition "snodes" "Secondary_Nodes" QFTOther |
104 |
"Secondary nodes; usually this will just be one node", |
105 |
FieldConfig (getSecondaryNodeAttribute nodeName), QffNormal) |
106 |
, (FieldDefinition "snodes.group" "SecondaryNodesGroups" QFTOther |
107 |
"Node groups of secondary nodes", |
108 |
FieldConfig (getSecondaryNodeGroupAttribute groupName), QffNormal) |
109 |
, (FieldDefinition "snodes.group.uuid" "SecondaryNodesGroupsUUID" QFTOther |
110 |
"Node group UUIDs of secondary nodes", |
111 |
FieldConfig (getSecondaryNodeGroupAttribute groupUuid), QffNormal) |
112 |
] ++ |
113 |
|
114 |
-- Instance parameter fields, whole |
115 |
[ (FieldDefinition "hvparams" "HypervisorParameters" QFTOther |
116 |
"Hypervisor parameters (merged)", |
117 |
FieldConfig ((rsNormal .) . getFilledInstHvParams), QffNormal) |
118 |
, (FieldDefinition "beparams" "BackendParameters" QFTOther |
119 |
"Backend parameters (merged)", |
120 |
FieldConfig ((rsErrorNoData .) . getFilledInstBeParams), QffNormal) |
121 |
, (FieldDefinition "osparams" "OpSysParameters" QFTOther |
122 |
"Operating system parameters (merged)", |
123 |
FieldConfig ((rsNormal .) . getFilledInstOsParams), QffNormal) |
124 |
, (FieldDefinition "custom_hvparams" "CustomHypervisorParameters" QFTOther |
125 |
"Custom hypervisor parameters", |
126 |
FieldSimple (rsNormal . instHvparams), QffNormal) |
127 |
, (FieldDefinition "custom_beparams" "CustomBackendParameters" QFTOther |
128 |
"Custom backend parameters", |
129 |
FieldSimple (rsNormal . instBeparams), QffNormal) |
130 |
, (FieldDefinition "custom_osparams" "CustomOpSysParameters" QFTOther |
131 |
"Custom operating system parameters", |
132 |
FieldSimple (rsNormal . instOsparams), QffNormal) |
133 |
] ++ |
134 |
|
135 |
-- Instance parameter fields, generated |
136 |
map (buildBeParamField beParamGetter) allBeParamFields ++ |
137 |
map (buildHvParamField hvParamGetter) (C.toList C.hvsParameters) ++ |
138 |
|
139 |
-- Aggregate disk parameter fields |
140 |
[ (FieldDefinition "disk_usage" "DiskUsage" QFTUnit |
141 |
"Total disk space used by instance on each of its nodes; this is not the\ |
142 |
\ disk size visible to the instance, but the usage on the node", |
143 |
FieldSimple (rsNormal . getDiskSizeRequirements), QffNormal) |
144 |
, (FieldDefinition "disk.count" "Disks" QFTNumber |
145 |
"Number of disks", |
146 |
FieldSimple (rsNormal . length . instDisks), QffNormal) |
147 |
, (FieldDefinition "disk.sizes" "Disk_sizes" QFTOther |
148 |
"List of disk sizes", |
149 |
FieldSimple (rsNormal . map diskSize . instDisks), QffNormal) |
150 |
, (FieldDefinition "disk.spindles" "Disk_spindles" QFTOther |
151 |
"List of disk spindles", |
152 |
FieldSimple (rsNormal . map (MaybeForJSON . diskSpindles) . |
153 |
instDisks), |
154 |
QffNormal) |
155 |
, (FieldDefinition "disk.names" "Disk_names" QFTOther |
156 |
"List of disk names", |
157 |
FieldSimple (rsNormal . map (MaybeForJSON . diskName) . |
158 |
instDisks), |
159 |
QffNormal) |
160 |
, (FieldDefinition "disk.uuids" "Disk_UUIDs" QFTOther |
161 |
"List of disk UUIDs", |
162 |
FieldSimple (rsNormal . map diskUuid . instDisks), QffNormal) |
163 |
] ++ |
164 |
|
165 |
-- Per-disk parameter fields |
166 |
instantiateIndexedFields C.maxDisks |
167 |
[ (fieldDefinitionCompleter "disk.size/%d" "Disk/%d" QFTUnit |
168 |
"Disk size of %s disk", |
169 |
getIndexedField instDisks diskSize, QffNormal) |
170 |
, (fieldDefinitionCompleter "disk.spindles/%d" "DiskSpindles/%d" QFTNumber |
171 |
"Spindles of %s disk", |
172 |
getIndexedOptionalField instDisks diskSpindles, QffNormal) |
173 |
, (fieldDefinitionCompleter "disk.name/%d" "DiskName/%d" QFTText |
174 |
"Name of %s disk", |
175 |
getIndexedOptionalField instDisks diskName, QffNormal) |
176 |
, (fieldDefinitionCompleter "disk.uuid/%d" "DiskUUID/%d" QFTText |
177 |
"UUID of %s disk", |
178 |
getIndexedField instDisks diskUuid, QffNormal) |
179 |
] ++ |
180 |
|
181 |
-- Aggregate nic parameter fields |
182 |
[ (FieldDefinition "nic.count" "NICs" QFTNumber |
183 |
"Number of network interfaces", |
184 |
FieldSimple (rsNormal . length . instNics), QffNormal) |
185 |
, (FieldDefinition "nic.macs" "NIC_MACs" QFTOther |
186 |
(nicAggDescPrefix ++ "MAC address"), |
187 |
FieldSimple (rsNormal . map nicMac . instNics), QffNormal) |
188 |
, (FieldDefinition "nic.ips" "NIC_IPs" QFTOther |
189 |
(nicAggDescPrefix ++ "IP address"), |
190 |
FieldSimple (rsNormal . map (MaybeForJSON . nicIp) . instNics), |
191 |
QffNormal) |
192 |
, (FieldDefinition "nic.names" "NIC_Names" QFTOther |
193 |
(nicAggDescPrefix ++ "name"), |
194 |
FieldSimple (rsNormal . map (MaybeForJSON . nicName) . instNics), |
195 |
QffNormal) |
196 |
, (FieldDefinition "nic.uuids" "NIC_UUIDs" QFTOther |
197 |
(nicAggDescPrefix ++ "UUID"), |
198 |
FieldSimple (rsNormal . map nicUuid . instNics), QffNormal) |
199 |
, (FieldDefinition "nic.modes" "NIC_modes" QFTOther |
200 |
(nicAggDescPrefix ++ "mode"), |
201 |
FieldConfig (\cfg -> rsNormal . map |
202 |
(nicpMode . fillNicParamsFromConfig cfg . nicNicparams) |
203 |
. instNics), |
204 |
QffNormal) |
205 |
, (FieldDefinition "nic.bridges" "NIC_bridges" QFTOther |
206 |
(nicAggDescPrefix ++ "bridge"), |
207 |
FieldConfig (\cfg -> rsNormal . map (MaybeForJSON . getNicBridge . |
208 |
fillNicParamsFromConfig cfg . nicNicparams) . instNics), |
209 |
QffNormal) |
210 |
, (FieldDefinition "nic.links" "NIC_links" QFTOther |
211 |
(nicAggDescPrefix ++ "link"), |
212 |
FieldConfig (\cfg -> rsNormal . map |
213 |
(nicpLink . fillNicParamsFromConfig cfg . nicNicparams) |
214 |
. instNics), |
215 |
QffNormal) |
216 |
, (FieldDefinition "nic.networks" "NIC_networks" QFTOther |
217 |
"List containing each interface's network", |
218 |
FieldSimple (rsNormal . map (MaybeForJSON . nicNetwork) . instNics), |
219 |
QffNormal) |
220 |
, (FieldDefinition "nic.networks.names" "NIC_networks_names" QFTOther |
221 |
"List containing the name of each interface's network", |
222 |
FieldConfig (\cfg -> rsNormal . map |
223 |
(\x -> MaybeForJSON (getNetworkName cfg <$> nicNetwork x)) |
224 |
. instNics), |
225 |
QffNormal) |
226 |
] ++ |
227 |
|
228 |
-- Per-nic parameter fields |
229 |
instantiateIndexedFields C.maxNics |
230 |
[ (fieldDefinitionCompleter "nic.ip/%d" "NicIP/%d" QFTText |
231 |
("IP address" ++ nicDescSuffix), |
232 |
getIndexedOptionalField instNics nicIp, QffNormal) |
233 |
, (fieldDefinitionCompleter "nic.uuid/%d" "NicUUID/%d" QFTText |
234 |
("UUID address" ++ nicDescSuffix), |
235 |
getIndexedField instNics nicUuid, QffNormal) |
236 |
, (fieldDefinitionCompleter "nic.mac/%d" "NicMAC/%d" QFTText |
237 |
("MAC address" ++ nicDescSuffix), |
238 |
getIndexedField instNics nicMac, QffNormal) |
239 |
, (fieldDefinitionCompleter "nic.name/%d" "NicName/%d" QFTText |
240 |
("Name address" ++ nicDescSuffix), |
241 |
getIndexedOptionalField instNics nicName, QffNormal) |
242 |
, (fieldDefinitionCompleter "nic.network/%d" "NicNetwork/%d" QFTText |
243 |
("Network" ++ nicDescSuffix), |
244 |
getIndexedOptionalField instNics nicNetwork, QffNormal) |
245 |
, (fieldDefinitionCompleter "nic.mode/%d" "NicMode/%d" QFTText |
246 |
("Mode" ++ nicDescSuffix), |
247 |
getIndexedNicField nicpMode, QffNormal) |
248 |
, (fieldDefinitionCompleter "nic.link/%d" "NicLink/%d" QFTText |
249 |
("Link" ++ nicDescSuffix), |
250 |
getIndexedNicField nicpLink, QffNormal) |
251 |
, (fieldDefinitionCompleter "nic.network.name/%d" "NicNetworkName/%d" QFTText |
252 |
("Network name" ++ nicDescSuffix), |
253 |
getIndexedNicNetworkNameField, QffNormal) |
254 |
, (fieldDefinitionCompleter "nic.bridge/%d" "NicBridge/%d" QFTText |
255 |
("Bridge" ++ nicDescSuffix), |
256 |
getOptionalIndexedNicField getNicBridge, QffNormal) |
257 |
] ++ |
258 |
|
259 |
-- Live fields using special getters |
260 |
[ (FieldDefinition "status" "Status" QFTText |
261 |
statusDocText, |
262 |
FieldConfigRuntime statusExtract, QffNormal) |
263 |
, (FieldDefinition "oper_state" "Running" QFTBool |
264 |
"Actual state of instance", |
265 |
FieldRuntime operStatusExtract, QffNormal) |
266 |
] ++ |
267 |
|
268 |
-- Simple live fields |
269 |
map instanceLiveFieldBuilder instanceLiveFieldsDefs ++ |
270 |
|
271 |
-- Generated fields |
272 |
serialFields "Instance" ++ |
273 |
uuidFields "Instance" ++ |
274 |
tagsFields |
275 |
|
276 |
-- * Helper functions for node property retrieval |
277 |
|
278 |
-- | Constant suffix of network interface field descriptions. |
279 |
nicDescSuffix ::String |
280 |
nicDescSuffix = " of %s network interface" |
281 |
|
282 |
-- | Almost-constant suffix of aggregate network interface field descriptions. |
283 |
nicAggDescPrefix ::String |
284 |
nicAggDescPrefix = "List containing each network interface's " |
285 |
|
286 |
-- | Given a network name id, returns the network's name. |
287 |
getNetworkName :: ConfigData -> String -> NonEmptyString |
288 |
getNetworkName cfg = networkName . (Map.!) (fromContainer $ configNetworks cfg) |
289 |
|
290 |
-- | Gets the bridge of a NIC. |
291 |
getNicBridge :: FilledNicParams -> Maybe String |
292 |
getNicBridge nicParams |
293 |
| nicpMode nicParams == NMBridged = Just $ nicpLink nicParams |
294 |
| otherwise = Nothing |
295 |
|
296 |
-- | Fill partial NIC params by using the defaults from the configuration. |
297 |
fillNicParamsFromConfig :: ConfigData -> PartialNicParams -> FilledNicParams |
298 |
fillNicParamsFromConfig cfg = fillNicParams (getDefaultNicParams cfg) |
299 |
|
300 |
-- | Retrieves the default network interface parameters. |
301 |
getDefaultNicParams :: ConfigData -> FilledNicParams |
302 |
getDefaultNicParams cfg = |
303 |
(Map.!) (fromContainer . clusterNicparams . configCluster $ cfg) C.ppDefault |
304 |
|
305 |
-- | Returns a field that retrieves a given NIC's network name. |
306 |
getIndexedNicNetworkNameField :: Int -> FieldGetter Instance Runtime |
307 |
getIndexedNicNetworkNameField index = |
308 |
FieldConfig (\cfg inst -> rsMaybeUnavail $ do |
309 |
nicObj <- maybeAt index $ instNics inst |
310 |
nicNetworkId <- nicNetwork nicObj |
311 |
return $ getNetworkName cfg nicNetworkId) |
312 |
|
313 |
-- | Gets a fillable NIC field. |
314 |
getIndexedNicField :: (J.JSON a) |
315 |
=> (FilledNicParams -> a) |
316 |
-> Int |
317 |
-> FieldGetter Instance Runtime |
318 |
getIndexedNicField getter = |
319 |
getOptionalIndexedNicField (\x -> Just . getter $ x) |
320 |
|
321 |
-- | Gets an optional fillable NIC field. |
322 |
getOptionalIndexedNicField :: (J.JSON a) |
323 |
=> (FilledNicParams -> Maybe a) |
324 |
-> Int |
325 |
-> FieldGetter Instance Runtime |
326 |
getOptionalIndexedNicField = |
327 |
getIndexedFieldWithDefault |
328 |
(map nicNicparams . instNics) (\x _ -> getDefaultNicParams x) fillNicParams |
329 |
|
330 |
-- | Creates a function which produces a 'FieldGetter' when fed an index. Works |
331 |
-- for fields that should be filled out through the use of a default. |
332 |
getIndexedFieldWithDefault :: (J.JSON c) |
333 |
=> (Instance -> [a]) -- ^ Extracts a list of incomplete objects |
334 |
-> (ConfigData -> Instance -> b) -- ^ Extracts the default object |
335 |
-> (b -> a -> b) -- ^ Fills the default object |
336 |
-> (b -> Maybe c) -- ^ Extracts an obj property |
337 |
-> Int -- ^ Index in list to use |
338 |
-> FieldGetter Instance Runtime -- ^ Result |
339 |
getIndexedFieldWithDefault |
340 |
listGetter defaultGetter fillFn propertyGetter index = |
341 |
FieldConfig (\cfg inst -> rsMaybeUnavail $ do |
342 |
incompleteObj <- maybeAt index $ listGetter inst |
343 |
let defaultObj = defaultGetter cfg inst |
344 |
completeObj = fillFn defaultObj incompleteObj |
345 |
propertyGetter completeObj) |
346 |
|
347 |
-- | Creates a function which produces a 'FieldGetter' when fed an index. Works |
348 |
-- for fields that may not return a value, expressed through the Maybe monad. |
349 |
getIndexedOptionalField :: (J.JSON b) |
350 |
=> (Instance -> [a]) -- ^ Extracts a list of objects |
351 |
-> (a -> Maybe b) -- ^ Possibly gets a property |
352 |
-- from an object |
353 |
-> Int -- ^ Index in list to use |
354 |
-> FieldGetter Instance Runtime -- ^ Result |
355 |
getIndexedOptionalField extractor optPropertyGetter index = |
356 |
FieldSimple(\inst -> rsMaybeUnavail $ do |
357 |
obj <- maybeAt index $ extractor inst |
358 |
optPropertyGetter obj) |
359 |
|
360 |
-- | Creates a function which produces a 'FieldGetter' when fed an index. |
361 |
-- Works only for fields that surely return a value. |
362 |
getIndexedField :: (J.JSON b) |
363 |
=> (Instance -> [a]) -- ^ Extracts a list of objects |
364 |
-> (a -> b) -- ^ Gets a property from an object |
365 |
-> Int -- ^ Index in list to use |
366 |
-> FieldGetter Instance Runtime -- ^ Result |
367 |
getIndexedField extractor propertyGetter index = |
368 |
let optPropertyGetter = Just . propertyGetter |
369 |
in getIndexedOptionalField extractor optPropertyGetter index |
370 |
|
371 |
-- | Retrieves a value from an array at an index, using the Maybe monad to |
372 |
-- indicate failure. |
373 |
maybeAt :: Int -> [a] -> Maybe a |
374 |
maybeAt index list |
375 |
| index >= length list = Nothing |
376 |
| otherwise = Just $ list !! index |
377 |
|
378 |
-- | Primed with format strings for everything but the type, it consumes two |
379 |
-- values and uses them to complete the FieldDefinition. |
380 |
-- Warning: a bit unsafe as it uses printf. Handle with care. |
381 |
fieldDefinitionCompleter :: (PrintfArg t1) => (PrintfArg t2) |
382 |
=> FieldName |
383 |
-> FieldTitle |
384 |
-> FieldType |
385 |
-> FieldDoc |
386 |
-> t1 |
387 |
-> t2 |
388 |
-> FieldDefinition |
389 |
fieldDefinitionCompleter fName fTitle fType fDoc firstVal secondVal = |
390 |
FieldDefinition (printf fName firstVal) |
391 |
(printf fTitle firstVal) |
392 |
fType |
393 |
(printf fDoc secondVal) |
394 |
|
395 |
-- | Given an incomplete field definition and values that can complete it, |
396 |
-- return a fully functional FieldData. Cannot work for all cases, should be |
397 |
-- extended as necessary. |
398 |
fillIncompleteFields :: (t1 -> t2 -> FieldDefinition, |
399 |
t1 -> FieldGetter a b, |
400 |
QffMode) |
401 |
-> t1 |
402 |
-> t2 |
403 |
-> FieldData a b |
404 |
fillIncompleteFields (iDef, iGet, mode) firstVal secondVal = |
405 |
(iDef firstVal secondVal, iGet firstVal, mode) |
406 |
|
407 |
-- | Given indexed fields that describe lists, complete / instantiate them for |
408 |
-- a given list size. |
409 |
instantiateIndexedFields :: (Show t1, Integral t1) |
410 |
=> Int -- ^ The size of the list |
411 |
-> [(t1 -> String -> FieldDefinition, |
412 |
t1 -> FieldGetter a b, |
413 |
QffMode)] -- ^ The indexed fields |
414 |
-> FieldList a b -- ^ A list of complete fields |
415 |
instantiateIndexedFields listSize fields = do |
416 |
index <- take listSize [0..] |
417 |
field <- fields |
418 |
return . fillIncompleteFields field index . formatOrdinal $ index + 1 |
419 |
|
420 |
-- * Various helper functions for property retrieval |
421 |
|
422 |
-- | Helper function for primary node retrieval |
423 |
getPrimaryNode :: ConfigData -> Instance -> ErrorResult Node |
424 |
getPrimaryNode cfg = getInstPrimaryNode cfg . instName |
425 |
|
426 |
-- | Get primary node hostname |
427 |
getPrimaryNodeName :: ConfigData -> Instance -> ResultEntry |
428 |
getPrimaryNodeName cfg inst = |
429 |
rsErrorNoData $ nodeName <$> getPrimaryNode cfg inst |
430 |
|
431 |
-- | Get primary node hostname |
432 |
getPrimaryNodeGroup :: ConfigData -> Instance -> ResultEntry |
433 |
getPrimaryNodeGroup cfg inst = |
434 |
rsErrorNoData $ (J.showJSON . groupName) <$> |
435 |
(getPrimaryNode cfg inst >>= |
436 |
maybeToError "Configuration missing" . getGroupOfNode cfg) |
437 |
|
438 |
-- | Get secondary nodes - the configuration objects themselves |
439 |
getSecondaryNodes :: ConfigData -> Instance -> ErrorResult [Node] |
440 |
getSecondaryNodes cfg inst = do |
441 |
pNode <- getPrimaryNode cfg inst |
442 |
allNodes <- getInstAllNodes cfg $ instName inst |
443 |
return $ delete pNode allNodes |
444 |
|
445 |
-- | Get attributes of the secondary nodes |
446 |
getSecondaryNodeAttribute :: (J.JSON a) |
447 |
=> (Node -> a) |
448 |
-> ConfigData |
449 |
-> Instance |
450 |
-> ResultEntry |
451 |
getSecondaryNodeAttribute getter cfg inst = |
452 |
rsErrorNoData $ map (J.showJSON . getter) <$> getSecondaryNodes cfg inst |
453 |
|
454 |
-- | Get secondary node groups |
455 |
getSecondaryNodeGroups :: ConfigData -> Instance -> ErrorResult [NodeGroup] |
456 |
getSecondaryNodeGroups cfg inst = do |
457 |
sNodes <- getSecondaryNodes cfg inst |
458 |
return . catMaybes $ map (getGroupOfNode cfg) sNodes |
459 |
|
460 |
-- | Get attributes of secondary node groups |
461 |
getSecondaryNodeGroupAttribute :: (J.JSON a) |
462 |
=> (NodeGroup -> a) |
463 |
-> ConfigData |
464 |
-> Instance |
465 |
-> ResultEntry |
466 |
getSecondaryNodeGroupAttribute getter cfg inst = |
467 |
rsErrorNoData $ map (J.showJSON . getter) <$> getSecondaryNodeGroups cfg inst |
468 |
|
469 |
-- | Beparam getter builder: given a field, it returns a FieldConfig |
470 |
-- getter, that is a function that takes the config and the object and |
471 |
-- returns the Beparam field specified when the getter was built. |
472 |
beParamGetter :: String -- ^ The field we are building the getter for |
473 |
-> ConfigData -- ^ The configuration object |
474 |
-> Instance -- ^ The instance configuration object |
475 |
-> ResultEntry -- ^ The result |
476 |
beParamGetter field config inst = |
477 |
case getFilledInstBeParams config inst of |
478 |
Ok beParams -> dictFieldGetter field $ Just beParams |
479 |
Bad _ -> rsNoData |
480 |
|
481 |
-- | Hvparam getter builder: given a field, it returns a FieldConfig |
482 |
-- getter, that is a function that takes the config and the object and |
483 |
-- returns the Hvparam field specified when the getter was built. |
484 |
hvParamGetter :: String -- ^ The field we're building the getter for |
485 |
-> ConfigData -> Instance -> ResultEntry |
486 |
hvParamGetter field cfg inst = |
487 |
rsMaybeUnavail . Map.lookup field . fromContainer $ |
488 |
getFilledInstHvParams cfg inst |
489 |
|
490 |
-- * Live fields functionality |
491 |
|
492 |
-- | List of node live fields. |
493 |
instanceLiveFieldsDefs :: [(FieldName, FieldTitle, FieldType, String, FieldDoc)] |
494 |
instanceLiveFieldsDefs = |
495 |
[ ("oper_ram", "Memory", QFTUnit, "oper_ram", |
496 |
"Actual memory usage as seen by hypervisor") |
497 |
, ("oper_vcpus", "VCPUs", QFTNumber, "oper_vcpus", |
498 |
"Actual number of VCPUs as seen by hypervisor") |
499 |
] |
500 |
|
501 |
-- | Map each name to a function that extracts that value from the RPC result. |
502 |
instanceLiveFieldExtract :: FieldName -> InstanceInfo -> Instance -> J.JSValue |
503 |
instanceLiveFieldExtract "oper_ram" info _ = J.showJSON $ instInfoMemory info |
504 |
instanceLiveFieldExtract "oper_vcpus" info _ = J.showJSON $ instInfoVcpus info |
505 |
instanceLiveFieldExtract n _ _ = J.showJSON $ |
506 |
"The field " ++ n ++ " is not an expected or extractable live field!" |
507 |
|
508 |
-- | Helper for extracting field from RPC result. |
509 |
instanceLiveRpcCall :: FieldName -> Runtime -> Instance -> ResultEntry |
510 |
instanceLiveRpcCall fname (Right (Just (res, _))) inst = |
511 |
case instanceLiveFieldExtract fname res inst of |
512 |
J.JSNull -> rsNoData |
513 |
x -> rsNormal x |
514 |
instanceLiveRpcCall _ (Right Nothing) _ = rsUnavail |
515 |
instanceLiveRpcCall _ (Left err) _ = |
516 |
ResultEntry (rpcErrorToStatus err) Nothing |
517 |
|
518 |
-- | Builder for node live fields. |
519 |
instanceLiveFieldBuilder :: (FieldName, FieldTitle, FieldType, String, FieldDoc) |
520 |
-> FieldData Instance Runtime |
521 |
instanceLiveFieldBuilder (fname, ftitle, ftype, _, fdoc) = |
522 |
( FieldDefinition fname ftitle ftype fdoc |
523 |
, FieldRuntime $ instanceLiveRpcCall fname |
524 |
, QffNormal) |
525 |
|
526 |
-- * Functionality related to status and operational status extraction |
527 |
|
528 |
-- | The documentation text for the instance status field |
529 |
statusDocText :: String |
530 |
statusDocText = |
531 |
let si = show . instanceStatusToRaw :: InstanceStatus -> String |
532 |
in "Instance status; " ++ |
533 |
si Running ++ |
534 |
" if instance is set to be running and actually is, " ++ |
535 |
si StatusDown ++ |
536 |
" if instance is stopped and is not running, " ++ |
537 |
si WrongNode ++ |
538 |
" if instance running, but not on its designated primary node, " ++ |
539 |
si ErrorUp ++ |
540 |
" if instance should be stopped, but is actually running, " ++ |
541 |
si ErrorDown ++ |
542 |
" if instance should run, but doesn't, " ++ |
543 |
si NodeDown ++ |
544 |
" if instance's primary node is down, " ++ |
545 |
si NodeOffline ++ |
546 |
" if instance's primary node is marked offline, " ++ |
547 |
si StatusOffline ++ |
548 |
" if instance is offline and does not use dynamic resources" |
549 |
|
550 |
-- | Checks if the primary node of an instance is offline |
551 |
isPrimaryOffline :: ConfigData -> Instance -> Bool |
552 |
isPrimaryOffline cfg inst = |
553 |
let pNodeResult = getNode cfg $ instPrimaryNode inst |
554 |
in case pNodeResult of |
555 |
Ok pNode -> nodeOffline pNode |
556 |
Bad _ -> error "Programmer error - result assumed to be OK is Bad!" |
557 |
|
558 |
-- | Determines the status of a live instance |
559 |
liveInstanceStatus :: LiveInfo -> Instance -> InstanceStatus |
560 |
liveInstanceStatus (_, foundOnPrimary) inst |
561 |
| not foundOnPrimary = WrongNode |
562 |
| adminState == AdminUp = Running |
563 |
| otherwise = ErrorUp |
564 |
where adminState = instAdminState inst |
565 |
|
566 |
-- | Determines the status of a dead instance. |
567 |
deadInstanceStatus :: Instance -> InstanceStatus |
568 |
deadInstanceStatus inst = |
569 |
case instAdminState inst of |
570 |
AdminUp -> ErrorDown |
571 |
AdminDown -> StatusDown |
572 |
AdminOffline -> StatusOffline |
573 |
|
574 |
-- | Determines the status of the instance, depending on whether it is possible |
575 |
-- to communicate with its primary node, on which node it is, and its |
576 |
-- configuration. |
577 |
determineInstanceStatus :: ConfigData -- ^ The configuration data |
578 |
-> Runtime -- ^ All the data from the live call |
579 |
-> Instance -- ^ Static instance configuration |
580 |
-> InstanceStatus -- ^ Result |
581 |
determineInstanceStatus cfg res inst |
582 |
| isPrimaryOffline cfg inst = NodeOffline |
583 |
| otherwise = case res of |
584 |
Left _ -> NodeDown |
585 |
Right (Just liveData) -> liveInstanceStatus liveData inst |
586 |
Right Nothing -> deadInstanceStatus inst |
587 |
|
588 |
-- | Extracts the instance status, retrieving it using the functions above and |
589 |
-- transforming it into a 'ResultEntry'. |
590 |
statusExtract :: ConfigData -> Runtime -> Instance -> ResultEntry |
591 |
statusExtract cfg res inst = |
592 |
rsNormal . J.showJSON . instanceStatusToRaw $ |
593 |
determineInstanceStatus cfg res inst |
594 |
|
595 |
-- | Extracts the operational status of the instance. |
596 |
operStatusExtract :: Runtime -> Instance -> ResultEntry |
597 |
operStatusExtract res _ = |
598 |
rsMaybeNoData $ J.showJSON <$> |
599 |
case res of |
600 |
Left _ -> Nothing |
601 |
Right x -> Just $ isJust x |
602 |
|
603 |
-- * Helper functions extracting information as necessary for the generic query |
604 |
-- interfaces |
605 |
|
606 |
-- | Finds information about the instance in the info delivered by a node |
607 |
findInstanceInfo :: Instance |
608 |
-> ERpcError RpcResultAllInstancesInfo |
609 |
-> Maybe InstanceInfo |
610 |
findInstanceInfo inst nodeResponse = |
611 |
case nodeResponse of |
612 |
Left _err -> Nothing |
613 |
Right allInfo -> |
614 |
let instances = rpcResAllInstInfoInstances allInfo |
615 |
maybeMatch = pickPairUnique (instName inst) instances |
616 |
in snd <$> maybeMatch |
617 |
|
618 |
-- | Finds the node information ('RPCResultError') or the instance information |
619 |
-- (Maybe 'LiveInfo'). |
620 |
extractLiveInfo :: [(Node, ERpcError RpcResultAllInstancesInfo)] |
621 |
-> Instance |
622 |
-> Runtime |
623 |
extractLiveInfo nodeResultList inst = |
624 |
let uuidResultList = [(nodeUuid x, y) | (x, y) <- nodeResultList] |
625 |
pNodeUuid = instPrimaryNode inst |
626 |
maybeRPCError = getNodeStatus uuidResultList pNodeUuid |
627 |
in case maybeRPCError of |
628 |
Just err -> Left err |
629 |
Nothing -> Right $ getInstanceStatus uuidResultList pNodeUuid inst |
630 |
|
631 |
-- | Tries to find out if the node given by the uuid is bad - unreachable or |
632 |
-- returning errors, does not mather for the purpose of this call. |
633 |
getNodeStatus :: [(String, ERpcError RpcResultAllInstancesInfo)] |
634 |
-> String |
635 |
-> Maybe RpcError |
636 |
getNodeStatus uuidList uuid = |
637 |
case snd <$> pickPairUnique uuid uuidList of |
638 |
Just (Left err) -> Just err |
639 |
Just (Right _) -> Nothing |
640 |
Nothing -> Just . RpcResultError $ |
641 |
"Primary node response not present" |
642 |
|
643 |
-- | Retrieves the instance information if it is present anywhere in the all |
644 |
-- instances RPC result. Notes if it originates from the primary node. |
645 |
-- All nodes are represented as UUID's for ease of use. |
646 |
getInstanceStatus :: [(String, ERpcError RpcResultAllInstancesInfo)] |
647 |
-> String |
648 |
-> Instance |
649 |
-> Maybe LiveInfo |
650 |
getInstanceStatus uuidList pNodeUuid inst = |
651 |
let primarySearchResult = |
652 |
snd <$> pickPairUnique pNodeUuid uuidList >>= findInstanceInfo inst |
653 |
in case primarySearchResult of |
654 |
Just instInfo -> Just (instInfo, True) |
655 |
Nothing -> |
656 |
let allSearchResult = |
657 |
getFirst . mconcat $ map |
658 |
(First . findInstanceInfo inst . snd) uuidList |
659 |
in case allSearchResult of |
660 |
Just liveInfo -> Just (liveInfo, False) |
661 |
Nothing -> Nothing |
662 |
|
663 |
-- | Collect live data from RPC query if enabled. |
664 |
collectLiveData :: Bool -> ConfigData -> [Instance] -> IO [(Instance, Runtime)] |
665 |
collectLiveData liveDataEnabled cfg instances |
666 |
| not liveDataEnabled = return . zip instances . repeat . Left . |
667 |
RpcResultError $ "Live data disabled" |
668 |
| otherwise = do |
669 |
let hvSpec = getDefaultHypervisorSpec cfg |
670 |
instance_nodes = nub . justOk $ |
671 |
map (getNode cfg . instPrimaryNode) instances |
672 |
good_nodes = nodesWithValidConfig cfg instance_nodes |
673 |
rpcres <- executeRpcCall good_nodes $ RpcCallAllInstancesInfo [hvSpec] |
674 |
return . zip instances . map (extractLiveInfo rpcres) $ instances |