Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Query / Instance.hs @ a861d322

History | View | Annotate | Download (28 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
  ) where
31

    
32
import Control.Applicative
33
import Data.List
34
import Data.Maybe
35
import Data.Monoid
36
import qualified Data.Map as Map
37
import qualified Text.JSON as J
38
import Text.Printf
39

    
40
import Ganeti.BasicTypes
41
import Ganeti.Common
42
import Ganeti.Config
43
import qualified Ganeti.Constants as C
44
import qualified Ganeti.ConstantUtils as C
45
import Ganeti.Errors
46
import Ganeti.JSON
47
import Ganeti.Objects
48
import Ganeti.Query.Common
49
import Ganeti.Query.Language
50
import Ganeti.Query.Types
51
import Ganeti.Rpc
52
import Ganeti.Storage.Utils
53
import Ganeti.Types
54
import Ganeti.Utils (formatOrdinal)
55

    
56
-- | The LiveInfo structure packs additional information beside the
57
-- 'InstanceInfo'. We also need to know whether the instance information was
58
-- found on the primary node, and encode this as a Bool.
59
type LiveInfo = (InstanceInfo, Bool)
60

    
61
-- | Runtime possibly containing the 'LiveInfo'. See the genericQuery function
62
-- in the Query.hs file for an explanation of the terms used.
63
type Runtime = Either RpcError (Maybe LiveInfo)
64

    
65
-- | The instance fields map.
66
fieldsMap :: FieldMap Instance Runtime
67
fieldsMap = Map.fromList [(fdefName f, v) | v@(f, _, _) <- instanceFields]
68

    
69
-- | The instance fields
70
instanceFields :: FieldList Instance Runtime
71
instanceFields =
72
  -- Simple fields
73
  [ (FieldDefinition "admin_state" "InstanceState" QFTText
74
     "Desired state of instance",
75
     FieldSimple (rsNormal . adminStateToRaw . instAdminState), QffNormal)
76
  , (FieldDefinition "admin_up" "Autostart" QFTBool
77
     "Desired state of instance",
78
     FieldSimple (rsNormal . (== AdminUp) . instAdminState), QffNormal)
79
  , (FieldDefinition "disk_template" "Disk_template" QFTText
80
     "Instance disk template",
81
     FieldSimple (rsNormal . instDiskTemplate), QffNormal)
82
  , (FieldDefinition "disks_active" "DisksActive" QFTBool
83
     "Desired state of instance disks",
84
     FieldSimple (rsNormal . instDisksActive), QffNormal)
85
  , (FieldDefinition "name" "Instance" QFTText
86
     "Instance name",
87
     FieldSimple (rsNormal . instName), QffHostname)
88
  , (FieldDefinition "hypervisor" "Hypervisor" QFTText
89
     "Hypervisor name",
90
     FieldSimple (rsNormal . instHypervisor), QffNormal)
91
  , (FieldDefinition "network_port" "Network_port" QFTOther
92
     "Instance network port if available (e.g. for VNC console)",
93
     FieldSimple (rsMaybeUnavail . instNetworkPort), QffNormal)
94
  , (FieldDefinition "os" "OS" QFTText
95
     "Operating system",
96
     FieldSimple (rsNormal . instOs), QffNormal)
97
  , (FieldDefinition "pnode" "Primary_node" QFTText
98
     "Primary node",
99
     FieldConfig getPrimaryNodeName, QffHostname)
100
  , (FieldDefinition "pnode.group" "PrimaryNodeGroup" QFTText
101
     "Primary node's group",
102
     FieldConfig getPrimaryNodeGroup, QffNormal)
103
  , (FieldDefinition "snodes" "Secondary_Nodes" QFTOther
104
     "Secondary nodes; usually this will just be one node",
105
     FieldConfig (getSecondaryNodeAttribute nodeName), QffNormal)
106
  , (FieldDefinition "snodes.group" "SecondaryNodesGroups" QFTOther
107
     "Node groups of secondary nodes",
108
     FieldConfig (getSecondaryNodeGroupAttribute groupName), QffNormal)
109
  , (FieldDefinition "snodes.group.uuid" "SecondaryNodesGroupsUUID" QFTOther
110
     "Node group UUIDs of secondary nodes",
111
     FieldConfig (getSecondaryNodeGroupAttribute groupUuid), QffNormal)
112
  ] ++
