Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Objects.hs @ 88b58ed6

History | View | Annotate | Download (24.3 kB)

1
{-# LANGUAGE TemplateHaskell #-}
2

    
3
{-| Implementation of the Ganeti config objects.
4

    
5
Some object fields are not implemented yet, and as such they are
6
commented out below.
7

    
8
-}
9

    
10
{-
11

    
12
Copyright (C) 2011, 2012, 2013 Google Inc.
13

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

    
19
This program is distributed in the hope that it will be useful, but
20
WITHOUT ANY WARRANTY; without even the implied warranty of
21
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
22
General Public License for more details.
23

    
24
You should have received a copy of the GNU General Public License
25
along with this program; if not, write to the Free Software
26
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
27
02110-1301, USA.
28

    
29
-}
30

    
31
module Ganeti.Objects
32
  ( HvParams
33
  , OsParams
34
  , PartialNicParams(..)
35
  , FilledNicParams(..)
36
  , fillNicParams
37
  , allNicParamFields
38
  , PartialNic(..)
39
  , FileDriver(..)
40
  , DiskLogicalId(..)
41
  , Disk(..)
42
  , includesLogicalId
43
  , DiskTemplate(..)
44
  , PartialBeParams(..)
45
  , FilledBeParams(..)
46
  , fillBeParams
47
  , allBeParamFields
48
  , Instance(..)
49
  , toDictInstance
50
  , getDiskSizeRequirements
51
  , PartialNDParams(..)
52
  , FilledNDParams(..)
53
  , fillNDParams
54
  , allNDParamFields
55
  , Node(..)
56
  , AllocPolicy(..)
57
  , FilledISpecParams(..)
58
  , PartialISpecParams(..)
59
  , fillISpecParams
60
  , allISpecParamFields
61
  , MinMaxISpecs(..)
62
  , FilledIPolicy(..)
63
  , PartialIPolicy(..)
64
  , fillIPolicy
65
  , DiskParams
66
  , NodeGroup(..)
67
  , IpFamily(..)
68
  , ipFamilyToVersion
69
  , fillDict
70
  , ClusterHvParams
71
  , OsHvParams
72
  , ClusterBeParams
73
  , ClusterOsParams
74
  , ClusterNicParams
75
  , Cluster(..)
76
  , ConfigData(..)
77
  , TimeStampObject(..)
78
  , UuidObject(..)
79
  , SerialNoObject(..)
80
  , TagsObject(..)
81
  , DictObject(..) -- re-exported from THH
82
  , TagSet -- re-exported from THH
83
  , Network(..)
84
  , Ip4Address(..)
85
  , Ip4Network(..)
86
  , readIp4Address
87
  , nextIp4Address
88
  ) where
89

    
90
import Control.Applicative
91
import Data.List (foldl')
92
import Data.Maybe
93
import qualified Data.Map as Map
94
import qualified Data.Set as Set
95
import Data.Word
96
import Text.JSON (showJSON, readJSON, JSON, JSValue(..), fromJSString)
97
import qualified Text.JSON as J
98

    
99
import qualified Ganeti.Constants as C
100
import qualified Ganeti.ConstantUtils as ConstantUtils
101
import Ganeti.JSON
102
import Ganeti.Types
103
import Ganeti.THH
104
import Ganeti.Utils (sepSplit, tryRead)
105

    
106
-- * Generic definitions
107

    
108
-- | Fills one map with keys from the other map, if not already
109
-- existing. Mirrors objects.py:FillDict.
110
fillDict :: (Ord k) => Map.Map k v -> Map.Map k v -> [k] -> Map.Map k v
111
fillDict defaults custom skip_keys =
112
  let updated = Map.union custom defaults
113
  in foldl' (flip Map.delete) updated skip_keys
114

    
115
-- | The hypervisor parameter type. This is currently a simple map,
116
-- without type checking on key/value pairs.
117
type HvParams = Container JSValue
118

    
119
-- | The OS parameters type. This is, and will remain, a string
120
-- container, since the keys are dynamically declared by the OSes, and
121
-- the values are always strings.
122
type OsParams = Container String
123

    
124
-- | Class of objects that have timestamps.
125
class TimeStampObject a where
126
  cTimeOf :: a -> Double
127
  mTimeOf :: a -> Double
128

    
129
-- | Class of objects that have an UUID.
130
class UuidObject a where
131
  uuidOf :: a -> String
132

    
133
-- | Class of object that have a serial number.
134
class SerialNoObject a where
135
  serialOf :: a -> Int
136

    
137
-- | Class of objects that have tags.
138
class TagsObject a where
139
  tagsOf :: a -> Set.Set String
140

    
141
-- * Network definitions
142

    
143
-- ** Ipv4 types
144

    
145
-- | Custom type for a simple IPv4 address.
146
data Ip4Address = Ip4Address Word8 Word8 Word8 Word8
147
                  deriving Eq
148

    
149
instance Show Ip4Address where
150
  show (Ip4Address a b c d) = show a ++ "." ++ show b ++ "." ++
151
                              show c ++ "." ++ show d
152

    
153
-- | Parses an IPv4 address from a string.
154
readIp4Address :: (Applicative m, Monad m) => String -> m Ip4Address
155
readIp4Address s =
156
  case sepSplit '.' s of
157
    [a, b, c, d] -> Ip4Address <$>
158
                      tryRead "first octect" a <*>
159
                      tryRead "second octet" b <*>
160
                      tryRead "third octet"  c <*>
161
                      tryRead "fourth octet" d
162
    _ -> fail $ "Can't parse IPv4 address from string " ++ s
163

    
164
-- | JSON instance for 'Ip4Address'.
165
instance JSON Ip4Address where
166
  showJSON = showJSON . show
167
  readJSON (JSString s) = readIp4Address (fromJSString s)
168
  readJSON v = fail $ "Invalid JSON value " ++ show v ++ " for an IPv4 address"
169

    
170
-- | \"Next\" address implementation for IPv4 addresses.
171
--
172
-- Note that this loops! Note also that this is a very dumb
173
-- implementation.
174
nextIp4Address :: Ip4Address -> Ip4Address
175
nextIp4Address (Ip4Address a b c d) =
176
  let inc xs y = if all (==0) xs then y + 1 else y
177
      d' = d + 1
178
      c' = inc [d'] c
179
      b' = inc [c', d'] b
180
      a' = inc [b', c', d'] a
