root / src / Ganeti / Query / Instance.hs @ 14fff9f2
History | View | Annotate | Download (36.8 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 = fieldListToFieldMap 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 |
FieldConfig 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 |
FieldConfig getDiskSizes, QffNormal) |
187 |
, (FieldDefinition "disk.spindles" "Disk_spindles" QFTOther |
188 |
"List of disk spindles", |
189 |
FieldConfig getDiskSpindles, QffNormal) |
190 |
, (FieldDefinition "disk.names" "Disk_names" QFTOther |
191 |
"List of disk names", |
192 |
FieldConfig getDiskNames, QffNormal) |
193 |
, (FieldDefinition "disk.uuids" "Disk_UUIDs" QFTOther |
194 |
"List of disk UUIDs", |
195 |
FieldConfig getDiskUuids, QffNormal) |
196 |
] ++ |
197 |
|
198 |
-- Per-disk parameter fields |
199 |
instantiateIndexedFields C.maxDisks |
200 |
[ (fieldDefinitionCompleter "disk.size/%d" "Disk/%d" QFTUnit |
201 |
"Disk size of %s disk", |
202 |
getIndexedConfField getInstDisks diskSize, QffNormal) |
203 |
, (fieldDefinitionCompleter "disk.spindles/%d" "DiskSpindles/%d" QFTNumber |
204 |
"Spindles of %s disk", |
205 |
getIndexedOptionalConfField getInstDisks diskSpindles, QffNormal) |
206 |
, (fieldDefinitionCompleter "disk.name/%d" "DiskName/%d" QFTText |
207 |
"Name of %s disk", |
208 |
getIndexedOptionalConfField getInstDisks diskName, QffNormal) |
209 |
, (fieldDefinitionCompleter "disk.uuid/%d" "DiskUUID/%d" QFTText |
210 |
"UUID of %s disk", |
211 |
getIndexedConfField getInstDisks diskUuid, QffNormal) |
212 |
] ++ |
213 |
|
214 |
-- Aggregate nic parameter fields |
215 |
[ (FieldDefinition "nic.count" "NICs" QFTNumber |
216 |
"Number of network interfaces", |
217 |
FieldSimple (rsNormal . length . instNics), QffNormal) |
218 |
, (FieldDefinition "nic.macs" "NIC_MACs" QFTOther |
219 |
(nicAggDescPrefix ++ "MAC address"), |
220 |
FieldSimple (rsNormal . map nicMac . instNics), QffNormal) |
221 |
, (FieldDefinition "nic.ips" "NIC_IPs" QFTOther |
222 |
(nicAggDescPrefix ++ "IP address"), |
223 |
FieldSimple (rsNormal . map (MaybeForJSON . nicIp) . instNics), |
224 |
QffNormal) |
225 |
, (FieldDefinition "nic.names" "NIC_Names" QFTOther |
226 |
(nicAggDescPrefix ++ "name"), |
227 |
FieldSimple (rsNormal . map (MaybeForJSON . nicName) . instNics), |
228 |
QffNormal) |
229 |
, (FieldDefinition "nic.uuids" "NIC_UUIDs" QFTOther |
230 |
(nicAggDescPrefix ++ "UUID"), |
231 |
FieldSimple (rsNormal . map nicUuid . instNics), QffNormal) |
232 |
, (FieldDefinition "nic.modes" "NIC_modes" QFTOther |
233 |
(nicAggDescPrefix ++ "mode"), |
234 |
FieldConfig (\cfg -> rsNormal . map |
235 |
(nicpMode . fillNicParamsFromConfig cfg . nicNicparams) |
236 |
. instNics), |
237 |
QffNormal) |
238 |
, (FieldDefinition "nic.vlans" "NIC_VLANs" QFTOther |
239 |
(nicAggDescPrefix ++ "VLAN"), |
240 |
FieldConfig (\cfg -> rsNormal . map (MaybeForJSON . getNicVlan . |
241 |
fillNicParamsFromConfig cfg . nicNicparams) . instNics), |
242 |
QffNormal) |
243 |
, (FieldDefinition "nic.bridges" "NIC_bridges" QFTOther |
244 |
(nicAggDescPrefix ++ "bridge"), |
245 |
FieldConfig (\cfg -> rsNormal . map (MaybeForJSON . getNicBridge . |
246 |
fillNicParamsFromConfig cfg . nicNicparams) . instNics), |
247 |
QffNormal) |
248 |
, (FieldDefinition "nic.links" "NIC_links" QFTOther |
249 |
(nicAggDescPrefix ++ "link"), |
250 |
FieldConfig (\cfg -> rsNormal . map |
251 |
(nicpLink . fillNicParamsFromConfig cfg . nicNicparams) |
252 |
. instNics), |
253 |
QffNormal) |
254 |
, (FieldDefinition "nic.networks" "NIC_networks" QFTOther |
255 |
"List containing each interface's network", |
256 |
FieldSimple (rsNormal . map (MaybeForJSON . nicNetwork) . instNics), |
257 |
QffNormal) |
258 |
, (FieldDefinition "nic.networks.names" "NIC_networks_names" QFTOther |
259 |
"List containing the name of each interface's network", |
260 |
FieldConfig (\cfg -> rsNormal . map |
261 |
(\x -> MaybeForJSON (getNetworkName cfg <$> nicNetwork x)) |
262 |
. instNics), |
263 |
QffNormal) |
264 |
] ++ |
265 |
|
266 |
-- Per-nic parameter fields |
267 |
instantiateIndexedFields C.maxNics |
268 |
[ (fieldDefinitionCompleter "nic.ip/%d" "NicIP/%d" QFTText |
269 |
("IP address" ++ nicDescSuffix), |
270 |
getIndexedOptionalField instNics nicIp, QffNormal) |
271 |
, (fieldDefinitionCompleter "nic.uuid/%d" "NicUUID/%d" QFTText |
272 |
("UUID address" ++ nicDescSuffix), |
273 |
getIndexedField instNics nicUuid, QffNormal) |
274 |
, (fieldDefinitionCompleter "nic.mac/%d" "NicMAC/%d" QFTText |
275 |
("MAC address" ++ nicDescSuffix), |
276 |
getIndexedField instNics nicMac, QffNormal) |
277 |
, (fieldDefinitionCompleter "nic.name/%d" "NicName/%d" QFTText |
278 |
("Name address" ++ nicDescSuffix), |
279 |
getIndexedOptionalField instNics nicName, QffNormal) |
280 |
, (fieldDefinitionCompleter "nic.network/%d" "NicNetwork/%d" QFTText |
281 |
("Network" ++ nicDescSuffix), |
282 |
getIndexedOptionalField instNics nicNetwork, QffNormal) |
283 |
, (fieldDefinitionCompleter "nic.mode/%d" "NicMode/%d" QFTText |
284 |
("Mode" ++ nicDescSuffix), |
285 |
getIndexedNicField nicpMode, QffNormal) |
286 |
, (fieldDefinitionCompleter "nic.link/%d" "NicLink/%d" QFTText |
287 |
("Link" ++ nicDescSuffix), |
288 |
getIndexedNicField nicpLink, QffNormal) |
289 |
, (fieldDefinitionCompleter "nic.vlan/%d" "NicVLAN/%d" QFTText |
290 |
("VLAN" ++ nicDescSuffix), |
291 |
getOptionalIndexedNicField getNicVlan, QffNormal) |
292 |
, (fieldDefinitionCompleter "nic.network.name/%d" "NicNetworkName/%d" QFTText |
293 |
("Network name" ++ nicDescSuffix), |
294 |
getIndexedNicNetworkNameField, QffNormal) |
295 |
, (fieldDefinitionCompleter "nic.bridge/%d" "NicBridge/%d" QFTText |
296 |
("Bridge" ++ nicDescSuffix), |
297 |
getOptionalIndexedNicField getNicBridge, QffNormal) |
298 |
] ++ |
299 |
|
300 |
-- Live fields using special getters |
301 |
[ (FieldDefinition "status" "Status" QFTText |
302 |
statusDocText, |
303 |
FieldConfigRuntime statusExtract, QffNormal) |
304 |
, (FieldDefinition "oper_state" "Running" QFTBool |
305 |
"Actual state of instance", |
306 |
FieldRuntime operStatusExtract, QffNormal), |
307 |
|
308 |
(FieldDefinition "console" "Console" QFTOther |
309 |
"Instance console information", |
310 |
FieldRuntime consoleExtract, QffNormal) |
311 |
] ++ |
312 |
|
313 |
-- Simple live fields |
314 |
map instanceLiveFieldBuilder instanceLiveFieldsDefs ++ |
315 |
|
316 |
-- Common fields |
317 |
timeStampFields ++ |
318 |
serialFields "Instance" ++ |
319 |
uuidFields "Instance" ++ |
320 |
tagsFields |
321 |
|
322 |
-- * Helper functions for node property retrieval |
323 |
|
324 |
-- | Constant suffix of network interface field descriptions. |
325 |
nicDescSuffix ::String |
326 |
nicDescSuffix = " of %s network interface" |
327 |
|
328 |
-- | Almost-constant suffix of aggregate network interface field descriptions. |
329 |
nicAggDescPrefix ::String |
330 |
nicAggDescPrefix = "List containing each network interface's " |
331 |
|
332 |
-- | Given a network name id, returns the network's name. |
333 |
getNetworkName :: ConfigData -> String -> NonEmptyString |
334 |
getNetworkName cfg = networkName . (Map.!) (fromContainer $ configNetworks cfg) |
335 |
|
336 |
-- | Gets the bridge of a NIC. |
337 |
getNicBridge :: FilledNicParams -> Maybe String |
338 |
getNicBridge nicParams |
339 |
| nicpMode nicParams == NMBridged = Just $ nicpLink nicParams |
340 |
| otherwise = Nothing |
341 |
|
342 |
-- | Gets the VLAN of a NIC. |
343 |
getNicVlan :: FilledNicParams -> Maybe String |
344 |
getNicVlan params |
345 |
| nicpMode params == NMOvs = Just $ nicpVlan params |
346 |
| otherwise = Nothing |
347 |
|
348 |
-- | Fill partial NIC params by using the defaults from the configuration. |
349 |
fillNicParamsFromConfig :: ConfigData -> PartialNicParams -> FilledNicParams |
350 |
fillNicParamsFromConfig cfg = fillNicParams (getDefaultNicParams cfg) |
351 |
|
352 |
-- | Retrieves the default network interface parameters. |
353 |
getDefaultNicParams :: ConfigData -> FilledNicParams |
354 |
getDefaultNicParams cfg = |
355 |
(Map.!) (fromContainer . clusterNicparams . configCluster $ cfg) C.ppDefault |
356 |
|
357 |
-- | Retrieves the real disk size requirements for all the disks of the |
358 |
-- instance. This includes the metadata etc. and is different from the values |
359 |
-- visible to the instance. |
360 |
getDiskSizeRequirements :: ConfigData -> Instance -> ResultEntry |
361 |
getDiskSizeRequirements cfg inst = |
362 |
rsErrorNoData . liftA (sum . map getSizes) . getInstDisks cfg $ inst |
363 |
where |
364 |
getSizes :: Disk -> Int |
365 |
getSizes disk = |
366 |
case instDiskTemplate inst of |
367 |
DTDrbd8 -> diskSize disk + C.drbdMetaSize |
368 |
DTDiskless -> 0 |
369 |
DTBlock -> 0 |
370 |
_ -> diskSize disk |
371 |
|
372 |
-- | Get a list of disk sizes for an instance |
373 |
getDiskSizes :: ConfigData -> Instance -> ResultEntry |
374 |
getDiskSizes cfg = |
375 |
rsErrorNoData . liftA (map diskSize) . getInstDisks cfg |
376 |
|
377 |
-- | Get a list of disk spindles |
378 |
getDiskSpindles :: ConfigData -> Instance -> ResultEntry |
379 |
getDiskSpindles cfg = |
380 |
rsErrorNoData . liftA (map (MaybeForJSON . diskSpindles)) . getInstDisks cfg |
381 |
|
382 |
-- | Get a list of disk names for an instance |
383 |
getDiskNames :: ConfigData -> Instance -> ResultEntry |
384 |
getDiskNames cfg = |
385 |
rsErrorNoData . liftA (map (MaybeForJSON . diskName)) . getInstDisks cfg |
386 |
|
387 |
-- | Get a list of disk UUIDs for an instance |
388 |
getDiskUuids :: ConfigData -> Instance -> ResultEntry |
389 |
getDiskUuids cfg = |
390 |
rsErrorNoData . liftA (map diskUuid) . getInstDisks cfg |
391 |
|
392 |
-- | Creates a functions which produces a FieldConfig 'FieldGetter' when fed |
393 |
-- an index. Works for fields that may not return a value, expressed through |
394 |
-- the Maybe monad. |
395 |
getIndexedOptionalConfField :: (J.JSON b) |
396 |
-- | Extracts a list of objects |
397 |
=> (ConfigData -> Instance -> ErrorResult [a]) |
398 |
-> (a -> Maybe b) -- ^ Possibly gets a property |
399 |
-- from an object |
400 |
-> Int -- ^ Index in list to use |
401 |
-> FieldGetter Instance Runtime -- ^ Result |
402 |
getIndexedOptionalConfField extractor optPropertyGetter index = |
403 |
let getProperty x = maybeAt index x >>= optPropertyGetter |
404 |
in FieldConfig (\cfg -> |
405 |
rsErrorMaybeUnavail . liftA getProperty . extractor cfg) |
406 |
|
407 |
-- | Creates a function which produces a FieldConfig 'FieldGetter' when fed |
408 |
-- an index. Works only for fields that surely return a value. |
409 |
getIndexedConfField :: (J.JSON b) |
410 |
-- | Extracts a list of objects |
411 |
=> (ConfigData -> Instance -> ErrorResult [a]) |
412 |
-> (a -> b) -- ^ Gets a property from an object |
413 |
-> Int -- ^ Index in list to use |
414 |
-> FieldGetter Instance Runtime -- ^ Result |
415 |
getIndexedConfField extractor propertyGetter index = |
416 |
let optPropertyGetter = Just . propertyGetter |
417 |
in getIndexedOptionalConfField extractor optPropertyGetter index |
418 |
|
419 |
-- | Returns a field that retrieves a given NIC's network name. |
420 |
getIndexedNicNetworkNameField :: Int -> FieldGetter Instance Runtime |
421 |
getIndexedNicNetworkNameField index = |
422 |
FieldConfig (\cfg inst -> rsMaybeUnavail $ do |
423 |
nicObj <- maybeAt index $ instNics inst |
424 |
nicNetworkId <- nicNetwork nicObj |
425 |
return $ getNetworkName cfg nicNetworkId) |
426 |
|
427 |
-- | Gets a fillable NIC field. |
428 |
getIndexedNicField :: (J.JSON a) |
429 |
=> (FilledNicParams -> a) |
430 |
-> Int |
431 |
-> FieldGetter Instance Runtime |
432 |
getIndexedNicField getter = |
433 |
getOptionalIndexedNicField (\x -> Just . getter $ x) |
434 |
|
435 |
-- | Gets an optional fillable NIC field. |
436 |
getOptionalIndexedNicField :: (J.JSON a) |
437 |
=> (FilledNicParams -> Maybe a) |
438 |
-> Int |
439 |
-> FieldGetter Instance Runtime |
440 |
getOptionalIndexedNicField = |
441 |
getIndexedFieldWithDefault |
442 |
(map nicNicparams . instNics) (\x _ -> getDefaultNicParams x) fillNicParams |
443 |
|
444 |
-- | Creates a function which produces a 'FieldGetter' when fed an index. Works |
445 |
-- for fields that should be filled out through the use of a default. |
446 |
getIndexedFieldWithDefault :: (J.JSON c) |
447 |
=> (Instance -> [a]) -- ^ Extracts a list of incomplete objects |
448 |
-> (ConfigData -> Instance -> b) -- ^ Extracts the default object |
449 |
-> (b -> a -> b) -- ^ Fills the default object |
450 |
-> (b -> Maybe c) -- ^ Extracts an obj property |
451 |
-> Int -- ^ Index in list to use |
452 |
-> FieldGetter Instance Runtime -- ^ Result |
453 |
getIndexedFieldWithDefault |
454 |
listGetter defaultGetter fillFn propertyGetter index = |
455 |
FieldConfig (\cfg inst -> rsMaybeUnavail $ do |
456 |
incompleteObj <- maybeAt index $ listGetter inst |
457 |
let defaultObj = defaultGetter cfg inst |
458 |
completeObj = fillFn defaultObj incompleteObj |
459 |
propertyGetter completeObj) |
460 |
|
461 |
-- | Creates a function which produces a 'FieldGetter' when fed an index. Works |
462 |
-- for fields that may not return a value, expressed through the Maybe monad. |
463 |
getIndexedOptionalField :: (J.JSON b) |
464 |
=> (Instance -> [a]) -- ^ Extracts a list of objects |
465 |
-> (a -> Maybe b) -- ^ Possibly gets a property |
466 |
-- from an object |
467 |
-> Int -- ^ Index in list to use |
468 |
-> FieldGetter Instance Runtime -- ^ Result |
469 |
getIndexedOptionalField extractor optPropertyGetter index = |
470 |
FieldSimple(\inst -> rsMaybeUnavail $ do |
471 |
obj <- maybeAt index $ extractor inst |
472 |
optPropertyGetter obj) |
473 |
|
474 |
-- | Creates a function which produces a 'FieldGetter' when fed an index. |
475 |
-- Works only for fields that surely return a value. |
476 |
getIndexedField :: (J.JSON b) |
477 |
=> (Instance -> [a]) -- ^ Extracts a list of objects |
478 |
-> (a -> b) -- ^ Gets a property from an object |
479 |
-> Int -- ^ Index in list to use |
480 |
-> FieldGetter Instance Runtime -- ^ Result |
481 |
getIndexedField extractor propertyGetter index = |
482 |
let optPropertyGetter = Just . propertyGetter |
483 |
in getIndexedOptionalField extractor optPropertyGetter index |
484 |
|
485 |
-- | Retrieves a value from an array at an index, using the Maybe monad to |
486 |
-- indicate failure. |
487 |
maybeAt :: Int -> [a] -> Maybe a |
488 |
maybeAt index list |
489 |
| index >= length list = Nothing |
490 |
| otherwise = Just $ list !! index |
491 |
|
492 |
-- | Primed with format strings for everything but the type, it consumes two |
493 |
-- values and uses them to complete the FieldDefinition. |
494 |
-- Warning: a bit unsafe as it uses printf. Handle with care. |
495 |
fieldDefinitionCompleter :: (PrintfArg t1) => (PrintfArg t2) |
496 |
=> FieldName |
497 |
-> FieldTitle |
498 |
-> FieldType |
499 |
-> FieldDoc |
500 |
-> t1 |
501 |
-> t2 |
502 |
-> FieldDefinition |
503 |
fieldDefinitionCompleter fName fTitle fType fDoc firstVal secondVal = |
504 |
FieldDefinition (printf fName firstVal) |
505 |
(printf fTitle firstVal) |
506 |
fType |
507 |
(printf fDoc secondVal) |
508 |
|
509 |
-- | Given an incomplete field definition and values that can complete it, |
510 |
-- return a fully functional FieldData. Cannot work for all cases, should be |
511 |
-- extended as necessary. |
512 |
fillIncompleteFields :: (t1 -> t2 -> FieldDefinition, |
513 |
t1 -> FieldGetter a b, |
514 |
QffMode) |
515 |
-> t1 |
516 |
-> t2 |
517 |
-> FieldData a b |
518 |
fillIncompleteFields (iDef, iGet, mode) firstVal secondVal = |
519 |
(iDef firstVal secondVal, iGet firstVal, mode) |
520 |
|
521 |
-- | Given indexed fields that describe lists, complete / instantiate them for |
522 |
-- a given list size. |
523 |
instantiateIndexedFields :: (Show t1, Integral t1) |
524 |
=> Int -- ^ The size of the list |
525 |
-> [(t1 -> String -> FieldDefinition, |
526 |
t1 -> FieldGetter a b, |
527 |
QffMode)] -- ^ The indexed fields |
528 |
-> FieldList a b -- ^ A list of complete fields |
529 |
instantiateIndexedFields listSize fields = do |
530 |
index <- take listSize [0..] |
531 |
field <- fields |
532 |
return . fillIncompleteFields field index . formatOrdinal $ index + 1 |
533 |
|
534 |
-- * Various helper functions for property retrieval |
535 |
|
536 |
-- | Helper function for primary node retrieval |
537 |
getPrimaryNode :: ConfigData -> Instance -> ErrorResult Node |
538 |
getPrimaryNode cfg = getInstPrimaryNode cfg . instName |
539 |
|
540 |
-- | Get primary node hostname |
541 |
getPrimaryNodeName :: ConfigData -> Instance -> ResultEntry |
542 |
getPrimaryNodeName cfg inst = |
543 |
rsErrorNoData $ nodeName <$> getPrimaryNode cfg inst |
544 |
|
545 |
-- | Get primary node group |
546 |
getPrimaryNodeGroup :: ConfigData -> Instance -> ErrorResult NodeGroup |
547 |
getPrimaryNodeGroup cfg inst = do |
548 |
pNode <- getPrimaryNode cfg inst |
549 |
maybeToError "Configuration missing" $ getGroupOfNode cfg pNode |
550 |
|
551 |
-- | Get primary node group name |
552 |
getPrimaryNodeGroupName :: ConfigData -> Instance -> ResultEntry |
553 |
getPrimaryNodeGroupName cfg inst = |
554 |
rsErrorNoData $ groupName <$> getPrimaryNodeGroup cfg inst |
555 |
|
556 |
-- | Get primary node group uuid |
557 |
getPrimaryNodeGroupUuid :: ConfigData -> Instance -> ResultEntry |
558 |
getPrimaryNodeGroupUuid cfg inst = |
559 |
rsErrorNoData $ groupUuid <$> getPrimaryNodeGroup cfg inst |
560 |
|
561 |
-- | Get secondary nodes - the configuration objects themselves |
562 |
getSecondaryNodes :: ConfigData -> Instance -> ErrorResult [Node] |
563 |
getSecondaryNodes cfg inst = do |
564 |
pNode <- getPrimaryNode cfg inst |
565 |
allNodes <- getInstAllNodes cfg $ instName inst |
566 |
return $ delete pNode allNodes |
567 |
|
568 |
-- | Get attributes of the secondary nodes |
569 |
getSecondaryNodeAttribute :: (J.JSON a) |
570 |
=> (Node -> a) |
571 |
-> ConfigData |
572 |
-> Instance |
573 |
-> ResultEntry |
574 |
getSecondaryNodeAttribute getter cfg inst = |
575 |
rsErrorNoData $ map (J.showJSON . getter) <$> getSecondaryNodes cfg inst |
576 |
|
577 |
-- | Get secondary node groups |
578 |
getSecondaryNodeGroups :: ConfigData -> Instance -> ErrorResult [NodeGroup] |
579 |
getSecondaryNodeGroups cfg inst = do |
580 |
sNodes <- getSecondaryNodes cfg inst |
581 |
return . catMaybes $ map (getGroupOfNode cfg) sNodes |
582 |
|
583 |
-- | Get attributes of secondary node groups |
584 |
getSecondaryNodeGroupAttribute :: (J.JSON a) |
585 |
=> (NodeGroup -> a) |
586 |
-> ConfigData |
587 |
-> Instance |
588 |
-> ResultEntry |
589 |
getSecondaryNodeGroupAttribute getter cfg inst = |
590 |
rsErrorNoData $ map (J.showJSON . getter) <$> getSecondaryNodeGroups cfg inst |
591 |
|
592 |
-- | Beparam getter builder: given a field, it returns a FieldConfig |
593 |
-- getter, that is a function that takes the config and the object and |
594 |
-- returns the Beparam field specified when the getter was built. |
595 |
beParamGetter :: String -- ^ The field we are building the getter for |
596 |
-> ConfigData -- ^ The configuration object |
597 |
-> Instance -- ^ The instance configuration object |
598 |
-> ResultEntry -- ^ The result |
599 |
beParamGetter field config inst = |
600 |
case getFilledInstBeParams config inst of |
601 |
Ok beParams -> dictFieldGetter field $ Just beParams |
602 |
Bad _ -> rsNoData |
603 |
|
604 |
-- | Hvparam getter builder: given a field, it returns a FieldConfig |
605 |
-- getter, that is a function that takes the config and the object and |
606 |
-- returns the Hvparam field specified when the getter was built. |
607 |
hvParamGetter :: String -- ^ The field we're building the getter for |
608 |
-> ConfigData -> Instance -> ResultEntry |
609 |
hvParamGetter field cfg inst = |
610 |
rsMaybeUnavail . Map.lookup field . fromContainer $ |
611 |
getFilledInstHvParams (C.toList C.hvcGlobals) cfg inst |
612 |
|
613 |
-- * Live fields functionality |
614 |
|
615 |
-- | List of node live fields. |
616 |
instanceLiveFieldsDefs :: [(FieldName, FieldTitle, FieldType, String, FieldDoc)] |
617 |
instanceLiveFieldsDefs = |
618 |
[ ("oper_ram", "Memory", QFTUnit, "oper_ram", |
619 |
"Actual memory usage as seen by hypervisor") |
620 |
, ("oper_vcpus", "VCPUs", QFTNumber, "oper_vcpus", |
621 |
"Actual number of VCPUs as seen by hypervisor") |
622 |
] |
623 |
|
624 |
-- | Map each name to a function that extracts that value from the RPC result. |
625 |
instanceLiveFieldExtract :: FieldName -> InstanceInfo -> Instance -> J.JSValue |
626 |
instanceLiveFieldExtract "oper_ram" info _ = J.showJSON $ instInfoMemory info |
627 |
instanceLiveFieldExtract "oper_vcpus" info _ = J.showJSON $ instInfoVcpus info |
628 |
instanceLiveFieldExtract n _ _ = J.showJSON $ |
629 |
"The field " ++ n ++ " is not an expected or extractable live field!" |
630 |
|
631 |
-- | Helper for extracting an instance live field from the RPC results. |
632 |
instanceLiveRpcCall :: FieldName -> Runtime -> Instance -> ResultEntry |
633 |
instanceLiveRpcCall fname (Right (Just (res, _), _)) inst = |
634 |
case instanceLiveFieldExtract fname res inst of |
635 |
J.JSNull -> rsNoData |
636 |
x -> rsNormal x |
637 |
instanceLiveRpcCall _ (Right (Nothing, _)) _ = rsUnavail |
638 |
instanceLiveRpcCall _ (Left err) _ = |
639 |
ResultEntry (rpcErrorToStatus err) Nothing |
640 |
|
641 |
-- | Builder for node live fields. |
642 |
instanceLiveFieldBuilder :: (FieldName, FieldTitle, FieldType, String, FieldDoc) |
643 |
-> FieldData Instance Runtime |
644 |
instanceLiveFieldBuilder (fname, ftitle, ftype, _, fdoc) = |
645 |
( FieldDefinition fname ftitle ftype fdoc |
646 |
, FieldRuntime $ instanceLiveRpcCall fname |
647 |
, QffNormal) |
648 |
|
649 |
-- * Functionality related to status and operational status extraction |
650 |
|
651 |
-- | The documentation text for the instance status field |
652 |
statusDocText :: String |
653 |
statusDocText = |
654 |
let si = show . instanceStatusToRaw :: InstanceStatus -> String |
655 |
in "Instance status; " ++ |
656 |
si Running ++ |
657 |
" if instance is set to be running and actually is, " ++ |
658 |
si StatusDown ++ |
659 |
" if instance is stopped and is not running, " ++ |
660 |
si WrongNode ++ |
661 |
" if instance running, but not on its designated primary node, " ++ |
662 |
si ErrorUp ++ |
663 |
" if instance should be stopped, but is actually running, " ++ |
664 |
si ErrorDown ++ |
665 |
" if instance should run, but doesn't, " ++ |
666 |
si NodeDown ++ |
667 |
" if instance's primary node is down, " ++ |
668 |
si NodeOffline ++ |
669 |
" if instance's primary node is marked offline, " ++ |
670 |
si StatusOffline ++ |
671 |
" if instance is offline and does not use dynamic resources" |
672 |
|
673 |
-- | Checks if the primary node of an instance is offline |
674 |
isPrimaryOffline :: ConfigData -> Instance -> Bool |
675 |
isPrimaryOffline cfg inst = |
676 |
let pNodeResult = getNode cfg $ instPrimaryNode inst |
677 |
in case pNodeResult of |
678 |
Ok pNode -> nodeOffline pNode |
679 |
Bad _ -> error "Programmer error - result assumed to be OK is Bad!" |
680 |
|
681 |
-- | Determines the status of a live instance |
682 |
liveInstanceStatus :: (InstanceInfo, Bool) -> Instance -> InstanceStatus |
683 |
liveInstanceStatus (instInfo, foundOnPrimary) inst |
684 |
| not foundOnPrimary = WrongNode |
685 |
| otherwise = |
686 |
case instanceState of |
687 |
InstanceStateRunning | adminState == AdminUp -> Running |
688 |
| otherwise -> ErrorUp |
689 |
InstanceStateShutdown | adminState == AdminUp && allowDown -> UserDown |
690 |
| otherwise -> StatusDown |
691 |
where adminState = instAdminState inst |
692 |
instanceState = instInfoState instInfo |
693 |
|
694 |
hvparams = fromContainer $ instHvparams inst |
695 |
|
696 |
allowDown = |
697 |
instHypervisor inst /= Kvm || |
698 |
(Map.member C.hvKvmUserShutdown hvparams && |
699 |
hvparams Map.! C.hvKvmUserShutdown == J.JSBool True) |
700 |
|
701 |
-- | Determines the status of a dead instance. |
702 |
deadInstanceStatus :: Instance -> InstanceStatus |
703 |
deadInstanceStatus inst = |
704 |
case instAdminState inst of |
705 |
AdminUp -> ErrorDown |
706 |
AdminDown -> StatusDown |
707 |
AdminOffline -> StatusOffline |
708 |
|
709 |
-- | Determines the status of the instance, depending on whether it is possible |
710 |
-- to communicate with its primary node, on which node it is, and its |
711 |
-- configuration. |
712 |
determineInstanceStatus :: ConfigData -- ^ The configuration data |
713 |
-> Runtime -- ^ All the data from the live call |
714 |
-> Instance -- ^ Static instance configuration |
715 |
-> InstanceStatus -- ^ Result |
716 |
determineInstanceStatus cfg res inst |
717 |
| isPrimaryOffline cfg inst = NodeOffline |
718 |
| otherwise = case res of |
719 |
Left _ -> NodeDown |
720 |
Right (Just liveData, _) -> liveInstanceStatus liveData inst |
721 |
Right (Nothing, _) -> deadInstanceStatus inst |
722 |
|
723 |
-- | Extracts the instance status, retrieving it using the functions above and |
724 |
-- transforming it into a 'ResultEntry'. |
725 |
statusExtract :: ConfigData -> Runtime -> Instance -> ResultEntry |
726 |
statusExtract cfg res inst = |
727 |
rsNormal . J.showJSON . instanceStatusToRaw $ |
728 |
determineInstanceStatus cfg res inst |
729 |
|
730 |
-- | Extracts the operational status of the instance. |
731 |
operStatusExtract :: Runtime -> Instance -> ResultEntry |
732 |
operStatusExtract res _ = |
733 |
rsMaybeNoData $ J.showJSON <$> |
734 |
case res of |
735 |
Left _ -> Nothing |
736 |
Right (x, _) -> Just $ isJust x |
737 |
|
738 |
-- | Extracts the console connection information |
739 |
consoleExtract :: Runtime -> Instance -> ResultEntry |
740 |
consoleExtract (Left err) _ = ResultEntry (rpcErrorToStatus err) Nothing |
741 |
consoleExtract (Right (_, val)) _ = rsMaybeNoData val |
742 |
|
743 |
-- * Helper functions extracting information as necessary for the generic query |
744 |
-- interfaces |
745 |
|
746 |
-- | This function checks if a node with a given uuid has experienced an error |
747 |
-- or not. |
748 |
checkForNodeError :: [(String, ERpcError a)] |
749 |
-> String |
750 |
-> Maybe RpcError |
751 |
checkForNodeError uuidList uuid = |
752 |
case snd <$> pickPairUnique uuid uuidList of |
753 |
Just (Left err) -> Just err |
754 |
Just (Right _) -> Nothing |
755 |
Nothing -> Just . RpcResultError $ |
756 |
"Node response not present" |
757 |
|
758 |
-- | Finds information about the instance in the info delivered by a node |
759 |
findInfoInNodeResult :: Instance |
760 |
-> ERpcError RpcResultAllInstancesInfo |
761 |
-> Maybe InstanceInfo |
762 |
findInfoInNodeResult inst nodeResponse = |
763 |
case nodeResponse of |
764 |
Left _err -> Nothing |
765 |
Right allInfo -> |
766 |
let instances = rpcResAllInstInfoInstances allInfo |
767 |
maybeMatch = pickPairUnique (instName inst) instances |
768 |
in snd <$> maybeMatch |
769 |
|
770 |
-- | Retrieves the instance information if it is present anywhere in the all |
771 |
-- instances RPC result. Notes if it originates from the primary node. |
772 |
-- An error is delivered if there is no result, and the primary node is down. |
773 |
getInstanceInfo :: [(String, ERpcError RpcResultAllInstancesInfo)] |
774 |
-> Instance |
775 |
-> ERpcError (Maybe (InstanceInfo, Bool)) |
776 |
getInstanceInfo uuidList inst = |
777 |
let pNodeUuid = instPrimaryNode inst |
778 |
primarySearchResult = |
779 |
pickPairUnique pNodeUuid uuidList >>= findInfoInNodeResult inst . snd |
780 |
in case primarySearchResult of |
781 |
Just instInfo -> Right . Just $ (instInfo, True) |
782 |
Nothing -> |
783 |
let allSearchResult = |
784 |
getFirst . mconcat $ map |
785 |
(First . findInfoInNodeResult inst . snd) uuidList |
786 |
in case allSearchResult of |
787 |
Just instInfo -> Right . Just $ (instInfo, False) |
788 |
Nothing -> |
789 |
case checkForNodeError uuidList pNodeUuid of |
790 |
Just err -> Left err |
791 |
Nothing -> Right Nothing |
792 |
|
793 |
-- | Retrieves the console information if present anywhere in the given results |
794 |
getConsoleInfo :: [(String, ERpcError RpcResultInstanceConsoleInfo)] |
795 |
-> Instance |
796 |
-> Maybe InstanceConsoleInfo |
797 |
getConsoleInfo uuidList inst = |
798 |
let allValidResults = concatMap rpcResInstConsInfoInstancesInfo . |
799 |
rights . map snd $ uuidList |
800 |
in snd <$> pickPairUnique (instName inst) allValidResults |
801 |
|
802 |
-- | Extracts all the live information that can be extracted. |
803 |
extractLiveInfo :: [(Node, ERpcError RpcResultAllInstancesInfo)] |
804 |
-> [(Node, ERpcError RpcResultInstanceConsoleInfo)] |
805 |
-> Instance |
806 |
-> Runtime |
807 |
extractLiveInfo nodeResultList nodeConsoleList inst = |
808 |
let uuidConvert = map (\(x, y) -> (nodeUuid x, y)) |
809 |
uuidResultList = uuidConvert nodeResultList |
810 |
uuidConsoleList = uuidConvert nodeConsoleList |
811 |
in case getInstanceInfo uuidResultList inst of |
812 |
-- If we can't get the instance info, we can't get the console info either. |
813 |
-- Best to propagate the error further. |
814 |
Left err -> Left err |
815 |
Right res -> Right (res, getConsoleInfo uuidConsoleList inst) |
816 |
|
817 |
-- | Retrieves all the parameters for the console calls. |
818 |
getAllConsoleParams :: ConfigData |
819 |
-> [Instance] |
820 |
-> ErrorResult [InstanceConsoleInfoParams] |
821 |
getAllConsoleParams cfg = mapM $ \i -> |
822 |
InstanceConsoleInfoParams i |
823 |
<$> getPrimaryNode cfg i |
824 |
<*> getPrimaryNodeGroup cfg i |
825 |
<*> pure (getFilledInstHvParams [] cfg i) |
826 |
<*> getFilledInstBeParams cfg i |
827 |
|
828 |
-- | Compares two params according to their node, needed for grouping. |
829 |
compareParamsByNode :: InstanceConsoleInfoParams |
830 |
-> InstanceConsoleInfoParams |
831 |
-> Bool |
832 |
compareParamsByNode x y = instConsInfoParamsNode x == instConsInfoParamsNode y |
833 |
|
834 |
-- | Groups instance information calls heading out to the same nodes. |
835 |
consoleParamsToCalls :: [InstanceConsoleInfoParams] |
836 |
-> [(Node, RpcCallInstanceConsoleInfo)] |
837 |
consoleParamsToCalls params = |
838 |
let sortedParams = sortBy |
839 |
(comparing (instPrimaryNode . instConsInfoParamsInstance)) params |
840 |
groupedParams = groupBy compareParamsByNode sortedParams |
841 |
in map (\x -> case x of |
842 |
[] -> error "Programmer error: group must have one or more members" |
843 |
paramGroup@(y:_) -> |
844 |
let node = instConsInfoParamsNode y |
845 |
packer z = (instName $ instConsInfoParamsInstance z, z) |
846 |
in (node, RpcCallInstanceConsoleInfo . map packer $ paramGroup) |
847 |
) groupedParams |
848 |
|
849 |
-- | Retrieves a list of all the hypervisors and params used by the given |
850 |
-- instances. |
851 |
getHypervisorSpecs :: ConfigData -> [Instance] -> [(Hypervisor, HvParams)] |
852 |
getHypervisorSpecs cfg instances = |
853 |
let hvs = nub . map instHypervisor $ instances |
854 |
hvParamMap = (fromContainer . clusterHvparams . configCluster $ cfg) |
855 |
in zip hvs . map ((Map.!) hvParamMap . hypervisorToRaw) $ hvs |
856 |
|
857 |
-- | Collect live data from RPC query if enabled. |
858 |
collectLiveData :: Bool -- ^ Live queries allowed |
859 |
-> ConfigData -- ^ The cluster config |
860 |
-> [String] -- ^ The requested fields |
861 |
-> [Instance] -- ^ The instance objects |
862 |
-> IO [(Instance, Runtime)] |
863 |
collectLiveData liveDataEnabled cfg fields instances |
864 |
| not liveDataEnabled = return . zip instances . repeat . Left . |
865 |
RpcResultError $ "Live data disabled" |
866 |
| otherwise = do |
867 |
let hvSpecs = getHypervisorSpecs cfg instances |
868 |
instanceNodes = nub . justOk $ |
869 |
map (getNode cfg . instPrimaryNode) instances |
870 |
goodNodes = nodesWithValidConfig cfg instanceNodes |
871 |
instInfoRes <- executeRpcCall goodNodes (RpcCallAllInstancesInfo hvSpecs) |
872 |
consInfoRes <- |
873 |
if "console" `elem` fields |
874 |
then case getAllConsoleParams cfg instances of |
875 |
Ok p -> executeRpcCalls $ consoleParamsToCalls p |
876 |
Bad _ -> return . zip goodNodes . repeat . Left $ |
877 |
RpcResultError "Cannot construct parameters for console info call" |
878 |
else return [] -- The information is not necessary |
879 |
return . zip instances . |
880 |
map (extractLiveInfo instInfoRes consInfoRes) $ instances |