113

    
114
  -- Instance parameter fields, whole
115
  [ (FieldDefinition "hvparams" "HypervisorParameters" QFTOther
116
     "Hypervisor parameters (merged)",
117
     FieldConfig ((rsNormal .) . getFilledInstHvParams), QffNormal)
118
  , (FieldDefinition "beparams" "BackendParameters" QFTOther
119
     "Backend parameters (merged)",
120
     FieldConfig ((rsErrorNoData .) . getFilledInstBeParams), QffNormal)
121
  , (FieldDefinition "osparams" "OpSysParameters" QFTOther
122
     "Operating system parameters (merged)",
123
     FieldConfig ((rsNormal .) . getFilledInstOsParams), QffNormal)
124
  , (FieldDefinition "custom_hvparams" "CustomHypervisorParameters" QFTOther
125
     "Custom hypervisor parameters",
126
     FieldSimple (rsNormal . instHvparams), QffNormal)
127
  , (FieldDefinition "custom_beparams" "CustomBackendParameters" QFTOther
128
     "Custom backend parameters",
129
     FieldSimple (rsNormal . instBeparams), QffNormal)
130
  , (FieldDefinition "custom_osparams" "CustomOpSysParameters" QFTOther
131
     "Custom operating system parameters",
132
     FieldSimple (rsNormal . instOsparams), QffNormal)
133
  ] ++
134

    
135
  -- Instance parameter fields, generated
136
  map (buildBeParamField beParamGetter) allBeParamFields ++
137
  map (buildHvParamField hvParamGetter) (C.toList C.hvsParameters) ++
138

    
139
  -- Aggregate disk parameter fields
140
  [ (FieldDefinition "disk_usage" "DiskUsage" QFTUnit
141
     "Total disk space used by instance on each of its nodes; this is not the\
142
     \ disk size visible to the instance, but the usage on the node",
143
     FieldSimple (rsNormal . getDiskSizeRequirements), QffNormal)
144
  , (FieldDefinition "disk.count" "Disks" QFTNumber
145
     "Number of disks",
146
     FieldSimple (rsNormal . length . instDisks), QffNormal)
147
  , (FieldDefinition "disk.sizes" "Disk_sizes" QFTOther
148
     "List of disk sizes",
149
     FieldSimple (rsNormal . map diskSize . instDisks), QffNormal)
150
  , (FieldDefinition "disk.spindles" "Disk_spindles" QFTOther
151
     "List of disk spindles",
152
     FieldSimple (rsNormal . map (MaybeForJSON . diskSpindles) .
153
                  instDisks),
154
     QffNormal)
155
  , (FieldDefinition "disk.names" "Disk_names" QFTOther
156
     "List of disk names",
157
     FieldSimple (rsNormal . map (MaybeForJSON . diskName) .
158
                  instDisks),
159
     QffNormal)
160
  , (FieldDefinition "disk.uuids" "Disk_UUIDs" QFTOther
161
     "List of disk UUIDs",
162
     FieldSimple (rsNormal . map diskUuid . instDisks), QffNormal)
163
  ] ++
164

    
165
  -- Per-disk parameter fields
166
  fillNumberFields C.maxDisks
167
  [ (fieldDefinitionCompleter "disk.size/%d" "Disk/%d" QFTUnit
168
     "Disk size of %s disk",
169
     getFillableField instDisks diskSize, QffNormal)
170
  , (fieldDefinitionCompleter "disk.spindles/%d" "DiskSpindles/%d" QFTNumber
171
     "Spindles of %s disk",
172
     getFillableOptionalField instDisks diskSpindles, QffNormal)
173
  , (fieldDefinitionCompleter "disk.name/%d" "DiskName/%d" QFTText
174
     "Name of %s disk",
175
     getFillableOptionalField instDisks diskName, QffNormal)
176
  , (fieldDefinitionCompleter "disk.uuid/%d" "DiskUUID/%d" QFTText
177
     "UUID of %s disk",
178
     getFillableField instDisks diskUuid, QffNormal)
179
  ] ++
180

    
181
  -- Aggregate nic parameter fields