181
  in Ip4Address a' b' c' d'
182

    
183
-- | Custom type for an IPv4 network.
184
data Ip4Network = Ip4Network Ip4Address Word8
185
                  deriving Eq
186

    
187
instance Show Ip4Network where
188
  show (Ip4Network ip netmask) = show ip ++ "/" ++ show netmask
189

    
190
-- | JSON instance for 'Ip4Network'.
191
instance JSON Ip4Network where
192
  showJSON = showJSON . show
193
  readJSON (JSString s) =
194
    case sepSplit '/' (fromJSString s) of
195
      [ip, nm] -> do
196
        ip' <- readIp4Address ip
197
        nm' <- tryRead "parsing netmask" nm
198
        if nm' >= 0 && nm' <= 32
199
          then return $ Ip4Network ip' nm'
200
          else fail $ "Invalid netmask " ++ show nm' ++ " from string " ++
201
                      fromJSString s
202
      _ -> fail $ "Can't parse IPv4 network from string " ++ fromJSString s
203
  readJSON v = fail $ "Invalid JSON value " ++ show v ++ " for an IPv4 network"
204

    
205
-- ** Ganeti \"network\" config object.
206

    
207
-- FIXME: Not all types might be correct here, since they
208
-- haven't been exhaustively deduced from the python code yet.
209
$(buildObject "Network" "network" $
210
  [ simpleField "name"             [t| NonEmptyString |]
211
  , optionalField $
212
    simpleField "mac_prefix"       [t| String |]
213
  , simpleField "network"          [t| Ip4Network |]
214
  , optionalField $
215
    simpleField "network6"         [t| String |]
216
  , optionalField $
217
    simpleField "gateway"          [t| Ip4Address |]
218
  , optionalField $
219
    simpleField "gateway6"         [t| String |]
220
  , optionalField $
221
    simpleField "reservations"     [t| String |]
222
  , optionalField $
223
    simpleField "ext_reservations" [t| String |]
224
  ]
225
  ++ uuidFields
226
  ++ timeStampFields
227
  ++ serialFields
228
  ++ tagsFields)
