Statistics
| Branch: | Tag: | Revision:

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

History | View | Annotate | Download (34.2 kB)

1
{-| Implementation of the Ganeti Query2 instance queries.
2

    
3
-}
4

    
5
{-
6

    
7
Copyright (C) 2013 Google Inc.
8

    
9
This program is free software; you can redistribute it and/or modify
10
it under the terms of the GNU General Public License as published by
11
the Free Software Foundation; either version 2 of the License, or
12
(at your option) any later version.
13

    
14
This program is distributed in the hope that it will be useful, but
15
WITHOUT ANY WARRANTY; without even the implied warranty of
16
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
17
General Public License for more details.
18

    
19
You should have received a copy of the GNU General Public License
20
along with this program; if not, write to the Free Software
21
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
22
02110-1301, USA.
23

    
24
-}
25

    
26
module Ganeti.Query.Instance
27
  ( Runtime
28
  , fieldsMap
29
  , collectLiveData
30
  , getInstanceInfo
31
  , instanceFields
32
  , instanceAliases
33
  ) where
34

    
35
import Control.Applicative
36
import Data.Either
37
import Data.List
38
import Data.Maybe
39
import Data.Monoid
40
import qualified Data.Map as Map
41
import Data.Ord (comparing)
42
import qualified Text.JSON as J
43
import Text.Printf
44

    
45
import Ganeti.BasicTypes
46
import Ganeti.Common
47
import Ganeti.Config
48
import qualified Ganeti.Constants as C
49
import qualified Ganeti.ConstantUtils as C
50
import Ganeti.Errors
51
import Ganeti.JSON
52
import Ganeti.Objects
53
import Ganeti.Query.Common
54
import Ganeti.Query.Language
55
import Ganeti.Query.Types
56
import Ganeti.Rpc
57
import Ganeti.Storage.Utils
58
import Ganeti.Types
59
import Ganeti.Utils (formatOrdinal)
60

    
61
-- | The LiveInfo consists of two entries whose presence is independent.
62
-- The 'InstanceInfo' is the live instance information, accompanied by a bool
63
-- signifying if it was found on its designated primary node or not.
64
-- The 'InstanceConsoleInfo' describes how to connect to an instance.
65
-- Any combination of these may or may not be present, depending on node and
66
-- instance availability.
67
type LiveInfo = (Maybe (InstanceInfo, Bool), Maybe InstanceConsoleInfo)
68

    
69
-- | Runtime containing the 'LiveInfo'. See the genericQuery function in
70
-- the Query.hs file for an explanation of the terms used.
71
type Runtime = Either RpcError LiveInfo
72

    
73
-- | The instance fields map.
74
fieldsMap :: FieldMap Instance Runtime
75
fieldsMap = fieldListToFieldMap aliasedFields
76

    
77
-- | The instance aliases.
78
instanceAliases :: [(FieldName, FieldName)]
79
instanceAliases =
80
  [ ("vcpus", "be/vcpus")
81
  , ("be/memory", "be/maxmem")
82
  , ("sda_size", "disk.size/0")
83
  , ("sdb_size", "disk.size/1")
84
  , ("ip", "nic.ip/0")
85
  , ("mac", "nic.mac/0")
86
  , ("bridge", "nic.bridge/0")
87
  , ("nic_mode", "nic.mode/0")
88
  , ("nic_link", "nic.link/0")
89
  , ("nic_network", "nic.network/0")
90
  ]
91

    
92
-- | The aliased instance fields.
93
aliasedFields :: FieldList Instance Runtime
94
aliasedFields = aliasFields instanceAliases instanceFields
95

    
96
-- | The instance fields.
97
instanceFields :: FieldList Instance Runtime
98
instanceFields =
99
  -- Simple fields
100
  [ (FieldDefinition "admin_state" "InstanceState" QFTText
101
     "Desired state of instance",
102
     FieldSimple (rsNormal . adminStateToRaw . instAdminState), QffNormal)
103
  , (FieldDefinition "admin_up" "Autostart" QFTBool
104
     "Desired state of instance",
105
     FieldSimple (rsNormal . (== AdminUp) . instAdminState), QffNormal)
106
  , (FieldDefinition "disk_template" "Disk_template" QFTText
107
     "Instance disk template",
108
     FieldSimple (rsNormal . instDiskTemplate), QffNormal)
109
  , (FieldDefinition "disks_active" "DisksActive" QFTBool
110
     "Desired state of instance disks",
111
     FieldSimple (rsNormal . instDisksActive), QffNormal)
112
  , (FieldDefinition "name" "Instance" QFTText
113
     "Instance name",
114
     FieldSimple (rsNormal . instName), QffHostname)
115
  , (FieldDefinition "hypervisor" "Hypervisor" QFTText
116
     "Hypervisor name",
117
     FieldSimple (rsNormal . instHypervisor), QffNormal)
118
  , (FieldDefinition "network_port" "Network_port" QFTOther
119
     "Instance network port if available (e.g. for VNC console)",
120
     FieldSimple (rsMaybeUnavail . instNetworkPort), QffNormal)
121
  , (FieldDefinition "os" "OS" QFTText
122
     "Operating system",
123
     FieldSimple (rsNormal . instOs), QffNormal)
124
  , (FieldDefinition "pnode" "Primary_node" QFTText
125
     "Primary node",
126
     FieldConfig getPrimaryNodeName, QffHostname)
127
  , (FieldDefinition "pnode.group" "PrimaryNodeGroup" QFTText
128
     "Primary node's group",
129
     FieldConfig getPrimaryNodeGroupName, QffNormal)
130
  , (FieldDefinition "pnode.group.uuid" "PrimaryNodeGroupUUID" QFTText
131
     "Primary node's group UUID",
132
     FieldConfig getPrimaryNodeGroupUuid, QffNormal)
133
  , (FieldDefinition "snodes" "Secondary_Nodes" QFTOther
134
     "Secondary nodes; usually this will just be one node",
135
     FieldConfig (getSecondaryNodeAttribute nodeName), QffNormal)
136
  , (FieldDefinition "snodes.group" "SecondaryNodesGroups" QFTOther
137
     "Node groups of secondary nodes",
138
     FieldConfig (getSecondaryNodeGroupAttribute groupName), QffNormal)
139
  , (FieldDefinition "snodes.group.uuid" "SecondaryNodesGroupsUUID" QFTOther
140
     "Node group UUIDs of secondary nodes",
141
     FieldConfig (getSecondaryNodeGroupAttribute groupUuid), QffNormal)
142
  ] ++