182
  [ (FieldDefinition "nic.count" "NICs" QFTNumber
183
     "Number of network interfaces",
184
     FieldSimple (rsNormal . length . instNics), QffNormal)
185
  , (FieldDefinition "nic.macs" "NIC_MACs" QFTOther
186
     (nicAggDescPrefix ++ "MAC address"),
187
     FieldSimple (rsNormal . map nicMac . instNics), QffNormal)
188
  , (FieldDefinition "nic.ips" "NIC_IPs" QFTOther
189
     (nicAggDescPrefix ++ "IP address"),
190
     FieldSimple (rsNormal . map (MaybeForJSON . nicIp) . instNics),
191
     QffNormal)
192
  , (FieldDefinition "nic.names" "NIC_Names" QFTOther
193
     (nicAggDescPrefix ++ "name"),
194
     FieldSimple (rsNormal . map (MaybeForJSON . nicName) . instNics),
195
     QffNormal)
196
  , (FieldDefinition "nic.uuids" "NIC_UUIDs" QFTOther
197
     (nicAggDescPrefix ++ "UUID"),
198
     FieldSimple (rsNormal . map nicUuid . instNics), QffNormal)
199
  , (FieldDefinition "nic.modes" "NIC_modes" QFTOther
200
     (nicAggDescPrefix ++ "mode"),
201
     FieldConfig (\cfg -> rsNormal . map
202
       (nicpMode . fillNicParamsFromConfig cfg . nicNicparams)
203
       . instNics),
204
     QffNormal)
205
  , (FieldDefinition "nic.bridges" "NIC_bridges" QFTOther
206
     (nicAggDescPrefix ++ "bridge"),
207
     FieldConfig (\cfg -> rsNormal . map (MaybeForJSON . getNicBridge .
208
       fillNicParamsFromConfig cfg . nicNicparams) . instNics),
209
     QffNormal)
210
  , (FieldDefinition "nic.links" "NIC_links" QFTOther
211
     (nicAggDescPrefix ++ "link"),
212
     FieldConfig (\cfg -> rsNormal . map
213
       (nicpLink . fillNicParamsFromConfig cfg . nicNicparams)
214
       . instNics),
215
     QffNormal)
216
  , (FieldDefinition "nic.networks" "NIC_networks" QFTOther
217
     "List containing each interface's network",
218
     FieldSimple (rsNormal . map (MaybeForJSON . nicNetwork) . instNics),
219
     QffNormal)
220
  , (FieldDefinition "nic.networks.names" "NIC_networks_names" QFTOther
221
     "List containing the name of each interface's network",
222
     FieldConfig (\cfg -> rsNormal . map
223
       (\x -> MaybeForJSON (getNetworkName cfg <$> nicNetwork x))
224
       . instNics),
225
     QffNormal)
226
  ] ++
227

    
228
  -- Per-nic parameter fields
229
  fillNumberFields C.maxNics
230
  [ (fieldDefinitionCompleter "nic.ip/%d" "NicIP/%d" QFTText
231
     ("IP address" ++ nicDescSuffix),
232
     getFillableOptionalField instNics nicIp, QffNormal)
233
  , (fieldDefinitionCompleter "nic.uuid/%d" "NicUUID/%d" QFTText
234
     ("UUID address" ++ nicDescSuffix),
235
     getFillableField instNics nicUuid, QffNormal)
236
  , (fieldDefinitionCompleter "nic.mac/%d" "NicMAC/%d" QFTText
237
     ("MAC address" ++ nicDescSuffix),
238
     getFillableField instNics nicMac, QffNormal)
239
  , (fieldDefinitionCompleter "nic.name/%d" "NicName/%d" QFTText
240
     ("Name address" ++ nicDescSuffix),
241
     getFillableOptionalField instNics nicName, QffNormal)
242
  , (fieldDefinitionCompleter "nic.network/%d" "NicNetwork/%d" QFTText
243
     ("Network" ++ nicDescSuffix),
244
     getFillableOptionalField instNics nicNetwork, QffNormal)
245
  , (fieldDefinitionCompleter "nic.mode/%d" "NicMode/%d" QFTText
246
     ("Mode" ++ nicDescSuffix),
247
     getFillableNicField nicpMode, QffNormal)
248
  , (fieldDefinitionCompleter "nic.link/%d" "NicLink/%d" QFTText
249
     ("Link" ++ nicDescSuffix),
250
     getFillableNicField nicpLink, QffNormal)
251
  , (fieldDefinitionCompleter "nic.network.name/%d" "NicNetworkName/%d" QFTText
252
     ("Network name" ++ nicDescSuffix),
253
     getFillableNicNetworkNameField, QffNormal)
254
  , (fieldDefinitionCompleter "nic.bridge/%d" "NicBridge/%d" QFTText
255
     ("Bridge" ++ nicDescSuffix),
256
     getOptionalFillableNicField getNicBridge, QffNormal)
257
  ] ++
