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