143

    
144
  -- Instance parameter fields, whole
145
  [ (FieldDefinition "hvparams" "HypervisorParameters" QFTOther
146
     "Hypervisor parameters (merged)",
147
     FieldConfig
148
       ((rsNormal .) . getFilledInstHvParams (C.toList C.hvcGlobals)),
149
     QffNormal),
150

    
151
    (FieldDefinition "beparams" "BackendParameters" QFTOther
152
     "Backend parameters (merged)",
153
     FieldConfig ((rsErrorNoData .) . getFilledInstBeParams), QffNormal)
154
  , (FieldDefinition "osparams" "OpSysParameters" QFTOther
155
     "Operating system parameters (merged)",
156
     FieldConfig ((rsNormal .) . getFilledInstOsParams), QffNormal)
157
  , (FieldDefinition "custom_hvparams" "CustomHypervisorParameters" QFTOther
158
     "Custom hypervisor parameters",
159
     FieldSimple (rsNormal . instHvparams), QffNormal)
160
  , (FieldDefinition "custom_beparams" "CustomBackendParameters" QFTOther
161
     "Custom backend parameters",
162
     FieldSimple (rsNormal . instBeparams), QffNormal)
163
  , (FieldDefinition "custom_osparams" "CustomOpSysParameters" QFTOther
164
     "Custom operating system parameters",
165
     FieldSimple (rsNormal . instOsparams), QffNormal)
166
  , (FieldDefinition "custom_nicparams" "CustomNicParameters" QFTOther
167
     "Custom network interface parameters",
168
     FieldSimple (rsNormal . map nicNicparams . instNics), QffNormal)
169
  ] ++
170

    
171
  -- Instance parameter fields, generated
172
  map (buildBeParamField beParamGetter) allBeParamFields ++
173
  map (buildHvParamField hvParamGetter)
174
      (C.toList C.hvsParameters \\ C.toList C.hvcGlobals) ++
175

    
176
  -- Aggregate disk parameter fields
177
  [ (FieldDefinition "disk_usage" "DiskUsage" QFTUnit
178
     "Total disk space used by instance on each of its nodes; this is not the\
179
     \ disk size visible to the instance, but the usage on the node",
180
     FieldSimple (rsNormal . getDiskSizeRequirements), QffNormal)
181
  , (FieldDefinition "disk.count" "Disks" QFTNumber
182
     "Number of disks",
183
     FieldSimple (rsNormal . length . instDisks), QffNormal)
184
  , (FieldDefinition "disk.sizes" "Disk_sizes" QFTOther
185
     "List of disk sizes",
186
     FieldSimple (rsNormal . map diskSize . instDisks), QffNormal)
187
  , (FieldDefinition "disk.spindles" "Disk_spindles" QFTOther
188
     "List of disk spindles",
189
     FieldSimple (rsNormal . map (MaybeForJSON . diskSpindles) .
190
                  instDisks),
191
     QffNormal)
192
  , (FieldDefinition "disk.names" "Disk_names" QFTOther
193
     "List of disk names",
194
     FieldSimple (rsNormal . map (MaybeForJSON . diskName) .
195
                  instDisks),
196
     QffNormal)
197
  , (FieldDefinition "disk.uuids" "Disk_UUIDs" QFTOther
198
     "List of disk UUIDs",
199
     FieldSimple (rsNormal . map diskUuid . instDisks), QffNormal)
200
  ] ++
201

    
202
  -- Per-disk parameter fields
203
  instantiateIndexedFields C.maxDisks
204
  [ (fieldDefinitionCompleter "disk.size/%d" "Disk/%d" QFTUnit
205
     "Disk size of %s disk",
206
     getIndexedField instDisks diskSize, QffNormal)
207
  , (fieldDefinitionCompleter "disk.spindles/%d" "DiskSpindles/%d" QFTNumber
208
     "Spindles of %s disk",
209
     getIndexedOptionalField instDisks diskSpindles, QffNormal)
210
  , (fieldDefinitionCompleter "disk.name/%d" "DiskName/%d" QFTText
211
     "Name of %s disk",
212
     getIndexedOptionalField instDisks diskName, QffNormal)
213
  , (fieldDefinitionCompleter "disk.uuid/%d" "DiskUUID/%d" QFTText
214
     "UUID of %s disk",
215
     getIndexedField instDisks diskUuid, QffNormal)
216
  ] ++