258

    
259
  -- Live fields using special getters
260
  [ (FieldDefinition "status" "Status" QFTText
261
     statusDocText,
262
     FieldConfigRuntime statusExtract, QffNormal)
263
  , (FieldDefinition "oper_state" "Running" QFTBool
264
     "Actual state of instance",
265
     FieldRuntime operStatusExtract, QffNormal)
266
  ] ++
267

    
268
  -- Simple live fields
269
  map instanceLiveFieldBuilder instanceLiveFieldsDefs ++
270

    
271
  -- Generated fields
272
  serialFields "Instance" ++
273
  uuidFields "Instance" ++
274
  tagsFields
275

    
276
-- * Helper functions for node property retrieval
277

    
278
-- | Constant suffix of network interface field descriptions.
279
nicDescSuffix ::String
280
nicDescSuffix = " of %s network interface"
281

    
282
-- | Almost-constant suffix of aggregate network interface field descriptions.
283
nicAggDescPrefix ::String
284
nicAggDescPrefix = "List containing each network interface's "
285

    
286
-- | Given a network name id, returns the network's name.
287
getNetworkName :: ConfigData -> String -> NonEmptyString
288
getNetworkName cfg = networkName . (Map.!) (fromContainer $ configNetworks cfg)
289

    
290
-- | Gets the bridge of a NIC.
291
getNicBridge :: FilledNicParams -> Maybe String
292
getNicBridge nicParams
293
  | nicpMode nicParams == NMBridged = Just $ nicpLink nicParams
294
  | otherwise                       = Nothing
295

    
296
-- | Fill partial NIC params by using the defaults from the configuration.
297
fillNicParamsFromConfig :: ConfigData -> PartialNicParams -> FilledNicParams
298
fillNicParamsFromConfig cfg = fillNicParams (getDefaultNicParams cfg)
299

    
300
-- | Retrieves the default network interface parameters.
301
getDefaultNicParams :: ConfigData -> FilledNicParams
302
getDefaultNicParams cfg =
303
  (Map.!) (fromContainer . clusterNicparams . configCluster $ cfg) C.ppDefault
304

    
305
-- | Returns a field that retrieves a given NIC's network name.
306
getFillableNicNetworkNameField :: Int -> FieldGetter Instance Runtime
307
getFillableNicNetworkNameField index =
308
  FieldConfig (\cfg inst -> rsMaybeUnavail $ do
309
    nicObj <- maybeAt index $ instNics inst
310
    nicNetworkId <- nicNetwork nicObj
311
    return $ getNetworkName cfg nicNetworkId)
312

    
313
-- | Gets a fillable NIC field.
314
getFillableNicField :: (J.JSON a)
315
                    => (FilledNicParams -> a)
316
                    -> Int
317
                    -> FieldGetter Instance Runtime
318
getFillableNicField getter =
319
  getOptionalFillableNicField (\x -> Just . getter $ x)
320

    
321
-- | Gets an optional fillable NIC field.
322
getOptionalFillableNicField :: (J.JSON a)
323
                            => (FilledNicParams -> Maybe a)
324
                            -> Int
325
                            -> FieldGetter Instance Runtime
326
getOptionalFillableNicField =
327
  getFillableFieldWithDefault
328
    (map nicNicparams . instNics) (\x _ -> getDefaultNicParams x) fillNicParams
329

    
330
-- | Creates a function which produces a 'FieldGetter' when fed an index. Works
331
-- for fields that should be filled out through the use of a default.
332
getFillableFieldWithDefault :: (J.JSON c)
333
  => (Instance -> [a])             -- ^ Extracts a list of incomplete objects
334
  -> (ConfigData -> Instance -> b) -- ^ Extracts the default object