229

    
230
instance SerialNoObject Network where
231
  serialOf = networkSerial
232

    
233
instance TagsObject Network where
234
  tagsOf = networkTags
235

    
236
instance UuidObject Network where
237
  uuidOf = networkUuid
238

    
239
instance TimeStampObject Network where
240
  cTimeOf = networkCtime
241
  mTimeOf = networkMtime
242

    
243
-- * NIC definitions
244

    
245
$(buildParam "Nic" "nicp"
246
  [ simpleField "mode" [t| NICMode |]
247
  , simpleField "link" [t| String  |]
248
  , simpleField "vlan" [t| Maybe String |]
249
  ])
250

    
251
$(buildObject "PartialNic" "nic" $
252
  [ simpleField "mac" [t| String |]
253
  , optionalField $ simpleField "ip" [t| String |]
254
  , simpleField "nicparams" [t| PartialNicParams |]
255
  , optionalField $ simpleField "network" [t| String |]
256
  , optionalField $ simpleField "name" [t| String |]
257
  ] ++ uuidFields)
258

    
259
instance UuidObject PartialNic where
260
  uuidOf = nicUuid
261

    
262
-- * Disk definitions
263

    
264
-- | Constant for the dev_type key entry in the disk config.
265
devType :: String
266
devType = "dev_type"
267

    
268
-- | The disk configuration type. This includes the disk type itself,
269
-- for a more complete consistency. Note that since in the Python
270
-- code-base there's no authoritative place where we document the
271
-- logical id, this is probably a good reference point.
272
data DiskLogicalId
273
  = LIDPlain String String  -- ^ Volume group, logical volume
274
  | LIDDrbd8 String String Int Int Int String
275
  -- ^ NodeA, NodeB, Port, MinorA, MinorB, Secret
276
  | LIDFile FileDriver String -- ^ Driver, path
277
  | LIDSharedFile FileDriver String -- ^ Driver, path
278
  | LIDBlockDev BlockDriver String -- ^ Driver, path (must be under /dev)
279
  | LIDRados String String -- ^ Unused, path
280
  | LIDExt String String -- ^ ExtProvider, unique name
281
    deriving (Show, Eq)
282

    
283
-- | Mapping from a logical id to a disk type.
284
lidDiskType :: DiskLogicalId -> DiskTemplate
285
lidDiskType (LIDPlain {}) = DTPlain
286
lidDiskType (LIDDrbd8 {}) = DTDrbd8
287
lidDiskType (LIDFile  {}) = DTFile
288
lidDiskType (LIDSharedFile  {}) = DTSharedFile
289
lidDiskType (LIDBlockDev {}) = DTBlock
290
lidDiskType (LIDRados {}) = DTRbd
291
lidDiskType (LIDExt {}) = DTExt
292

    
293
-- | Builds the extra disk_type field for a given logical id.
294
lidEncodeType :: DiskLogicalId -> [(String, JSValue)]
295
lidEncodeType v = [(devType, showJSON . lidDiskType $ v)]
296

    
297
-- | Custom encoder for DiskLogicalId (logical id only).
298
encodeDLId :: DiskLogicalId -> JSValue
299
encodeDLId (LIDPlain vg lv) = JSArray [showJSON vg, showJSON lv]
300
encodeDLId (LIDDrbd8 nodeA nodeB port minorA minorB key) =
301
  JSArray [ showJSON nodeA, showJSON nodeB, showJSON port
302
          , showJSON minorA, showJSON minorB, showJSON key ]