217

    
218
  -- Aggregate nic parameter fields
219
  [ (FieldDefinition "nic.count" "NICs" QFTNumber
220
     "Number of network interfaces",
221
     FieldSimple (rsNormal . length . instNics), QffNormal)
222
  , (FieldDefinition "nic.macs" "NIC_MACs" QFTOther
223
     (nicAggDescPrefix ++ "MAC address"),
224
     FieldSimple (rsNormal . map nicMac . instNics), QffNormal)
225
  , (FieldDefinition "nic.ips" "NIC_IPs" QFTOther
226
     (nicAggDescPrefix ++ "IP address"),
227
     FieldSimple (rsNormal . map (MaybeForJSON . nicIp) . instNics),
228
     QffNormal)
229
  , (FieldDefinition "nic.names" "NIC_Names" QFTOther
230
     (nicAggDescPrefix ++ "name"),
231
     FieldSimple (rsNormal . map (MaybeForJSON . nicName) . instNics),
232
     QffNormal)
233
  , (FieldDefinition "nic.uuids" "NIC_UUIDs" QFTOther
234
     (nicAggDescPrefix ++ "UUID"),
235
     FieldSimple (rsNormal . map nicUuid . instNics), QffNormal)
236
  , (FieldDefinition "nic.modes" "NIC_modes" QFTOther
237
     (nicAggDescPrefix ++ "mode"),
238
     FieldConfig (\cfg -> rsNormal . map
239
       (nicpMode . fillNicParamsFromConfig cfg . nicNicparams)
240
       . instNics),
241
     QffNormal)
242
  , (FieldDefinition "nic.vlans" "NIC_VLANs" QFTOther
243
     (nicAggDescPrefix ++ "VLAN"),
244
     FieldConfig (\cfg -> rsNormal . map (MaybeForJSON . getNicVlan .
245
       fillNicParamsFromConfig cfg . nicNicparams) . instNics),
246
     QffNormal)
247
  , (FieldDefinition "nic.bridges" "NIC_bridges" QFTOther
248
     (nicAggDescPrefix ++ "bridge"),
249
     FieldConfig (\cfg -> rsNormal . map (MaybeForJSON . getNicBridge .
250
       fillNicParamsFromConfig cfg . nicNicparams) . instNics),
251
     QffNormal)
252
  , (FieldDefinition "nic.links" "NIC_links" QFTOther
253
     (nicAggDescPrefix ++ "link"),
254
     FieldConfig (\cfg -> rsNormal . map
255
       (nicpLink . fillNicParamsFromConfig cfg . nicNicparams)
256
       . instNics),
257
     QffNormal)
258
  , (FieldDefinition "nic.networks" "NIC_networks" QFTOther
259
     "List containing each interface's network",
260
     FieldSimple (rsNormal . map (MaybeForJSON . nicNetwork) . instNics),
261
     QffNormal)
262
  , (FieldDefinition "nic.networks.names" "NIC_networks_names" QFTOther
263
     "List containing the name of each interface's network",
264
     FieldConfig (\cfg -> rsNormal . map
265
       (\x -> MaybeForJSON (getNetworkName cfg <$> nicNetwork x))
266
       . instNics),
267
     QffNormal)
268
  ] ++
269

    
270
  -- Per-nic parameter fields
271
  instantiateIndexedFields C.maxNics
272
  [ (fieldDefinitionCompleter "nic.ip/%d" "NicIP/%d" QFTText
273
     ("IP address" ++ nicDescSuffix),
274
     getIndexedOptionalField instNics nicIp, QffNormal)
275
  , (fieldDefinitionCompleter "nic.uuid/%d" "NicUUID/%d" QFTText
276
     ("UUID address" ++ nicDescSuffix),
277
     getIndexedField instNics nicUuid, QffNormal)
278
  , (fieldDefinitionCompleter "nic.mac/%d" "NicMAC/%d" QFTText
279
     ("MAC address" ++ nicDescSuffix),
280
     getIndexedField instNics nicMac, QffNormal)
281
  , (fieldDefinitionCompleter "nic.name/%d" "NicName/%d" QFTText
282
     ("Name address" ++ nicDescSuffix),
283
     getIndexedOptionalField instNics nicName, QffNormal)
284
  , (fieldDefinitionCompleter "nic.network/%d" "NicNetwork/%d" QFTText
285
     ("Network" ++ nicDescSuffix),
286
     getIndexedOptionalField instNics nicNetwork, QffNormal)
287
  , (fieldDefinitionCompleter "nic.mode/%d" "NicMode/%d" QFTText
288
     ("Mode" ++ nicDescSuffix),
289
     getIndexedNicField nicpMode, QffNormal)
290
  , (fieldDefinitionCompleter "nic.link/%d" "NicLink/%d" QFTText
291
     ("Link" ++ nicDescSuffix),
292
     getIndexedNicField nicpLink, QffNormal)
293
  , (fieldDefinitionCompleter "nic.vlan/%d" "NicVLAN/%d" QFTText
294
     ("VLAN" ++ nicDescSuffix),
295
     getOptionalIndexedNicField getNicVlan, QffNormal)
296
  , (fieldDefinitionCompleter "nic.network.name/%d" "NicNetworkName/%d" QFTText
297
     ("Network name" ++ nicDescSuffix),
298
     getIndexedNicNetworkNameField, QffNormal)
299
  , (fieldDefinitionCompleter "nic.bridge/%d" "NicBridge/%d" QFTText
300
     ("Bridge" ++ nicDescSuffix),
301
     getOptionalIndexedNicField getNicBridge, QffNormal)
302
  ] ++