335
  -> (b -> a -> b)                 -- ^ Fills the default object
336
  -> (b -> Maybe c)                -- ^ Extracts an obj property
337
  -> Int                           -- ^ Index in list to use
338
  -> FieldGetter Instance Runtime  -- ^ Result
339
getFillableFieldWithDefault
340
  listGetter defaultGetter fillFn propertyGetter index =
341
  FieldConfig (\cfg inst -> rsMaybeUnavail $ do
342
                              incompleteObj <- maybeAt index $ listGetter inst
343
                              let defaultObj = defaultGetter cfg inst
344
                                  completeObj = fillFn defaultObj incompleteObj
345
                              propertyGetter completeObj)
346

    
347
-- | Creates a function which produces a 'FieldGetter' when fed an index. Works
348
-- for fields that may not return a value, expressed through the Maybe monad.
349
getFillableOptionalField :: (J.JSON b)
350
                         => (Instance -> [a]) -- ^ Extracts a list of objects
351
                         -> (a -> Maybe b)    -- ^ Possibly gets a property
352
                                              -- from an object
353
                         -> Int               -- ^ Index in list to use
354
                         -> FieldGetter Instance Runtime -- ^ Result
355
getFillableOptionalField extractor optPropertyGetter index =
356
  FieldSimple(\inst -> rsMaybeUnavail $ do
357
                         obj <- maybeAt index $ extractor inst
358
                         optPropertyGetter obj)
359

    
360
-- | Creates a function which produces a 'FieldGetter' when fed an index.
361
-- Works only for fields that surely return a value.
362
getFillableField :: (J.JSON b)
363
                 => (Instance -> [a]) -- ^ Extracts a list of objects
364
                 -> (a -> b)          -- ^ Gets a property from an object
365
                 -> Int               -- ^ Index in list to use
366
                 -> FieldGetter Instance Runtime -- ^ Result
367
getFillableField extractor propertyGetter index =
368
  let optPropertyGetter = Just . propertyGetter
369
  in getFillableOptionalField extractor optPropertyGetter index
370

    
371
-- | Retrieves a value from an array at an index, using the Maybe monad to
372
-- indicate failure.
373
maybeAt :: Int -> [a] -> Maybe a
374
maybeAt index list
375
  | index >= length list = Nothing
376
  | otherwise            = Just $ list !! index
377

    
378
-- | Primed with format strings for everything but the type, it consumes two
379
-- values and uses them to complete the FieldDefinition.
380
-- Warning: a bit unsafe as it uses printf. Handle with care.
381
fieldDefinitionCompleter :: (PrintfArg t1) => (PrintfArg t2)
382
                         => FieldName
383
                         -> FieldTitle
384
                         -> FieldType
385
                         -> FieldDoc
386
                         -> t1
387
                         -> t2
388
                         -> FieldDefinition
389
fieldDefinitionCompleter fName fTitle fType fDoc firstVal secondVal =
390
  FieldDefinition (printf fName firstVal)
391
                  (printf fTitle firstVal)
392
                  fType
393
                  (printf fDoc secondVal)
394

    
395
-- | Given an incomplete field definition and values that can complete it,
396
-- return a fully functional FieldData. Cannot work for all cases, should be
397
-- extended as necessary.
398
fillIncompleteFields :: (t1 -> t2 -> FieldDefinition,
399
                         t1 -> FieldGetter a b,
400
                         QffMode)
401
                     -> t1
402
                     -> t2
403
                     -> FieldData a b
404
fillIncompleteFields (iDef, iGet, mode) firstVal secondVal =
405
  (iDef firstVal secondVal, iGet firstVal, mode)
406

    
407
-- | Given fields that describe lists, fill their definitions with appropriate
408
-- index representations.
409
fillNumberFields :: (Integral t1)
410
                 => Int
411
                 -> [(t1 -> String -> FieldDefinition,
412
                      t1 -> FieldGetter a b,
413
                      QffMode)]
414
                 -> FieldList a b
415
fillNumberFields numFills fieldsToFill = do
416
  index <- take numFills [0..]
417
  field <- fieldsToFill
418
  return . fillIncompleteFields field index . formatOrdinal $ index + 1
