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