303
encodeDLId (LIDRados pool name) = JSArray [showJSON pool, showJSON name]
304
encodeDLId (LIDFile driver name) = JSArray [showJSON driver, showJSON name]
305
encodeDLId (LIDSharedFile driver name) =
306
  JSArray [showJSON driver, showJSON name]
307
encodeDLId (LIDBlockDev driver name) = JSArray [showJSON driver, showJSON name]
308
encodeDLId (LIDExt extprovider name) =
309
  JSArray [showJSON extprovider, showJSON name]
310

    
311
-- | Custom encoder for DiskLogicalId, composing both the logical id
312
-- and the extra disk_type field.
313
encodeFullDLId :: DiskLogicalId -> (JSValue, [(String, JSValue)])
314
encodeFullDLId v = (encodeDLId v, lidEncodeType v)
315

    
316
-- | Custom decoder for DiskLogicalId. This is manual for now, since
317
-- we don't have yet automation for separate-key style fields.
318
decodeDLId :: [(String, JSValue)] -> JSValue -> J.Result DiskLogicalId
319
decodeDLId obj lid = do
320
  dtype <- fromObj obj devType
321
  case dtype of
322
    DTDrbd8 ->
323
      case lid of
324
        JSArray [nA, nB, p, mA, mB, k] -> do
325
          nA' <- readJSON nA
326
          nB' <- readJSON nB
327
          p'  <- readJSON p
328
          mA' <- readJSON mA
329
          mB' <- readJSON mB
330
          k'  <- readJSON k
331
          return $ LIDDrbd8 nA' nB' p' mA' mB' k'
332
        _ -> fail "Can't read logical_id for DRBD8 type"
333
    DTPlain ->
334
      case lid of
335
        JSArray [vg, lv] -> do
336
          vg' <- readJSON vg
337
          lv' <- readJSON lv
338
          return $ LIDPlain vg' lv'
339
        _ -> fail "Can't read logical_id for plain type"
340
    DTFile ->
341
      case lid of
342
        JSArray [driver, path] -> do
343
          driver' <- readJSON driver
344
          path'   <- readJSON path
345
          return $ LIDFile driver' path'
346
        _ -> fail "Can't read logical_id for file type"
347
    DTSharedFile ->
348
      case lid of
349
        JSArray [driver, path] -> do
350
          driver' <- readJSON driver
351
          path'   <- readJSON path
352
          return $ LIDSharedFile driver' path'
353
        _ -> fail "Can't read logical_id for shared file type"
354
    DTBlock ->
355
      case lid of
356
        JSArray [driver, path] -> do
357
          driver' <- readJSON driver
358
          path'   <- readJSON path
359
          return $ LIDBlockDev driver' path'
360
        _ -> fail "Can't read logical_id for blockdev type"
361
    DTRbd ->
362
      case lid of
363
        JSArray [driver, path] -> do
364
          driver' <- readJSON driver
365
          path'   <- readJSON path
366
          return $ LIDRados driver' path'
367
        _ -> fail "Can't read logical_id for rdb type"
368
    DTExt ->
369
      case lid of
370
        JSArray [extprovider, name] -> do
371
          extprovider' <- readJSON extprovider
372
          name'   <- readJSON name
373
          return $ LIDExt extprovider' name'
374
        _ -> fail "Can't read logical_id for extstorage type"
375
    DTDiskless ->
376
      fail "Retrieved 'diskless' disk."
377

    
378
-- | Disk data structure.
379
--
380
-- This is declared manually as it's a recursive structure, and our TH
381
-- code currently can't build it.
382
data Disk = Disk
383
  { diskLogicalId  :: DiskLogicalId
384
  , diskChildren   :: [Disk]
385
  , diskIvName     :: String
386
  , diskSize       :: Int
387
  , diskMode       :: DiskMode
388
  , diskName       :: Maybe String
389
  , diskSpindles   :: Maybe Int
390
  , diskUuid       :: String
391
  } deriving (Show, Eq)