419

    
420
-- * Various helper functions for property retrieval
421

    
422
-- | Helper function for primary node retrieval
423
getPrimaryNode :: ConfigData -> Instance -> ErrorResult Node
424
getPrimaryNode cfg = getInstPrimaryNode cfg . instName
425

    
426
-- | Get primary node hostname
427
getPrimaryNodeName :: ConfigData -> Instance -> ResultEntry
428
getPrimaryNodeName cfg inst =
429
  rsErrorNoData $ nodeName <$> getPrimaryNode cfg inst
430

    
431
-- | Get primary node hostname
432
getPrimaryNodeGroup :: ConfigData -> Instance -> ResultEntry
433
getPrimaryNodeGroup cfg inst =
434
  rsErrorNoData $ (J.showJSON . groupName) <$>
435
    (getPrimaryNode cfg inst >>=
436
    maybeToError "Configuration missing" . getGroupOfNode cfg)
437

    
438
-- | Get secondary nodes - the configuration objects themselves
439
getSecondaryNodes :: ConfigData -> Instance -> ErrorResult [Node]
440
getSecondaryNodes cfg inst = do
441
  pNode <- getPrimaryNode cfg inst
442
  allNodes <- getInstAllNodes cfg $ instName inst
443
  return $ delete pNode allNodes
444

    
445
-- | Get attributes of the secondary nodes
446
getSecondaryNodeAttribute :: (J.JSON a)
447
                          => (Node -> a)
448
                          -> ConfigData
449
                          -> Instance
450
                          -> ResultEntry
451
getSecondaryNodeAttribute getter cfg inst =
452
  rsErrorNoData $ map (J.showJSON . getter) <$> getSecondaryNodes cfg inst
453

    
454
-- | Get secondary node groups
455
getSecondaryNodeGroups :: ConfigData -> Instance -> ErrorResult [NodeGroup]
456
getSecondaryNodeGroups cfg inst = do
457
  sNodes <- getSecondaryNodes cfg inst
458
  return . catMaybes $ map (getGroupOfNode cfg) sNodes
459

    
460
-- | Get attributes of secondary node groups
461
getSecondaryNodeGroupAttribute :: (J.JSON a)
462
                               => (NodeGroup -> a)
463
                               -> ConfigData
464
                               -> Instance
465
                               -> ResultEntry
466
getSecondaryNodeGroupAttribute getter cfg inst =
467
  rsErrorNoData $ map (J.showJSON . getter) <$> getSecondaryNodeGroups cfg inst
468

    
469
-- | Beparam getter builder: given a field, it returns a FieldConfig
470
-- getter, that is a function that takes the config and the object and
471
-- returns the Beparam field specified when the getter was built.
472
beParamGetter :: String       -- ^ The field we are building the getter for
473
              -> ConfigData   -- ^ The configuration object
474
              -> Instance     -- ^ The instance configuration object
475
              -> ResultEntry  -- ^ The result
476
beParamGetter field config inst =
477
  case getFilledInstBeParams config inst of
478
    Ok beParams -> dictFieldGetter field $ Just beParams
479
    Bad       _ -> rsNoData
480

    
481
-- | Hvparam getter builder: given a field, it returns a FieldConfig
482
-- getter, that is a function that takes the config and the object and
483
-- returns the Hvparam field specified when the getter was built.
484
hvParamGetter :: String -- ^ The field we're building the getter for
485
              -> ConfigData -> Instance -> ResultEntry
486
hvParamGetter field cfg inst =
487
  rsMaybeUnavail . Map.lookup field . fromContainer $
488
                                        getFilledInstHvParams cfg inst
489

    
490
-- * Live fields functionality
491

    
492
-- | List of node live fields.
493
instanceLiveFieldsDefs :: [(FieldName, FieldTitle, FieldType, String, FieldDoc)]
494
instanceLiveFieldsDefs =
495
  [ ("oper_ram", "Memory", QFTUnit, "oper_ram",
496
     "Actual memory usage as seen by hypervisor")
497
  , ("oper_vcpus", "VCPUs", QFTNumber, "oper_vcpus",
498
     "Actual number of VCPUs as seen by hypervisor")
499
  ]