303

    
304
  -- Live fields using special getters
305
  [ (FieldDefinition "status" "Status" QFTText
306
     statusDocText,
307
     FieldConfigRuntime statusExtract, QffNormal)
308
  , (FieldDefinition "oper_state" "Running" QFTBool
309
     "Actual state of instance",
310
     FieldRuntime operStatusExtract, QffNormal),
311

    
312
    (FieldDefinition "console" "Console" QFTOther
313
     "Instance console information",
314
     FieldRuntime consoleExtract, QffNormal)
315
  ] ++
316

    
317
  -- Simple live fields
318
  map instanceLiveFieldBuilder instanceLiveFieldsDefs ++
319

    
320
  -- Common fields
321
  timeStampFields ++
322
  serialFields "Instance" ++
323
  uuidFields "Instance" ++
324
  tagsFields
325

    
326
-- * Helper functions for node property retrieval
327

    
328
-- | Constant suffix of network interface field descriptions.
329
nicDescSuffix ::String
330
nicDescSuffix = " of %s network interface"
331

    
332
-- | Almost-constant suffix of aggregate network interface field descriptions.
333
nicAggDescPrefix ::String
334
nicAggDescPrefix = "List containing each network interface's "
335

    
336
-- | Given a network name id, returns the network's name.
337
getNetworkName :: ConfigData -> String -> NonEmptyString
338
getNetworkName cfg = networkName . (Map.!) (fromContainer $ configNetworks cfg)
339

    
340
-- | Gets the bridge of a NIC.
341
getNicBridge :: FilledNicParams -> Maybe String
342
getNicBridge nicParams
343
  | nicpMode nicParams == NMBridged = Just $ nicpLink nicParams
344
  | otherwise                       = Nothing
345

    
346
-- | Gets the VLAN of a NIC.
347
getNicVlan :: FilledNicParams -> Maybe String
348
getNicVlan params
349
  | nicpMode params == NMOvs = Just $ nicpVlan params
350
  | otherwise                = Nothing
351

    
352
-- | Fill partial NIC params by using the defaults from the configuration.
353
fillNicParamsFromConfig :: ConfigData -> PartialNicParams -> FilledNicParams
354
fillNicParamsFromConfig cfg = fillNicParams (getDefaultNicParams cfg)
355

    
356
-- | Retrieves the default network interface parameters.
357
getDefaultNicParams :: ConfigData -> FilledNicParams
358
getDefaultNicParams cfg =
359
  (Map.!) (fromContainer . clusterNicparams . configCluster $ cfg) C.ppDefault
360

    
361
-- | Returns a field that retrieves a given NIC's network name.
362
getIndexedNicNetworkNameField :: Int -> FieldGetter Instance Runtime
363
getIndexedNicNetworkNameField index =
364
  FieldConfig (\cfg inst -> rsMaybeUnavail $ do
365
    nicObj <- maybeAt index $ instNics inst
366
    nicNetworkId <- nicNetwork nicObj
367
    return $ getNetworkName cfg nicNetworkId)
368

    
369
-- | Gets a fillable NIC field.
370
getIndexedNicField :: (J.JSON a)
371
                   => (FilledNicParams -> a)
372
                   -> Int
373
                   -> FieldGetter Instance Runtime
374
getIndexedNicField getter =
375
  getOptionalIndexedNicField (\x -> Just . getter $ x)
376

    
377
-- | Gets an optional fillable NIC field.
378
getOptionalIndexedNicField :: (J.JSON a)
379
                           => (FilledNicParams -> Maybe a)
380
                           -> Int
381
                           -> FieldGetter Instance Runtime
382
getOptionalIndexedNicField =
383
  getIndexedFieldWithDefault
384
    (map nicNicparams . instNics) (\x _ -> getDefaultNicParams x) fillNicParams
385

    
386
-- | Creates a function which produces a 'FieldGetter' when fed an index. Works
387
-- for fields that should be filled out through the use of a default.
388
getIndexedFieldWithDefault :: (J.JSON c)
389
  => (Instance -> [a])             -- ^ Extracts a list of incomplete objects
390
  -> (ConfigData -> Instance -> b) -- ^ Extracts the default object
391
  -> (b -> a -> b)                 -- ^ Fills the default object
392
  -> (b -> Maybe c)                -- ^ Extracts an obj property
393
  -> Int                           -- ^ Index in list to use
394
  -> FieldGetter Instance Runtime  -- ^ Result
395
getIndexedFieldWithDefault
396
  listGetter defaultGetter fillFn propertyGetter index =
397
  FieldConfig (\cfg inst -> rsMaybeUnavail $ do
398
                              incompleteObj <- maybeAt index $ listGetter inst
399
                              let defaultObj = defaultGetter cfg inst
400
                                  completeObj = fillFn defaultObj incompleteObj
401
                              propertyGetter completeObj)