392

    
393
$(buildObjectSerialisation "Disk" $
394
  [ customField 'decodeDLId 'encodeFullDLId ["dev_type"] $
395
      simpleField "logical_id"    [t| DiskLogicalId   |]
396
  , defaultField  [| [] |] $ simpleField "children" [t| [Disk] |]
397
  , defaultField [| "" |] $ simpleField "iv_name" [t| String |]
398
  , simpleField "size" [t| Int |]
399
  , defaultField [| DiskRdWr |] $ simpleField "mode" [t| DiskMode |]
400
  , optionalField $ simpleField "name" [t| String |]
401
  , optionalField $ simpleField "spindles" [t| Int |]
402
  ]
403
  ++ uuidFields)
404

    
405
instance UuidObject Disk where
406
  uuidOf = diskUuid
407

    
408
-- | Determines whether a disk or one of his children has the given logical id
409
-- (determined by the volume group name and by the logical volume name).
410
-- This can be true only for DRBD or LVM disks.
411
includesLogicalId :: String -> String -> Disk -> Bool
412
includesLogicalId vg_name lv_name disk =
413
  case diskLogicalId disk of
414
    LIDPlain vg lv -> vg_name == vg && lv_name == lv
415
    LIDDrbd8 {} ->
416
      any (includesLogicalId vg_name lv_name) $ diskChildren disk
417
    _ -> False
418

    
419
-- * Instance definitions
420

    
421
$(buildParam "Be" "bep"
422
  [ simpleField "minmem"          [t| Int  |]
423
  , simpleField "maxmem"          [t| Int  |]
424
  , simpleField "vcpus"           [t| Int  |]
425
  , simpleField "auto_balance"    [t| Bool |]
426
  , simpleField "always_failover" [t| Bool |]
427
  , simpleField "spindle_use"     [t| Int  |]
428
  ])
429

    
430
$(buildObject "Instance" "inst" $
431
  [ simpleField "name"           [t| String             |]
432
  , simpleField "primary_node"   [t| String             |]
433
  , simpleField "os"             [t| String             |]
434
  , simpleField "hypervisor"     [t| Hypervisor         |]
435
  , simpleField "hvparams"       [t| HvParams           |]
436
  , simpleField "beparams"       [t| PartialBeParams    |]
437
  , simpleField "osparams"       [t| OsParams           |]
438
  , simpleField "admin_state"    [t| AdminState         |]
439
  , simpleField "nics"           [t| [PartialNic]       |]
440
  , simpleField "disks"          [t| [Disk]             |]
441
  , simpleField "disk_template"  [t| DiskTemplate       |]
442
  , simpleField "disks_active"   [t| Bool               |]
443
  , optionalField $ simpleField "network_port" [t| Int  |]
444
  ]
445
  ++ timeStampFields
446
  ++ uuidFields
447
  ++ serialFields
448
  ++ tagsFields)
449

    
450
instance TimeStampObject Instance where
451
  cTimeOf = instCtime
452
  mTimeOf = instMtime
453

    
454
instance UuidObject Instance where
455
  uuidOf = instUuid
456

    
457
instance SerialNoObject Instance where
458
  serialOf = instSerial
459

    
460
instance TagsObject Instance where
461
  tagsOf = instTags
462

    
463
-- | Retrieves the real disk size requirements for all the disks of the
464
-- instance. This includes the metadata etc. and is different from the values
465
-- visible to the instance.
466
getDiskSizeRequirements :: Instance -> Int
467
getDiskSizeRequirements inst =
468
  sum . map
469
    (\disk -> case instDiskTemplate inst of
470
                DTDrbd8    -> diskSize disk + C.drbdMetaSize
471
                DTDiskless -> 0
472
                DTBlock    -> 0
473
                _          -> diskSize disk )
474
    $ instDisks inst