500

    
501
-- | Map each name to a function that extracts that value from the RPC result.
502
instanceLiveFieldExtract :: FieldName -> InstanceInfo -> Instance -> J.JSValue
503
instanceLiveFieldExtract "oper_ram"   info _ = J.showJSON $ instInfoMemory info
504
instanceLiveFieldExtract "oper_vcpus" info _ = J.showJSON $ instInfoVcpus info
505
instanceLiveFieldExtract n _ _ = J.showJSON $
506
  "The field " ++ n ++ " is not an expected or extractable live field!"
507

    
508
-- | Helper for extracting field from RPC result.
509
instanceLiveRpcCall :: FieldName -> Runtime -> Instance -> ResultEntry
510
instanceLiveRpcCall fname (Right (Just (res, _))) inst =
511
  case instanceLiveFieldExtract fname res inst of
512
    J.JSNull -> rsNoData
513
    x        -> rsNormal x
514
instanceLiveRpcCall _ (Right Nothing) _ = rsUnavail
515
instanceLiveRpcCall _ (Left err) _ =
516
  ResultEntry (rpcErrorToStatus err) Nothing
517

    
518
-- | Builder for node live fields.
519
instanceLiveFieldBuilder :: (FieldName, FieldTitle, FieldType, String, FieldDoc)
520
                         -> FieldData Instance Runtime
521
instanceLiveFieldBuilder (fname, ftitle, ftype, _, fdoc) =
522
  ( FieldDefinition fname ftitle ftype fdoc
523
  , FieldRuntime $ instanceLiveRpcCall fname
524
  , QffNormal)
525

    
526
-- * Functionality related to status and operational status extraction
527

    
528
-- | The documentation text for the instance status field
529
statusDocText :: String
530
statusDocText =
531
  let si = show . instanceStatusToRaw :: InstanceStatus -> String
532
  in  "Instance status; " ++
533
      si Running ++
534
      " if instance is set to be running and actually is, " ++
535
      si StatusDown ++
536
      " if instance is stopped and is not running, " ++
537
      si WrongNode ++
538
      " if instance running, but not on its designated primary node, " ++
539
      si ErrorUp ++
540
      " if instance should be stopped, but is actually running, " ++
541
      si ErrorDown ++
542
      " if instance should run, but doesn't, " ++
543
      si NodeDown ++
544
      " if instance's primary node is down, " ++
545
      si NodeOffline ++
546
      " if instance's primary node is marked offline, " ++
547
      si StatusOffline ++
548
      " if instance is offline and does not use dynamic resources"
549

    
550
-- | Checks if the primary node of an instance is offline
551
isPrimaryOffline :: ConfigData -> Instance -> Bool
552
isPrimaryOffline cfg inst =
553
  let pNodeResult = getNode cfg $ instPrimaryNode inst
554
  in case pNodeResult of
555
     Ok pNode -> nodeOffline pNode
556
     Bad    _ -> error "Programmer error - result assumed to be OK is Bad!"
557

    
558
-- | Determines the status of a live instance
559
liveInstanceStatus :: LiveInfo -> Instance -> InstanceStatus
560
liveInstanceStatus (_, foundOnPrimary) inst
561
  | not foundOnPrimary    = WrongNode
562
  | adminState == AdminUp = Running
563
  | otherwise             = ErrorUp
564
  where adminState = instAdminState inst
565

    
566
-- | Determines the status of a dead instance.
567
deadInstanceStatus :: Instance -> InstanceStatus
568
deadInstanceStatus inst =
569
  case instAdminState inst of
570
    AdminUp      -> ErrorDown
571
    AdminDown    -> StatusDown
572
    AdminOffline -> StatusOffline
573

    
574
-- | Determines the status of the instance, depending on whether it is possible
575
-- to communicate with its primary node, on which node it is, and its
576
-- configuration.
577
determineInstanceStatus :: ConfigData      -- ^ The configuration data
578
                        -> Runtime         -- ^ All the data from the live call
579
                        -> Instance        -- ^ Static instance configuration
580
                        -> InstanceStatus  -- ^ Result
581
determineInstanceStatus cfg res inst
582
  | isPrimaryOffline cfg inst = NodeOffline
583
  | otherwise = case res of
584
                  Left _                -> NodeDown
585
                  Right (Just liveData) -> liveInstanceStatus liveData inst
586
                  Right Nothing         -> deadInstanceStatus inst
