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