475

    
476
-- * IPolicy definitions
477

    
478
$(buildParam "ISpec" "ispec"
479
  [ simpleField ConstantUtils.ispecMemSize     [t| Int |]
480
  , simpleField ConstantUtils.ispecDiskSize    [t| Int |]
481
  , simpleField ConstantUtils.ispecDiskCount   [t| Int |]
482
  , simpleField ConstantUtils.ispecCpuCount    [t| Int |]
483
  , simpleField ConstantUtils.ispecNicCount    [t| Int |]
484
  , simpleField ConstantUtils.ispecSpindleUse  [t| Int |]
485
  ])
486

    
487
$(buildObject "MinMaxISpecs" "mmis"
488
  [ renameField "MinSpec" $ simpleField "min" [t| FilledISpecParams |]
489
  , renameField "MaxSpec" $ simpleField "max" [t| FilledISpecParams |]
490
  ])
491

    
492
-- | Custom partial ipolicy. This is not built via buildParam since it
493
-- has a special 2-level inheritance mode.
494
$(buildObject "PartialIPolicy" "ipolicy"
495
  [ optionalField . renameField "MinMaxISpecsP" $
496
    simpleField ConstantUtils.ispecsMinmax [t| [MinMaxISpecs] |]
497
  , optionalField . renameField "StdSpecP" $
498
    simpleField "std" [t| PartialISpecParams |]
499
  , optionalField . renameField "SpindleRatioP" $
500
    simpleField "spindle-ratio" [t| Double |]
501
  , optionalField . renameField "VcpuRatioP" $
502
    simpleField "vcpu-ratio" [t| Double |]
503
  , optionalField . renameField "DiskTemplatesP" $
504
    simpleField "disk-templates" [t| [DiskTemplate] |]
505
  ])
506

    
507
-- | Custom filled ipolicy. This is not built via buildParam since it
508
-- has a special 2-level inheritance mode.
509
$(buildObject "FilledIPolicy" "ipolicy"
510
  [ renameField "MinMaxISpecs" $
511
    simpleField ConstantUtils.ispecsMinmax [t| [MinMaxISpecs] |]
512
  , renameField "StdSpec" $ simpleField "std" [t| FilledISpecParams |]
513
  , simpleField "spindle-ratio"  [t| Double |]
514
  , simpleField "vcpu-ratio"     [t| Double |]
515
  , simpleField "disk-templates" [t| [DiskTemplate] |]
516
  ])
517

    
518
-- | Custom filler for the ipolicy types.
519
fillIPolicy :: FilledIPolicy -> PartialIPolicy -> FilledIPolicy
520
fillIPolicy (FilledIPolicy { ipolicyMinMaxISpecs  = fminmax
521
                           , ipolicyStdSpec       = fstd
522
                           , ipolicySpindleRatio  = fspindleRatio
523
                           , ipolicyVcpuRatio     = fvcpuRatio
524
                           , ipolicyDiskTemplates = fdiskTemplates})
525
            (PartialIPolicy { ipolicyMinMaxISpecsP  = pminmax
526
                            , ipolicyStdSpecP       = pstd
527
                            , ipolicySpindleRatioP  = pspindleRatio
528
                            , ipolicyVcpuRatioP     = pvcpuRatio
529
                            , ipolicyDiskTemplatesP = pdiskTemplates}) =
530
  FilledIPolicy { ipolicyMinMaxISpecs  = fromMaybe fminmax pminmax
531
                , ipolicyStdSpec       = case pstd of
532
                                         Nothing -> fstd
533
                                         Just p -> fillISpecParams fstd p
534
                , ipolicySpindleRatio  = fromMaybe fspindleRatio pspindleRatio
535
                , ipolicyVcpuRatio     = fromMaybe fvcpuRatio pvcpuRatio
536
                , ipolicyDiskTemplates = fromMaybe fdiskTemplates
537
                                         pdiskTemplates
538
                }
539
-- * Node definitions
540

    
541
$(buildParam "ND" "ndp"
542
  [ simpleField "oob_program"   [t| String |]
543
  , simpleField "spindle_count" [t| Int    |]
544
  , simpleField "exclusive_storage" [t| Bool |]
545
  , simpleField "ovs"           [t| Bool |]
546
  , simpleField "ovs_name"       [t| String |]
547
  , simpleField "ovs_link"       [t| String |]
548
  ])