587

    
588
-- | Extracts the instance status, retrieving it using the functions above and
589
-- transforming it into a 'ResultEntry'.
590
statusExtract :: ConfigData -> Runtime -> Instance -> ResultEntry
591
statusExtract cfg res inst =
592
  rsNormal . J.showJSON . instanceStatusToRaw $
593
    determineInstanceStatus cfg res inst
594

    
595
-- | Extracts the operational status of the instance.
596
operStatusExtract :: Runtime -> Instance -> ResultEntry
597
operStatusExtract res _ =
598
  rsMaybeNoData $ J.showJSON <$>
599
    case res of
600
      Left  _ -> Nothing
601
      Right x -> Just $ isJust x
602

    
603
-- * Helper functions extracting information as necessary for the generic query
604
-- interfaces
605

    
606
-- | Finds information about the instance in the info delivered by a node
607
findInstanceInfo :: Instance
608
                 -> ERpcError RpcResultAllInstancesInfo
609
                 -> Maybe InstanceInfo
610
findInstanceInfo inst nodeResponse =
611
  case nodeResponse of
612
    Left  _err    -> Nothing
613
    Right allInfo ->
614
      let instances = rpcResAllInstInfoInstances allInfo
615
          maybeMatch = pickPairUnique (instName inst) instances
616
      in snd <$> maybeMatch
617

    
618
-- | Finds the node information ('RPCResultError') or the instance information
619
-- (Maybe 'LiveInfo').
620
extractLiveInfo :: [(Node, ERpcError RpcResultAllInstancesInfo)]
621
                -> Instance
622
                -> Runtime
623
extractLiveInfo nodeResultList inst =
624
  let uuidResultList = [(nodeUuid x, y) | (x, y) <- nodeResultList]
625
      pNodeUuid = instPrimaryNode inst
626
      maybeRPCError = getNodeStatus uuidResultList pNodeUuid
627
  in case maybeRPCError of
628
       Just err -> Left err
629
       Nothing  -> Right $ getInstanceStatus uuidResultList pNodeUuid inst
630

    
631
-- | Tries to find out if the node given by the uuid is bad - unreachable or
632
-- returning errors, does not mather for the purpose of this call.
633
getNodeStatus :: [(String, ERpcError RpcResultAllInstancesInfo)]
634
              -> String
635
              -> Maybe RpcError
636
getNodeStatus uuidList uuid =
637
  case snd <$> pickPairUnique uuid uuidList of
638
    Just (Left err) -> Just err
639
    Just (Right _)  -> Nothing
640
    Nothing         -> Just . RpcResultError $
641
                         "Primary node response not present"
642

    
643
-- | Retrieves the instance information if it is present anywhere in the all
644
-- instances RPC result. Notes if it originates from the primary node.
645
-- All nodes are represented as UUID's for ease of use.
646
getInstanceStatus :: [(String, ERpcError RpcResultAllInstancesInfo)]
647
                  -> String
648
                  -> Instance
649
                  -> Maybe LiveInfo
650
getInstanceStatus uuidList pNodeUuid inst =
651
  let primarySearchResult =
652
        snd <$> pickPairUnique pNodeUuid uuidList >>= findInstanceInfo inst
653
  in case primarySearchResult of
654
       Just instInfo -> Just (instInfo, True)
655
       Nothing       ->
656
         let allSearchResult =
657
               getFirst . mconcat $ map
658
               (First . findInstanceInfo inst . snd) uuidList
659
         in case allSearchResult of
660
              Just liveInfo -> Just (liveInfo, False)
661
              Nothing       -> Nothing
662

    
663
-- | Collect live data from RPC query if enabled.
664
collectLiveData :: Bool -> ConfigData -> [Instance] -> IO [(Instance, Runtime)]
665
collectLiveData liveDataEnabled cfg instances
666
  | not liveDataEnabled = return . zip instances . repeat . Left .
667
                            RpcResultError $ "Live data disabled"
668
  | otherwise = do
669
      let hvSpec = getDefaultHypervisorSpec cfg
670
          instance_nodes = nub . justOk $
671
                             map (getNode cfg . instPrimaryNode) instances
672
          good_nodes = nodesWithValidConfig cfg instance_nodes
673
      rpcres <- executeRpcCall good_nodes $ RpcCallAllInstancesInfo [hvSpec]
674
      return . zip instances . map (extractLiveInfo rpcres) $ instances