Objects.hs 21.2 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
{-# LANGUAGE TemplateHaskell #-}

{-| Implementation of the Ganeti config objects.

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

-}

{-

Copyright (C) 2011, 2012 Google Inc.

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

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

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

-}

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

Iustin Pop's avatar
Iustin Pop committed
93
import Data.List (foldl')
94
import Data.Maybe
Iustin Pop's avatar
Iustin Pop committed
95
import qualified Data.Map as Map
96
import qualified Data.Set as Set
97
import Text.JSON (showJSON, readJSON, JSON, JSValue(..))
98
import qualified Text.JSON as J
99
100

import qualified Ganeti.Constants as C
101
import Ganeti.JSON
102
import Ganeti.Types
103
104
import Ganeti.THH

Iustin Pop's avatar
Iustin Pop committed
105
106
107
108
109
110
111
112
113
-- * Generic definitions

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

Iustin Pop's avatar
Iustin Pop committed
114
115
116
117
118
119
120
121
122
123
-- | The VTYPES, a mini-type system in Python.
$(declareSADT "VType"
  [ ("VTypeString",      'C.vtypeString)
  , ("VTypeMaybeString", 'C.vtypeMaybeString)
  , ("VTypeBool",        'C.vtypeBool)
  , ("VTypeSize",        'C.vtypeSize)
  , ("VTypeInt",         'C.vtypeInt)
  ])
$(makeJSONInstance ''VType)

Iustin Pop's avatar
Iustin Pop committed
124
125
126
127
128
129
130
131
132
-- | The hypervisor parameter type. This is currently a simple map,
-- without type checking on key/value pairs.
type HvParams = Container JSValue

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

133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
-- | Class of objects that have timestamps.
class TimeStampObject a where
  cTimeOf :: a -> Double
  mTimeOf :: a -> Double

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

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

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

150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
-- * Node role object

$(declareSADT "NodeRole"
  [ ("NROffline",   'C.nrOffline)
  , ("NRDrained",   'C.nrDrained)
  , ("NRRegular",   'C.nrRegular)
  , ("NRCandidate", 'C.nrMcandidate)
  , ("NRMaster",    'C.nrMaster)
  ])
$(makeJSONInstance ''NodeRole)

-- | The description of the node role.
roleDescription :: NodeRole -> String
roleDescription NROffline   = "offline"
roleDescription NRDrained   = "drained"
roleDescription NRRegular   = "regular"
roleDescription NRCandidate = "master candidate"
roleDescription NRMaster    = "master"

169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
-- * Network definitions

-- FIXME: Not all types might be correct here, since they
-- haven't been exhaustively deduced from the python code yet.
$(buildObject "Network" "network" $
  [ simpleField "name"             [t| NonEmptyString |]
  , optionalField $
    simpleField "network_type"     [t| NetworkType |]
  , optionalField $
    simpleField "mac_prefix"       [t| String |]
  , optionalField $
    simpleField "family"           [t| Int |]
  , simpleField "network"          [t| NonEmptyString |]
  , optionalField $
    simpleField "network6"         [t| String |]
  , optionalField $
    simpleField "gateway"          [t| String |]
  , optionalField $
    simpleField "gateway6"         [t| String |]
  , optionalField $
    simpleField "size"             [t| J.JSValue |]
  , optionalField $
    simpleField "reservations"     [t| String |]
  , optionalField $
    simpleField "ext_reservations" [t| String |]
  ]
  ++ serialFields
  ++ tagsFields)

instance SerialNoObject Network where
  serialOf = networkSerial

instance TagsObject Network where
  tagsOf = networkTags

204
205
-- * NIC definitions

Iustin Pop's avatar
Iustin Pop committed
206
$(buildParam "Nic" "nicp"
207
208
209
210
  [ simpleField "mode" [t| NICMode |]
  , simpleField "link" [t| String  |]
  ])

Iustin Pop's avatar
Iustin Pop committed
211
$(buildObject "PartialNic" "nic"
212
213
  [ simpleField "mac" [t| String |]
  , optionalField $ simpleField "ip" [t| String |]
Iustin Pop's avatar
Iustin Pop committed
214
  , simpleField "nicparams" [t| PartialNicParams |]
215
  , optionalField $ simpleField "network" [t| Network |]
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
  ])

-- * Disk definitions

$(declareSADT "DiskMode"
  [ ("DiskRdOnly", 'C.diskRdonly)
  , ("DiskRdWr",   'C.diskRdwr)
  ])
$(makeJSONInstance ''DiskMode)

$(declareSADT "DiskType"
  [ ("LD_LV",       'C.ldLv)
  , ("LD_DRBD8",    'C.ldDrbd8)
  , ("LD_FILE",     'C.ldFile)
  , ("LD_BLOCKDEV", 'C.ldBlockdev)
231
  , ("LD_RADOS",    'C.ldRbd)
232
  , ("LD_EXT",      'C.ldExt)
233
234
235
  ])
$(makeJSONInstance ''DiskType)

236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
-- | The persistent block driver type. Currently only one type is allowed.
$(declareSADT "BlockDriver"
  [ ("BlockDrvManual", 'C.blockdevDriverManual)
  ])
$(makeJSONInstance ''BlockDriver)

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

-- | The disk configuration type. This includes the disk type itself,
-- for a more complete consistency. Note that since in the Python
-- code-base there's no authoritative place where we document the
-- logical id, this is probably a good reference point.
data DiskLogicalId
  = LIDPlain String String  -- ^ Volume group, logical volume
  | LIDDrbd8 String String Int Int Int String
  -- ^ NodeA, NodeB, Port, MinorA, MinorB, Secret
  | LIDFile FileDriver String -- ^ Driver, path
  | LIDBlockDev BlockDriver String -- ^ Driver, path (must be under /dev)
  | LIDRados String String -- ^ Unused, path
257
  | LIDExt String String -- ^ ExtProvider, unique name
258
    deriving (Show, Eq)
259
260
261
262
263
264
265
266

-- | Mapping from a logical id to a disk type.
lidDiskType :: DiskLogicalId -> DiskType
lidDiskType (LIDPlain {}) = LD_LV
lidDiskType (LIDDrbd8 {}) = LD_DRBD8
lidDiskType (LIDFile  {}) = LD_FILE
lidDiskType (LIDBlockDev {}) = LD_BLOCKDEV
lidDiskType (LIDRados {}) = LD_RADOS
267
lidDiskType (LIDExt {}) = LD_EXT
268
269
270
271
272
273
274
275
276
277
278
279
280
281

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

-- | Custom encoder for DiskLogicalId (logical id only).
encodeDLId :: DiskLogicalId -> JSValue
encodeDLId (LIDPlain vg lv) = JSArray [showJSON vg, showJSON lv]
encodeDLId (LIDDrbd8 nodeA nodeB port minorA minorB key) =
  JSArray [ showJSON nodeA, showJSON nodeB, showJSON port
          , showJSON minorA, showJSON minorB, showJSON key ]
encodeDLId (LIDRados pool name) = JSArray [showJSON pool, showJSON name]
encodeDLId (LIDFile driver name) = JSArray [showJSON driver, showJSON name]
encodeDLId (LIDBlockDev driver name) = JSArray [showJSON driver, showJSON name]
Iustin Pop's avatar
Iustin Pop committed
282
283
encodeDLId (LIDExt extprovider name) =
  JSArray [showJSON extprovider, showJSON name]
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305

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

-- | Custom decoder for DiskLogicalId. This is manual for now, since
-- we don't have yet automation for separate-key style fields.
decodeDLId :: [(String, JSValue)] -> JSValue -> J.Result DiskLogicalId
decodeDLId obj lid = do
  dtype <- fromObj obj devType
  case dtype of
    LD_DRBD8 ->
      case lid of
        JSArray [nA, nB, p, mA, mB, k] -> do
          nA' <- readJSON nA
          nB' <- readJSON nB
          p'  <- readJSON p
          mA' <- readJSON mA
          mB' <- readJSON mB
          k'  <- readJSON k
          return $ LIDDrbd8 nA' nB' p' mA' mB' k'
Iustin Pop's avatar
Iustin Pop committed
306
        _ -> fail "Can't read logical_id for DRBD8 type"
307
308
309
310
311
312
    LD_LV ->
      case lid of
        JSArray [vg, lv] -> do
          vg' <- readJSON vg
          lv' <- readJSON lv
          return $ LIDPlain vg' lv'
Iustin Pop's avatar
Iustin Pop committed
313
        _ -> fail "Can't read logical_id for plain type"
314
315
316
317
318
319
    LD_FILE ->
      case lid of
        JSArray [driver, path] -> do
          driver' <- readJSON driver
          path'   <- readJSON path
          return $ LIDFile driver' path'
Iustin Pop's avatar
Iustin Pop committed
320
        _ -> fail "Can't read logical_id for file type"
321
322
323
324
325
326
    LD_BLOCKDEV ->
      case lid of
        JSArray [driver, path] -> do
          driver' <- readJSON driver
          path'   <- readJSON path
          return $ LIDBlockDev driver' path'
Iustin Pop's avatar
Iustin Pop committed
327
        _ -> fail "Can't read logical_id for blockdev type"
328
329
330
331
332
333
    LD_RADOS ->
      case lid of
        JSArray [driver, path] -> do
          driver' <- readJSON driver
          path'   <- readJSON path
          return $ LIDRados driver' path'
Iustin Pop's avatar
Iustin Pop committed
334
        _ -> fail "Can't read logical_id for rdb type"
335
336
337
338
339
340
341
    LD_EXT ->
      case lid of
        JSArray [extprovider, name] -> do
          extprovider' <- readJSON extprovider
          name'   <- readJSON name
          return $ LIDExt extprovider' name'
        _ -> fail "Can't read logical_id for extstorage type"
342

343
344
345
346
347
-- | Disk data structure.
--
-- This is declared manually as it's a recursive structure, and our TH
-- code currently can't build it.
data Disk = Disk
348
  { diskLogicalId  :: DiskLogicalId
349
350
351
352
353
--  , diskPhysicalId :: String
  , diskChildren   :: [Disk]
  , diskIvName     :: String
  , diskSize       :: Int
  , diskMode       :: DiskMode
354
  } deriving (Show, Eq)
355
356

$(buildObjectSerialisation "Disk"
Iustin Pop's avatar
Iustin Pop committed
357
  [ customField 'decodeDLId 'encodeFullDLId ["dev_type"] $
358
      simpleField "logical_id"    [t| DiskLogicalId   |]
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
--  , simpleField "physical_id" [t| String   |]
  , defaultField  [| [] |] $ simpleField "children" [t| [Disk] |]
  , defaultField [| "" |] $ simpleField "iv_name" [t| String |]
  , simpleField "size" [t| Int |]
  , defaultField [| DiskRdWr |] $ simpleField "mode" [t| DiskMode |]
  ])

-- * Instance definitions

$(declareSADT "AdminState"
  [ ("AdminOffline", 'C.adminstOffline)
  , ("AdminDown",    'C.adminstDown)
  , ("AdminUp",      'C.adminstUp)
  ])
$(makeJSONInstance ''AdminState)

Iustin Pop's avatar
Iustin Pop committed
375
$(buildParam "Be" "bep"
376
377
378
379
380
381
382
383
384
385
  [ simpleField "minmem"       [t| Int  |]
  , simpleField "maxmem"       [t| Int  |]
  , simpleField "vcpus"        [t| Int  |]
  , simpleField "auto_balance" [t| Bool |]
  ])

$(buildObject "Instance" "inst" $
  [ simpleField "name"           [t| String             |]
  , simpleField "primary_node"   [t| String             |]
  , simpleField "os"             [t| String             |]
Iustin Pop's avatar
Iustin Pop committed
386
387
388
389
  , simpleField "hypervisor"     [t| Hypervisor         |]
  , simpleField "hvparams"       [t| HvParams           |]
  , simpleField "beparams"       [t| PartialBeParams    |]
  , simpleField "osparams"       [t| OsParams           |]
390
  , simpleField "admin_state"    [t| AdminState         |]
Iustin Pop's avatar
Iustin Pop committed
391
  , simpleField "nics"           [t| [PartialNic]       |]
392
393
  , simpleField "disks"          [t| [Disk]             |]
  , simpleField "disk_template"  [t| DiskTemplate       |]
Iustin Pop's avatar
Iustin Pop committed
394
  , optionalField $ simpleField "network_port" [t| Int  |]
395
396
397
  ]
  ++ timeStampFields
  ++ uuidFields
398
399
  ++ serialFields
  ++ tagsFields)
400

401
402
403
404
405
406
407
408
409
410
411
412
413
instance TimeStampObject Instance where
  cTimeOf = instCtime
  mTimeOf = instMtime

instance UuidObject Instance where
  uuidOf = instUuid

instance SerialNoObject Instance where
  serialOf = instSerial

instance TagsObject Instance where
  tagsOf = instTags

414
415
-- * IPolicy definitions

Iustin Pop's avatar
Iustin Pop committed
416
$(buildParam "ISpec" "ispec"
417
418
419
420
  [ simpleField C.ispecMemSize     [t| Int |]
  , simpleField C.ispecDiskSize    [t| Int |]
  , simpleField C.ispecDiskCount   [t| Int |]
  , simpleField C.ispecCpuCount    [t| Int |]
Iustin Pop's avatar
Iustin Pop committed
421
  , simpleField C.ispecNicCount    [t| Int |]
422
423
424
425
426
  , simpleField C.ispecSpindleUse  [t| Int |]
  ])

-- | Custom partial ipolicy. This is not built via buildParam since it
-- has a special 2-level inheritance mode.
Iustin Pop's avatar
Iustin Pop committed
427
$(buildObject "PartialIPolicy" "ipolicy"
428
429
430
431
432
433
434
435
436
437
438
439
440
  [ renameField "MinSpecP" $ simpleField "min" [t| PartialISpecParams |]
  , renameField "MaxSpecP" $ simpleField "max" [t| PartialISpecParams |]
  , renameField "StdSpecP" $ simpleField "std" [t| PartialISpecParams |]
  , optionalField . renameField "SpindleRatioP"
                    $ simpleField "spindle-ratio"  [t| Double |]
  , optionalField . renameField "VcpuRatioP"
                    $ simpleField "vcpu-ratio"     [t| Double |]
  , optionalField . renameField "DiskTemplatesP"
                    $ simpleField "disk-templates" [t| [DiskTemplate] |]
  ])

-- | Custom filled ipolicy. This is not built via buildParam since it
-- has a special 2-level inheritance mode.
Iustin Pop's avatar
Iustin Pop committed
441
$(buildObject "FilledIPolicy" "ipolicy"
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
  [ renameField "MinSpec" $ simpleField "min" [t| FilledISpecParams |]
  , renameField "MaxSpec" $ simpleField "max" [t| FilledISpecParams |]
  , renameField "StdSpec" $ simpleField "std" [t| FilledISpecParams |]
  , simpleField "spindle-ratio"  [t| Double |]
  , simpleField "vcpu-ratio"     [t| Double |]
  , simpleField "disk-templates" [t| [DiskTemplate] |]
  ])

-- | Custom filler for the ipolicy types.
fillIPolicy :: FilledIPolicy -> PartialIPolicy -> FilledIPolicy
fillIPolicy (FilledIPolicy { ipolicyMinSpec       = fmin
                           , ipolicyMaxSpec       = fmax
                           , ipolicyStdSpec       = fstd
                           , ipolicySpindleRatio  = fspindleRatio
                           , ipolicyVcpuRatio     = fvcpuRatio
                           , ipolicyDiskTemplates = fdiskTemplates})
            (PartialIPolicy { ipolicyMinSpecP       = pmin
                            , ipolicyMaxSpecP       = pmax
                            , ipolicyStdSpecP       = pstd
                            , ipolicySpindleRatioP  = pspindleRatio
                            , ipolicyVcpuRatioP     = pvcpuRatio
                            , ipolicyDiskTemplatesP = pdiskTemplates}) =
  FilledIPolicy { ipolicyMinSpec       = fillISpecParams fmin pmin
                , ipolicyMaxSpec       = fillISpecParams fmax pmax
                , ipolicyStdSpec       = fillISpecParams fstd pstd
                , ipolicySpindleRatio  = fromMaybe fspindleRatio pspindleRatio
                , ipolicyVcpuRatio     = fromMaybe fvcpuRatio pvcpuRatio
                , ipolicyDiskTemplates = fromMaybe fdiskTemplates
                                         pdiskTemplates
                }
472
473
-- * Node definitions

Iustin Pop's avatar
Iustin Pop committed
474
$(buildParam "ND" "ndp"
475
476
  [ simpleField "oob_program"   [t| String |]
  , simpleField "spindle_count" [t| Int    |]
477
  , simpleField "exclusive_storage" [t| Bool |]
478
479
480
481
482
483
484
485
486
487
488
489
  ])

$(buildObject "Node" "node" $
  [ simpleField "name"             [t| String |]
  , simpleField "primary_ip"       [t| String |]
  , simpleField "secondary_ip"     [t| String |]
  , simpleField "master_candidate" [t| Bool   |]
  , simpleField "offline"          [t| Bool   |]
  , simpleField "drained"          [t| Bool   |]
  , simpleField "group"            [t| String |]
  , simpleField "master_capable"   [t| Bool   |]
  , simpleField "vm_capable"       [t| Bool   |]
Iustin Pop's avatar
Iustin Pop committed
490
  , simpleField "ndparams"         [t| PartialNDParams |]
491
492
493
494
  , simpleField "powered"          [t| Bool   |]
  ]
  ++ timeStampFields
  ++ uuidFields
495
496
  ++ serialFields
  ++ tagsFields)
497

498
499
500
501
502
503
504
505
506
507
508
509
510
instance TimeStampObject Node where
  cTimeOf = nodeCtime
  mTimeOf = nodeMtime

instance UuidObject Node where
  uuidOf = nodeUuid

instance SerialNoObject Node where
  serialOf = nodeSerial

instance TagsObject Node where
  tagsOf = nodeTags

511
512
-- * NodeGroup definitions

Iustin Pop's avatar
Iustin Pop committed
513
514
515
-- | The disk parameters type.
type DiskParams = Container (Container JSValue)

516
-- | A mapping from network UUIDs to nic params of the networks.
517
type Networks = Container PartialNicParams
518

519
520
$(buildObject "NodeGroup" "group" $
  [ simpleField "name"         [t| String |]
521
  , defaultField [| [] |] $ simpleField "members" [t| [String] |]
Iustin Pop's avatar
Iustin Pop committed
522
  , simpleField "ndparams"     [t| PartialNDParams |]
523
524
  , simpleField "alloc_policy" [t| AllocPolicy     |]
  , simpleField "ipolicy"      [t| PartialIPolicy  |]
Iustin Pop's avatar
Iustin Pop committed
525
  , simpleField "diskparams"   [t| DiskParams      |]
526
  , simpleField "networks"     [t| Networks        |]
527
528
529
  ]
  ++ timeStampFields
  ++ uuidFields
530
531
  ++ serialFields
  ++ tagsFields)
532

533
534
535
536
537
538
539
540
541
542
543
544
545
instance TimeStampObject NodeGroup where
  cTimeOf = groupCtime
  mTimeOf = groupMtime

instance UuidObject NodeGroup where
  uuidOf = groupUuid

instance SerialNoObject NodeGroup where
  serialOf = groupSerial

instance TagsObject NodeGroup where
  tagsOf = groupTags

Iustin Pop's avatar
Iustin Pop committed
546
547
548
549
550
551
552
553
554
555
556
557
558
-- | IP family type
$(declareIADT "IpFamily"
  [ ("IpFamilyV4", 'C.ip4Family)
  , ("IpFamilyV6", 'C.ip6Family)
  ])
$(makeJSONInstance ''IpFamily)

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

Iustin Pop's avatar
Iustin Pop committed
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
-- | Cluster HvParams (hvtype to hvparams mapping).
type ClusterHvParams = Container HvParams

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

-- | Cluser BeParams.
type ClusterBeParams = Container FilledBeParams

-- | Cluster OsParams.
type ClusterOsParams = Container OsParams

-- | Cluster NicParams.
type ClusterNicParams = Container FilledNicParams

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

577
578
-- * Cluster definitions
$(buildObject "Cluster" "cluster" $
Iustin Pop's avatar
Iustin Pop committed
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
  [ simpleField "rsahostkeypub"           [t| String           |]
  , simpleField "highest_used_port"       [t| Int              |]
  , simpleField "tcpudp_port_pool"        [t| [Int]            |]
  , simpleField "mac_prefix"              [t| String           |]
  , simpleField "volume_group_name"       [t| String           |]
  , simpleField "reserved_lvs"            [t| [String]         |]
  , optionalField $
    simpleField "drbd_usermode_helper"    [t| String           |]
  , simpleField "master_node"             [t| String           |]
  , simpleField "master_ip"               [t| String           |]
  , simpleField "master_netdev"           [t| String           |]
  , simpleField "master_netmask"          [t| Int              |]
  , simpleField "use_external_mip_script" [t| Bool             |]
  , simpleField "cluster_name"            [t| String           |]
  , simpleField "file_storage_dir"        [t| String           |]
  , simpleField "shared_file_storage_dir" [t| String           |]
595
  , simpleField "enabled_hypervisors"     [t| [Hypervisor]     |]
Iustin Pop's avatar
Iustin Pop committed
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
  , simpleField "hvparams"                [t| ClusterHvParams  |]
  , simpleField "os_hvp"                  [t| OsHvParams       |]
  , simpleField "beparams"                [t| ClusterBeParams  |]
  , simpleField "osparams"                [t| ClusterOsParams  |]
  , simpleField "nicparams"               [t| ClusterNicParams |]
  , simpleField "ndparams"                [t| FilledNDParams   |]
  , simpleField "diskparams"              [t| DiskParams       |]
  , simpleField "candidate_pool_size"     [t| Int              |]
  , simpleField "modify_etc_hosts"        [t| Bool             |]
  , simpleField "modify_ssh_setup"        [t| Bool             |]
  , simpleField "maintain_node_health"    [t| Bool             |]
  , simpleField "uid_pool"                [t| UidPool          |]
  , simpleField "default_iallocator"      [t| String           |]
  , simpleField "hidden_os"               [t| [String]         |]
  , simpleField "blacklisted_os"          [t| [String]         |]
  , simpleField "primary_ip_family"       [t| IpFamily         |]
  , simpleField "prealloc_wipe_disks"     [t| Bool             |]
  , simpleField "ipolicy"                 [t| FilledIPolicy    |]
614
 ]
Iustin Pop's avatar
Iustin Pop committed
615
616
 ++ timeStampFields
 ++ uuidFields
617
 ++ serialFields
Iustin Pop's avatar
Iustin Pop committed
618
 ++ tagsFields)
619

620
621
622
623
624
625
626
627
628
629
630
631
632
instance TimeStampObject Cluster where
  cTimeOf = clusterCtime
  mTimeOf = clusterMtime

instance UuidObject Cluster where
  uuidOf = clusterUuid

instance SerialNoObject Cluster where
  serialOf = clusterSerial

instance TagsObject Cluster where
  tagsOf = clusterTags

633
634
635
636
-- * ConfigData definitions

$(buildObject "ConfigData" "config" $
--  timeStampFields ++
637
638
639
640
641
  [ simpleField "version"    [t| Int                 |]
  , simpleField "cluster"    [t| Cluster             |]
  , simpleField "nodes"      [t| Container Node      |]
  , simpleField "nodegroups" [t| Container NodeGroup |]
  , simpleField "instances"  [t| Container Instance  |]
642
643
  ]
  ++ serialFields)
644
645
646

instance SerialNoObject ConfigData where
  serialOf = configSerial