402

    
403
-- | Creates a function which produces a 'FieldGetter' when fed an index. Works
404
-- for fields that may not return a value, expressed through the Maybe monad.
405
getIndexedOptionalField :: (J.JSON b)
406
                        => (Instance -> [a]) -- ^ Extracts a list of objects
407
                        -> (a -> Maybe b)    -- ^ Possibly gets a property
408
                                             -- from an object
409
                        -> Int               -- ^ Index in list to use
410
                        -> FieldGetter Instance Runtime -- ^ Result
411
getIndexedOptionalField extractor optPropertyGetter index =
412
  FieldSimple(\inst -> rsMaybeUnavail $ do
413
                         obj <- maybeAt index $ extractor inst
414
                         optPropertyGetter obj)
415

    
416
-- | Creates a function which produces a 'FieldGetter' when fed an index.
417
-- Works only for fields that surely return a value.
418
getIndexedField :: (J.JSON b)
419
                => (Instance -> [a]) -- ^ Extracts a list of objects
420
                -> (a -> b)          -- ^ Gets a property from an object
421
                -> Int               -- ^ Index in list to use
422
                -> FieldGetter Instance Runtime -- ^ Result
423
getIndexedField extractor propertyGetter index =
424
  let optPropertyGetter = Just . propertyGetter
425
  in getIndexedOptionalField extractor optPropertyGetter index
426

    
427
-- | Retrieves a value from an array at an index, using the Maybe monad to
428
-- indicate failure.
429
maybeAt :: Int -> [a] -> Maybe a
430
maybeAt index list
431
  | index >= length list = Nothing
432
  | otherwise            = Just $ list !! index
433

    
434
-- | Primed with format strings for everything but the type, it consumes two
435
-- values and uses them to complete the FieldDefinition.
436
-- Warning: a bit unsafe as it uses printf. Handle with care.
437
fieldDefinitionCompleter :: (PrintfArg t1) => (PrintfArg t2)
438
                         => FieldName
439
                         -> FieldTitle
440
                         -> FieldType
441
                         -> FieldDoc
442
                         -> t1
443
                         -> t2
444
                         -> FieldDefinition
445
fieldDefinitionCompleter fName fTitle fType fDoc firstVal secondVal =
446
  FieldDefinition (printf fName firstVal)
447
                  (printf fTitle firstVal)
448
                  fType
449
                  (printf fDoc secondVal)
450

    
451
-- | Given an incomplete field definition and values that can complete it,
452
-- return a fully functional FieldData. Cannot work for all cases, should be
453
-- extended as necessary.
454
fillIncompleteFields :: (t1 -> t2 -> FieldDefinition,
455
                         t1 -> FieldGetter a b,
456
                         QffMode)
457
                     -> t1
458
                     -> t2
459
                     -> FieldData a b
460
fillIncompleteFields (iDef, iGet, mode) firstVal secondVal =
461
  (iDef firstVal secondVal, iGet firstVal, mode)
462

    
463
-- | Given indexed fields that describe lists, complete / instantiate them for
464
-- a given list size.
465
instantiateIndexedFields :: (Show t1, Integral t1)
466
                         => Int            -- ^ The size of the list
467
                         -> [(t1 -> String -> FieldDefinition,
468
                              t1 -> FieldGetter a b,
469
                              QffMode)]    -- ^ The indexed fields
470
                         -> FieldList a b  -- ^ A list of complete fields
471
instantiateIndexedFields listSize fields = do
472
  index <- take listSize [0..]
473
  field <- fields
474
  return . fillIncompleteFields field index . formatOrdinal $ index + 1
475

    
476
-- * Various helper functions for property retrieval
477

    
478
-- | Helper function for primary node retrieval
479
getPrimaryNode :: ConfigData -> Instance -> ErrorResult Node
480
getPrimaryNode cfg = getInstPrimaryNode cfg . instName
481

    
482
-- | Get primary node hostname
483
getPrimaryNodeName :: ConfigData -> Instance -> ResultEntry
484
getPrimaryNodeName cfg inst =
485
  rsErrorNoData $ nodeName <$> getPrimaryNode cfg inst
486

    
487
-- | Get primary node group
488
getPrimaryNodeGroup :: ConfigData -> Instance -> ErrorResult NodeGroup
489
getPrimaryNodeGroup cfg inst = do
490
  pNode <- getPrimaryNode cfg inst
491
  maybeToError "Configuration missing" $ getGroupOfNode cfg pNode
492

    
493
-- | Get primary node group name
494
getPrimaryNodeGroupName :: ConfigData -> Instance -> ResultEntry
495
getPrimaryNodeGroupName cfg inst =
496
  rsErrorNoData $ groupName <$> getPrimaryNodeGroup cfg inst
497

    
498
-- | Get primary node group uuid
499
getPrimaryNodeGroupUuid :: ConfigData -> Instance -> ResultEntry
500
getPrimaryNodeGroupUuid cfg inst =
501
  rsErrorNoData $ groupUuid <$> getPrimaryNodeGroup cfg inst
502

    
503
-- | Get secondary nodes - the configuration objects themselves
504
getSecondaryNodes :: ConfigData -> Instance -> ErrorResult [Node]
505
getSecondaryNodes cfg inst = do
506
  pNode <- getPrimaryNode cfg inst
507
  allNodes <- getInstAllNodes cfg $ instName inst
508
  return $ delete pNode allNodes