549

    
550
$(buildObject "Node" "node" $
551
  [ simpleField "name"             [t| String |]
552
  , simpleField "primary_ip"       [t| String |]
553
  , simpleField "secondary_ip"     [t| String |]
554
  , simpleField "master_candidate" [t| Bool   |]
555
  , simpleField "offline"          [t| Bool   |]
556
  , simpleField "drained"          [t| Bool   |]
557
  , simpleField "group"            [t| String |]
558
  , simpleField "master_capable"   [t| Bool   |]
559
  , simpleField "vm_capable"       [t| Bool   |]
560
  , simpleField "ndparams"         [t| PartialNDParams |]
561
  , simpleField "powered"          [t| Bool   |]
562
  ]
563
  ++ timeStampFields
564
  ++ uuidFields
565
  ++ serialFields
566
  ++ tagsFields)
567

    
568
instance TimeStampObject Node where
569
  cTimeOf = nodeCtime
570
  mTimeOf = nodeMtime
571

    
572
instance UuidObject Node where
573
  uuidOf = nodeUuid
574

    
575
instance SerialNoObject Node where
576
  serialOf = nodeSerial
577

    
578
instance TagsObject Node where
579
  tagsOf = nodeTags
580

    
581
-- * NodeGroup definitions
582

    
583
-- | The disk parameters type.
584
type DiskParams = Container (Container JSValue)
585

    
586
-- | A mapping from network UUIDs to nic params of the networks.
587
type Networks = Container PartialNicParams
588

    
589
$(buildObject "NodeGroup" "group" $
590
  [ simpleField "name"         [t| String |]
591
  , defaultField [| [] |] $ simpleField "members" [t| [String] |]
592
  , simpleField "ndparams"     [t| PartialNDParams |]
593
  , simpleField "alloc_policy" [t| AllocPolicy     |]
594
  , simpleField "ipolicy"      [t| PartialIPolicy  |]
595
  , simpleField "diskparams"   [t| DiskParams      |]
596
  , simpleField "networks"     [t| Networks        |]
597
  ]
598
  ++ timeStampFields
599
  ++ uuidFields
600
  ++ serialFields
601
  ++ tagsFields)
602

    
603
instance TimeStampObject NodeGroup where
604
  cTimeOf = groupCtime
605
  mTimeOf = groupMtime
606

    
607
instance UuidObject NodeGroup where
608
  uuidOf = groupUuid
609

    
610
instance SerialNoObject NodeGroup where
611
  serialOf = groupSerial
612

    
613
instance TagsObject NodeGroup where
614
  tagsOf = groupTags
