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