509

    
510
-- | Get attributes of the secondary nodes
511
getSecondaryNodeAttribute :: (J.JSON a)
512
                          => (Node -> a)
513
                          -> ConfigData
514
                          -> Instance
515
                          -> ResultEntry
516
getSecondaryNodeAttribute getter cfg inst =
517
  rsErrorNoData $ map (J.showJSON . getter) <$> getSecondaryNodes cfg inst
518

    
519
-- | Get secondary node groups
520
getSecondaryNodeGroups :: ConfigData -> Instance -> ErrorResult [NodeGroup]
521
getSecondaryNodeGroups cfg inst = do
522
  sNodes <- getSecondaryNodes cfg inst
523
  return . catMaybes $ map (getGroupOfNode cfg) sNodes
524

    
525
-- | Get attributes of secondary node groups
526
getSecondaryNodeGroupAttribute :: (J.JSON a)
527
                               => (NodeGroup -> a)
528
                               -> ConfigData
529
                               -> Instance
530
                               -> ResultEntry
531
getSecondaryNodeGroupAttribute getter cfg inst =
532
  rsErrorNoData $ map (J.showJSON . getter) <$> getSecondaryNodeGroups cfg inst
533

    
534
-- | Beparam getter builder: given a field, it returns a FieldConfig
535
-- getter, that is a function that takes the config and the object and
536
-- returns the Beparam field specified when the getter was built.
537
beParamGetter :: String       -- ^ The field we are building the getter for
538
              -> ConfigData   -- ^ The configuration object
539
              -> Instance     -- ^ The instance configuration object
540
              -> ResultEntry  -- ^ The result
541
beParamGetter field config inst =
542
  case getFilledInstBeParams config inst of
543
    Ok beParams -> dictFieldGetter field $ Just beParams
544
    Bad       _ -> rsNoData
545

    
546
-- | Hvparam getter builder: given a field, it returns a FieldConfig
547
-- getter, that is a function that takes the config and the object and
548
-- returns the Hvparam field specified when the getter was built.
549
hvParamGetter :: String -- ^ The field we're building the getter for
550
              -> ConfigData -> Instance -> ResultEntry
551
hvParamGetter field cfg inst =
552
  rsMaybeUnavail . Map.lookup field . fromContainer $
553
    getFilledInstHvParams (C.toList C.hvcGlobals) cfg inst
554

    
555
-- * Live fields functionality
556

    
557
-- | List of node live fields.
558
instanceLiveFieldsDefs :: [(FieldName, FieldTitle, FieldType, String, FieldDoc)]
559
instanceLiveFieldsDefs =
560
  [ ("oper_ram", "Memory", QFTUnit, "oper_ram",
561
     "Actual memory usage as seen by hypervisor")
562
  , ("oper_vcpus", "VCPUs", QFTNumber, "oper_vcpus",
563
     "Actual number of VCPUs as seen by hypervisor")
564
  ]
565

    
566
-- | Map each name to a function that extracts that value from the RPC result.
567
instanceLiveFieldExtract :: FieldName -> InstanceInfo -> Instance -> J.JSValue
568
instanceLiveFieldExtract "oper_ram"   info _ = J.showJSON $ instInfoMemory info
569
instanceLiveFieldExtract "oper_vcpus" info _ = J.showJSON $ instInfoVcpus info
570
instanceLiveFieldExtract n _ _ = J.showJSON $
571
  "The field " ++ n ++ " is not an expected or extractable live field!"
572

    
573
-- | Helper for extracting an instance live field from the RPC results.
574
instanceLiveRpcCall :: FieldName -> Runtime -> Instance -> ResultEntry
575
instanceLiveRpcCall fname (Right (Just (res, _), _)) inst =
576
  case instanceLiveFieldExtract fname res inst of
577
    J.JSNull -> rsNoData
578
    x        -> rsNormal x
579
instanceLiveRpcCall _ (Right (Nothing, _)) _ = rsUnavail
580
instanceLiveRpcCall _ (Left err) _ =
581
  ResultEntry (rpcErrorToStatus err) Nothing
582

    
583
-- | Builder for node live fields.
584
instanceLiveFieldBuilder :: (FieldName, FieldTitle, FieldType, String, FieldDoc)
585
                         -> FieldData Instance Runtime
586
instanceLiveFieldBuilder (fname, ftitle, ftype, _, fdoc) =
587
  ( FieldDefinition fname ftitle ftype fdoc
588
  , FieldRuntime $ instanceLiveRpcCall fname
589
  , QffNormal)
590

    
591
-- * Functionality related to status and operational status extraction
592

    
593
-- | The documentation text for the instance status field
594
statusDocText :: String
595
statusDocText =
596
  let si = show . instanceStatusToRaw :: InstanceStatus -> String
597
  in  "Instance status; " ++
598
      si Running ++
599
      " if instance is set to be running and actually is, " ++
600
      si StatusDown ++
601
      " if instance is stopped and is not running, " ++
602
      si WrongNode ++
603
      " if instance running, but not on its designated primary node, " ++
604
      si ErrorUp ++
605
      " if instance should be stopped, but is actually running, " ++
606
      si ErrorDown ++
607
      " if instance should run, but doesn't, " ++
608
      si NodeDown ++
609
      " if instance's primary node is down, " ++
610
      si NodeOffline ++
611
      " if instance's primary node is marked offline, " ++
612
      si StatusOffline ++