615

    
616
-- | IP family type
617
$(declareIADT "IpFamily"
618
  [ ("IpFamilyV4", 'C.ip4Family)
619
  , ("IpFamilyV6", 'C.ip6Family)
620
  ])
621
$(makeJSONInstance ''IpFamily)
622

    
623
-- | Conversion from IP family to IP version. This is needed because
624
-- Python uses both, depending on context.
625
ipFamilyToVersion :: IpFamily -> Int
626
ipFamilyToVersion IpFamilyV4 = C.ip4Version
627
ipFamilyToVersion IpFamilyV6 = C.ip6Version
628

    
629
-- | Cluster HvParams (hvtype to hvparams mapping).
630
type ClusterHvParams = Container HvParams
631

    
632
-- | Cluster Os-HvParams (os to hvparams mapping).
633
type OsHvParams = Container ClusterHvParams
634

    
635
-- | Cluser BeParams.
636
type ClusterBeParams = Container FilledBeParams
637

    
638
-- | Cluster OsParams.
639
type ClusterOsParams = Container OsParams
640

    
641
-- | Cluster NicParams.
642
type ClusterNicParams = Container FilledNicParams
643

    
644
-- | Cluster UID Pool, list (low, high) UID ranges.
645
type UidPool = [(Int, Int)]
646

    
647
-- * Cluster definitions
648
$(buildObject "Cluster" "cluster" $
649
  [ simpleField "rsahostkeypub"           [t| String           |]
650
  , optionalField $
651
    simpleField "dsahostkeypub"           [t| String           |]
652
  , simpleField "highest_used_port"       [t| Int              |]
653
  , simpleField "tcpudp_port_pool"        [t| [Int]            |]
654
  , simpleField "mac_prefix"              [t| String           |]
655
  , optionalField $
656
    simpleField "volume_group_name"       [t| String           |]
657
  , simpleField "reserved_lvs"            [t| [String]         |]
658
  , optionalField $
659
    simpleField "drbd_usermode_helper"    [t| String           |]
660
  , simpleField "master_node"             [t| String           |]
661
  , simpleField "master_ip"               [t| String           |]
662
  , simpleField "master_netdev"           [t| String           |]
663
  , simpleField "master_netmask"          [t| Int              |]
664
  , simpleField "use_external_mip_script" [t| Bool             |]
665
  , simpleField "cluster_name"            [t| String           |]
666
  , simpleField "file_storage_dir"        [t| String           |]
667
  , simpleField "shared_file_storage_dir" [t| String           |]
668
  , simpleField "enabled_hypervisors"     [t| [Hypervisor]     |]
669
  , simpleField "hvparams"                [t| ClusterHvParams  |]
670
  , simpleField "os_hvp"                  [t| OsHvParams       |]
671
  , simpleField "beparams"                [t| ClusterBeParams  |]
672
  , simpleField "osparams"                [t| ClusterOsParams  |]
673
  , simpleField "nicparams"               [t| ClusterNicParams |]
674
  , simpleField "ndparams"                [t| FilledNDParams   |]
675
  , simpleField "diskparams"              [t| DiskParams       |]
676
  , simpleField "candidate_pool_size"     [t| Int              |]
677
  , simpleField "modify_etc_hosts"        [t| Bool             |]
678
  , simpleField "modify_ssh_setup"        [t| Bool             |]
679
  , simpleField "maintain_node_health"    [t| Bool             |]
680
  , simpleField "uid_pool"                [t| UidPool          |]
681
  , simpleField "default_iallocator"      [t| String           |]
682
  , simpleField "hidden_os"               [t| [String]         |]
683
  , simpleField "blacklisted_os"          [t| [String]         |]
684
  , simpleField "primary_ip_family"       [t| IpFamily         |]
685
  , simpleField "prealloc_wipe_disks"     [t| Bool             |]
686
  , simpleField "ipolicy"                 [t| FilledIPolicy    |]
687
  , simpleField "enabled_disk_templates"  [t| [DiskTemplate]   |]
688
 ]
689
 ++ timeStampFields
690
 ++ uuidFields
691
 ++ serialFields
692
 ++ tagsFields)
693

    
694
instance TimeStampObject Cluster where
695
  cTimeOf = clusterCtime
696
  mTimeOf = clusterMtime
697

    
698
instance UuidObject Cluster where
699
  uuidOf = clusterUuid
700

    
701
instance SerialNoObject Cluster where
702
  serialOf = clusterSerial
703

    
704
instance TagsObject Cluster where
705
  tagsOf = clusterTags
706

    
707
-- * ConfigData definitions
708

    
709
$(buildObject "ConfigData" "config" $
710
--  timeStampFields ++
711
  [ simpleField "version"    [t| Int                 |]
712
  , simpleField "cluster"    [t| Cluster             |]
713
  , simpleField "nodes"      [t| Container Node      |]
714
  , simpleField "nodegroups" [t| Container NodeGroup |]
715
  , simpleField "instances"  [t| Container Instance  |]
716
  , simpleField "networks"   [t| Container Network   |]
717
  ]
718
  ++ serialFields)
719

    
720
instance SerialNoObject ConfigData where
721
  serialOf = configSerial