613
      " if instance is offline and does not use dynamic resources"
614

    
615
-- | Checks if the primary node of an instance is offline
616
isPrimaryOffline :: ConfigData -> Instance -> Bool
617
isPrimaryOffline cfg inst =
618
  let pNodeResult = getNode cfg $ instPrimaryNode inst
619
  in case pNodeResult of
620
     Ok pNode -> nodeOffline pNode
621
     Bad    _ -> error "Programmer error - result assumed to be OK is Bad!"
622

    
623
-- | Determines the status of a live instance
624
liveInstanceStatus :: (InstanceInfo, Bool) -> Instance -> InstanceStatus
625
liveInstanceStatus (instInfo, foundOnPrimary) inst
626
  | not foundOnPrimary = WrongNode
627
  | otherwise =
628
    case instanceState of
629
      InstanceStateRunning | adminState == AdminUp -> Running
630
                           | otherwise -> ErrorUp
631
      InstanceStateShutdown | adminState == AdminUp && allowDown -> UserDown
632
                            | otherwise -> StatusDown
633
  where adminState = instAdminState inst
634
        instanceState = instInfoState instInfo
635

    
636
        hvparams = fromContainer $ instHvparams inst
637

    
638
        allowDown =
639
          instHypervisor inst /= Kvm ||
640
          (Map.member C.hvKvmUserShutdown hvparams &&
641
           hvparams Map.! C.hvKvmUserShutdown == J.JSBool True)
642

    
643
-- | Determines the status of a dead instance.
644
deadInstanceStatus :: Instance -> InstanceStatus
645
deadInstanceStatus inst =
646
  case instAdminState inst of
647
    AdminUp      -> ErrorDown
648
    AdminDown    -> StatusDown
649
    AdminOffline -> StatusOffline
650

    
651
-- | Determines the status of the instance, depending on whether it is possible
652
-- to communicate with its primary node, on which node it is, and its
653
-- configuration.
654
determineInstanceStatus :: ConfigData      -- ^ The configuration data
655
                        -> Runtime         -- ^ All the data from the live call
656
                        -> Instance        -- ^ Static instance configuration
657
                        -> InstanceStatus  -- ^ Result
658
determineInstanceStatus cfg res inst
659
  | isPrimaryOffline cfg inst = NodeOffline
660
  | otherwise = case res of
661
      Left _                   -> NodeDown
662
      Right (Just liveData, _) -> liveInstanceStatus liveData inst
663
      Right (Nothing, _)       -> deadInstanceStatus inst
664

    
665
-- | Extracts the instance status, retrieving it using the functions above and
666
-- transforming it into a 'ResultEntry'.
667
statusExtract :: ConfigData -> Runtime -> Instance -> ResultEntry
668
statusExtract cfg res inst =
669
  rsNormal . J.showJSON . instanceStatusToRaw $
670
    determineInstanceStatus cfg res inst
671

    
672
-- | Extracts the operational status of the instance.
673
operStatusExtract :: Runtime -> Instance -> ResultEntry
674
operStatusExtract res _ =
675
  rsMaybeNoData $ J.showJSON <$>
676
    case res of
677
      Left _       -> Nothing
678
      Right (x, _) -> Just $ isJust x
679

    
680
-- | Extracts the console connection information
681
consoleExtract :: Runtime -> Instance -> ResultEntry
682
consoleExtract (Left err) _ = ResultEntry (rpcErrorToStatus err) Nothing
683
consoleExtract (Right (_, val)) _ = rsMaybeNoData val
684

    
685
-- * Helper functions extracting information as necessary for the generic query
686
-- interfaces
687

    
688
-- | This function checks if a node with a given uuid has experienced an error
689
-- or not.
690
checkForNodeError :: [(String, ERpcError a)]
691
                  -> String
692
                  -> Maybe RpcError
693
checkForNodeError uuidList uuid =
694
  case snd <$> pickPairUnique uuid uuidList of
695
    Just (Left err) -> Just err
696
    Just (Right _)  -> Nothing
697
    Nothing         -> Just . RpcResultError $
698
                         "Node response not present"
699

    
700
-- | Finds information about the instance in the info delivered by a node
701
findInfoInNodeResult :: Instance
702
                     -> ERpcError RpcResultAllInstancesInfo
703
                     -> Maybe InstanceInfo
704
findInfoInNodeResult inst nodeResponse =
705
  case nodeResponse of
706
    Left  _err    -> Nothing
707
    Right allInfo ->
708
      let instances = rpcResAllInstInfoInstances allInfo
709
          maybeMatch = pickPairUnique (instName inst) instances
710
      in snd <$> maybeMatch
711

    
712
-- | Retrieves the instance information if it is present anywhere in the all
713
-- instances RPC result. Notes if it originates from the primary node.
714
-- An error is delivered if there is no result, and the primary node is down.
715
getInstanceInfo :: [(String, ERpcError RpcResultAllInstancesInfo)]
716
                -> Instance
717
                -> ERpcError (Maybe (InstanceInfo, Bool))
718
getInstanceInfo uuidList inst =
719
  let pNodeUuid = instPrimaryNode inst
720
      primarySearchResult =
721
        pickPairUnique pNodeUuid uuidList >>= findInfoInNodeResult inst . snd
722
  in case primarySearchResult of
723
       Just instInfo -> Right . Just $ (instInfo, True)
724
       Nothing       ->
725
         let allSearchResult =
726
               getFirst . mconcat $ map
727
               (First . findInfoInNodeResult inst . snd) uuidList
728
         in case allSearchResult of
729
              Just instInfo -> Right . Just $ (instInfo, False)
730
              Nothing       ->
731
                case checkForNodeError uuidList pNodeUuid of
732
                  Just err -> Left err
733
                  Nothing  -> Right Nothing
734

    
735
-- | Retrieves the console information if present anywhere in the given results
736
getConsoleInfo :: [(String, ERpcError RpcResultInstanceConsoleInfo)]
737
               -> Instance
738
               -> Maybe InstanceConsoleInfo
739
getConsoleInfo uuidList inst =
740
  let allValidResults = concatMap rpcResInstConsInfoInstancesInfo .
741
                        rights . map snd $ uuidList
742
  in snd <$> pickPairUnique (instName inst) allValidResults
743

    
744
-- | Extracts all the live information that can be extracted.
745
extractLiveInfo :: [(Node, ERpcError RpcResultAllInstancesInfo)]
746
                -> [(Node, ERpcError RpcResultInstanceConsoleInfo)]
747
                -> Instance
748
                -> Runtime
749
extractLiveInfo nodeResultList nodeConsoleList inst =
750
  let uuidConvert     = map (\(x, y) -> (nodeUuid x, y))
751
      uuidResultList  = uuidConvert nodeResultList
752
      uuidConsoleList = uuidConvert nodeConsoleList
753
  in case getInstanceInfo uuidResultList inst of
754
    -- If we can't get the instance info, we can't get the console info either.
755
    -- Best to propagate the error further.
756
    Left err  -> Left err
757
    Right res -> Right (res, getConsoleInfo uuidConsoleList inst)
758

    
759
-- | Retrieves all the parameters for the console calls.
760
getAllConsoleParams :: ConfigData
761
                    -> [Instance]
762
                    -> ErrorResult [InstanceConsoleInfoParams]
763
getAllConsoleParams cfg = mapM $ \i ->
764
  InstanceConsoleInfoParams i
765
    <$> getPrimaryNode cfg i
766
    <*> getPrimaryNodeGroup cfg i
767
    <*> pure (getFilledInstHvParams [] cfg i)
768
    <*> getFilledInstBeParams cfg i
769

    
770
-- | Compares two params according to their node, needed for grouping.
771
compareParamsByNode :: InstanceConsoleInfoParams
772
                    -> InstanceConsoleInfoParams
773
                    -> Bool
774
compareParamsByNode x y = instConsInfoParamsNode x == instConsInfoParamsNode y
775

    
776
-- | Groups instance information calls heading out to the same nodes.
777
consoleParamsToCalls :: [InstanceConsoleInfoParams]
778
                     -> [(Node, RpcCallInstanceConsoleInfo)]
779
consoleParamsToCalls params =
780
  let sortedParams = sortBy
781
        (comparing (instPrimaryNode . instConsInfoParamsInstance)) params
782
      groupedParams = groupBy compareParamsByNode sortedParams
783
  in map (\x -> case x of
784
            [] -> error "Programmer error: group must have one or more members"
785
            paramGroup@(y:_) ->
786
              let node = instConsInfoParamsNode y
787
                  packer z = (instName $ instConsInfoParamsInstance z, z)
788
              in (node, RpcCallInstanceConsoleInfo . map packer $ paramGroup)
789
         ) groupedParams
790

    
791
-- | Retrieves a list of all the hypervisors and params used by the given
792
-- instances.
793
getHypervisorSpecs :: ConfigData -> [Instance] -> [(Hypervisor, HvParams)]
794
getHypervisorSpecs cfg instances =
795
  let hvs = nub . map instHypervisor $ instances
796
      hvParamMap = (fromContainer . clusterHvparams . configCluster $ cfg)
797
  in zip hvs . map ((Map.!) hvParamMap . hypervisorToRaw) $ hvs
798

    
799
-- | Collect live data from RPC query if enabled.
800
collectLiveData :: Bool        -- ^ Live queries allowed
801
                -> ConfigData  -- ^ The cluster config
802
                -> [String]    -- ^ The requested fields
803
                -> [Instance]  -- ^ The instance objects
804
                -> IO [(Instance, Runtime)]
805
collectLiveData liveDataEnabled cfg fields instances
806
  | not liveDataEnabled = return . zip instances . repeat . Left .
807
                            RpcResultError $ "Live data disabled"
808
  | otherwise = do
809
      let hvSpecs = getHypervisorSpecs cfg instances
810
          instanceNodes = nub . justOk $
811
                            map (getNode cfg . instPrimaryNode) instances
812
          goodNodes = nodesWithValidConfig cfg instanceNodes
813
      instInfoRes <- executeRpcCall goodNodes (RpcCallAllInstancesInfo hvSpecs)
814
      consInfoRes <-
815
        if "console" `elem` fields
816
          then case getAllConsoleParams cfg instances of
817
            Ok  p -> executeRpcCalls $ consoleParamsToCalls p
818
            Bad _ -> return . zip goodNodes . repeat . Left $
819
              RpcResultError "Cannot construct parameters for console info call"
820
          else return [] -- The information is not necessary
821
      return . zip instances .
822
        map (extractLiveInfo instInfoRes consInfoRes) $ instances