Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Objects.hs @ b54ecf12

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

    
98
import Control.Applicative
99
import Data.List (foldl')
100
import Data.Maybe
101
import qualified Data.Map as Map
102
import qualified Data.Set as Set
103
import Data.Word
104
import Text.JSON (showJSON, readJSON, JSON, JSValue(..), fromJSString)
105
import qualified Text.JSON as J
106

    
107
import qualified Ganeti.Constants as C
108
import Ganeti.JSON
109
import Ganeti.Types
110
import Ganeti.THH
111
import Ganeti.Utils (sepSplit, tryRead)
112

    
113
-- * Generic definitions
114

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

    
122
-- | The VTYPES, a mini-type system in Python.
123
$(declareSADT "VType"
124
  [ ("VTypeString",      'C.vtypeString)
125
  , ("VTypeMaybeString", 'C.vtypeMaybeString)
126
  , ("VTypeBool",        'C.vtypeBool)
127
  , ("VTypeSize",        'C.vtypeSize)
128
  , ("VTypeInt",         'C.vtypeInt)
129
  ])
130
$(makeJSONInstance ''VType)
131

    
132
-- | The hypervisor parameter type. This is currently a simple map,
133
-- without type checking on key/value pairs.
134
type HvParams = Container JSValue
135

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

    
141
-- | Class of objects that have timestamps.
142
class TimeStampObject a where
143
  cTimeOf :: a -> Double
144
  mTimeOf :: a -> Double
145

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

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

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

    
158
-- * Node role object
159

    
160
$(declareSADT "NodeRole"
161
  [ ("NROffline",   'C.nrOffline)
162
  , ("NRDrained",   'C.nrDrained)
163
  , ("NRRegular",   'C.nrRegular)
164
  , ("NRCandidate", 'C.nrMcandidate)
165
  , ("NRMaster",    'C.nrMaster)
166
  ])
167
$(makeJSONInstance ''NodeRole)
168

    
169
-- | The description of the node role.
170
roleDescription :: NodeRole -> String
171
roleDescription NROffline   = "offline"
172
roleDescription NRDrained   = "drained"
173
roleDescription NRRegular   = "regular"
174
roleDescription NRCandidate = "master candidate"
175
roleDescription NRMaster    = "master"
176

    
177
-- * Network definitions
178

    
179
-- ** Ipv4 types
180

    
181
-- | Custom type for a simple IPv4 address.
182
data Ip4Address = Ip4Address Word8 Word8 Word8 Word8
183
                  deriving Eq
184

    
185
instance Show Ip4Address where
186
  show (Ip4Address a b c d) = show a ++ "." ++ show b ++ "." ++
187
                              show c ++ "." ++ show d
188

    
189
-- | Parses an IPv4 address from a string.
190
readIp4Address :: (Applicative m, Monad m) => String -> m Ip4Address
191
readIp4Address s =
192
  case sepSplit '.' s of
193
    [a, b, c, d] -> Ip4Address <$>
194
                      tryRead "first octect" a <*>
195
                      tryRead "second octet" b <*>
196
                      tryRead "third octet"  c <*>
197
                      tryRead "fourth octet" d
198
    _ -> fail $ "Can't parse IPv4 address from string " ++ s
199

    
200
-- | JSON instance for 'Ip4Address'.
201
instance JSON Ip4Address where
202
  showJSON = showJSON . show
203
  readJSON (JSString s) = readIp4Address (fromJSString s)
204
  readJSON v = fail $ "Invalid JSON value " ++ show v ++ " for an IPv4 address"
205

    
206
-- | \"Next\" address implementation for IPv4 addresses.
207
--
208
-- Note that this loops! Note also that this is a very dumb
209
-- implementation.
210
nextIp4Address :: Ip4Address -> Ip4Address
211
nextIp4Address (Ip4Address a b c d) =
212
  let inc xs y = if all (==0) xs then y + 1 else y
213
      d' = d + 1
214
      c' = inc [d'] c
215
      b' = inc [c', d'] b
216
      a' = inc [b', c', d'] a
217
  in Ip4Address a' b' c' d'
218

    
219
-- | Custom type for an IPv4 network.
220
data Ip4Network = Ip4Network Ip4Address Word8
221
                  deriving Eq
222

    
223
instance Show Ip4Network where
224
  show (Ip4Network ip netmask) = show ip ++ "/" ++ show netmask
225

    
226
-- | JSON instance for 'Ip4Network'.
227
instance JSON Ip4Network where
228
  showJSON = showJSON . show
229
  readJSON (JSString s) =
230
    case sepSplit '/' (fromJSString s) of
231
      [ip, nm] -> do
232
        ip' <- readIp4Address ip
233
        nm' <- tryRead "parsing netmask" nm
234
        if nm' >= 0 && nm' <= 32
235
          then return $ Ip4Network ip' nm'
236
          else fail $ "Invalid netmask " ++ show nm' ++ " from string " ++
237
                      fromJSString s
238
      _ -> fail $ "Can't parse IPv4 network from string " ++ fromJSString s
239
  readJSON v = fail $ "Invalid JSON value " ++ show v ++ " for an IPv4 network"
240

    
241
-- ** Ganeti \"network\" config object.
242

    
243
-- FIXME: Not all types might be correct here, since they
244
-- haven't been exhaustively deduced from the python code yet.
245
$(buildObject "Network" "network" $
246
  [ simpleField "name"             [t| NonEmptyString |]
247
  , optionalField $
248
    simpleField "mac_prefix"       [t| String |]
249
  , simpleField "network"          [t| Ip4Network |]
250
  , optionalField $
251
    simpleField "network6"         [t| String |]
252
  , optionalField $
253
    simpleField "gateway"          [t| Ip4Address |]
254
  , optionalField $
255
    simpleField "gateway6"         [t| String |]
256
  , optionalField $
257
    simpleField "reservations"     [t| String |]
258
  , optionalField $
259
    simpleField "ext_reservations" [t| String |]
260
  ]
261
  ++ uuidFields
262
  ++ serialFields
263
  ++ tagsFields)
264

    
265
instance SerialNoObject Network where
266
  serialOf = networkSerial
267

    
268
instance TagsObject Network where
269
  tagsOf = networkTags
270

    
271
instance UuidObject Network where
272
  uuidOf = networkUuid
273

    
274
-- * NIC definitions
275

    
276
$(buildParam "Nic" "nicp"
277
  [ simpleField "mode" [t| NICMode |]
278
  , simpleField "link" [t| String  |]
279
  ])
280

    
281
$(buildObject "PartialNic" "nic" $
282
  [ simpleField "mac" [t| String |]
283
  , optionalField $ simpleField "ip" [t| String |]
284
  , simpleField "nicparams" [t| PartialNicParams |]
285
  , optionalField $ simpleField "network" [t| String |]
286
  , optionalField $ simpleField "name" [t| String |]
287
  ] ++ uuidFields)
288

    
289
instance UuidObject PartialNic where
290
  uuidOf = nicUuid
291

    
292
-- * Disk definitions
293

    
294
$(declareSADT "DiskMode"
295
  [ ("DiskRdOnly", 'C.diskRdonly)
296
  , ("DiskRdWr",   'C.diskRdwr)
297
  ])
298
$(makeJSONInstance ''DiskMode)
299

    
300
$(declareSADT "DiskType"
301
  [ ("LD_LV",       'C.ldLv)
302
  , ("LD_DRBD8",    'C.ldDrbd8)
303
  , ("LD_FILE",     'C.ldFile)
304
  , ("LD_BLOCKDEV", 'C.ldBlockdev)
305
  , ("LD_RADOS",    'C.ldRbd)
306
  , ("LD_EXT",      'C.ldExt)
307
  ])
308
$(makeJSONInstance ''DiskType)
309

    
310
-- | The persistent block driver type. Currently only one type is allowed.
311
$(declareSADT "BlockDriver"
312
  [ ("BlockDrvManual", 'C.blockdevDriverManual)
313
  ])
314
$(makeJSONInstance ''BlockDriver)
315

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

    
320
-- | The disk configuration type. This includes the disk type itself,
321
-- for a more complete consistency. Note that since in the Python
322
-- code-base there's no authoritative place where we document the
323
-- logical id, this is probably a good reference point.
324
data DiskLogicalId
325
  = LIDPlain String String  -- ^ Volume group, logical volume
326
  | LIDDrbd8 String String Int Int Int String
327
  -- ^ NodeA, NodeB, Port, MinorA, MinorB, Secret
328
  | LIDFile FileDriver String -- ^ Driver, path
329
  | LIDBlockDev BlockDriver String -- ^ Driver, path (must be under /dev)
330
  | LIDRados String String -- ^ Unused, path
331
  | LIDExt String String -- ^ ExtProvider, unique name
332
    deriving (Show, Eq)
333

    
334
-- | Mapping from a logical id to a disk type.
335
lidDiskType :: DiskLogicalId -> DiskType
336
lidDiskType (LIDPlain {}) = LD_LV
337
lidDiskType (LIDDrbd8 {}) = LD_DRBD8
338
lidDiskType (LIDFile  {}) = LD_FILE
339
lidDiskType (LIDBlockDev {}) = LD_BLOCKDEV
340
lidDiskType (LIDRados {}) = LD_RADOS
341
lidDiskType (LIDExt {}) = LD_EXT
342

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

    
347
-- | Custom encoder for DiskLogicalId (logical id only).
348
encodeDLId :: DiskLogicalId -> JSValue
349
encodeDLId (LIDPlain vg lv) = JSArray [showJSON vg, showJSON lv]
350
encodeDLId (LIDDrbd8 nodeA nodeB port minorA minorB key) =
351
  JSArray [ showJSON nodeA, showJSON nodeB, showJSON port
352
          , showJSON minorA, showJSON minorB, showJSON key ]
353
encodeDLId (LIDRados pool name) = JSArray [showJSON pool, showJSON name]
354
encodeDLId (LIDFile driver name) = JSArray [showJSON driver, showJSON name]
355
encodeDLId (LIDBlockDev driver name) = JSArray [showJSON driver, showJSON name]
356
encodeDLId (LIDExt extprovider name) =
357
  JSArray [showJSON extprovider, showJSON name]
358

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

    
364
-- | Custom decoder for DiskLogicalId. This is manual for now, since
365
-- we don't have yet automation for separate-key style fields.
366
decodeDLId :: [(String, JSValue)] -> JSValue -> J.Result DiskLogicalId
367
decodeDLId obj lid = do
368
  dtype <- fromObj obj devType
369
  case dtype of
370
    LD_DRBD8 ->
371
      case lid of
372
        JSArray [nA, nB, p, mA, mB, k] -> do
373
          nA' <- readJSON nA
374
          nB' <- readJSON nB
375
          p'  <- readJSON p
376
          mA' <- readJSON mA
377
          mB' <- readJSON mB
378
          k'  <- readJSON k
379
          return $ LIDDrbd8 nA' nB' p' mA' mB' k'
380
        _ -> fail "Can't read logical_id for DRBD8 type"
381
    LD_LV ->
382
      case lid of
383
        JSArray [vg, lv] -> do
384
          vg' <- readJSON vg
385
          lv' <- readJSON lv
386
          return $ LIDPlain vg' lv'
387
        _ -> fail "Can't read logical_id for plain type"
388
    LD_FILE ->
389
      case lid of
390
        JSArray [driver, path] -> do
391
          driver' <- readJSON driver
392
          path'   <- readJSON path
393
          return $ LIDFile driver' path'
394
        _ -> fail "Can't read logical_id for file type"
395
    LD_BLOCKDEV ->
396
      case lid of
397
        JSArray [driver, path] -> do
398
          driver' <- readJSON driver
399
          path'   <- readJSON path
400
          return $ LIDBlockDev driver' path'
401
        _ -> fail "Can't read logical_id for blockdev type"
402
    LD_RADOS ->
403
      case lid of
404
        JSArray [driver, path] -> do
405
          driver' <- readJSON driver
406
          path'   <- readJSON path
407
          return $ LIDRados driver' path'
408
        _ -> fail "Can't read logical_id for rdb type"
409
    LD_EXT ->
410
      case lid of
411
        JSArray [extprovider, name] -> do
412
          extprovider' <- readJSON extprovider
413
          name'   <- readJSON name
414
          return $ LIDExt extprovider' name'
415
        _ -> fail "Can't read logical_id for extstorage type"
416

    
417
-- | Disk data structure.
418
--
419
-- This is declared manually as it's a recursive structure, and our TH
420
-- code currently can't build it.
421
data Disk = Disk
422
  { diskLogicalId  :: DiskLogicalId
423
--  , diskPhysicalId :: String
424
  , diskChildren   :: [Disk]
425
  , diskIvName     :: String
426
  , diskSize       :: Int
427
  , diskMode       :: DiskMode
428
  , diskName       :: Maybe String
429
  , diskSpindles   :: Maybe Int
430
  , diskUuid       :: String
431
  } deriving (Show, Eq)
432

    
433
$(buildObjectSerialisation "Disk" $
434
  [ customField 'decodeDLId 'encodeFullDLId ["dev_type"] $
435
      simpleField "logical_id"    [t| DiskLogicalId   |]
436
--  , simpleField "physical_id" [t| String   |]
437
  , defaultField  [| [] |] $ simpleField "children" [t| [Disk] |]
438
  , defaultField [| "" |] $ simpleField "iv_name" [t| String |]
439
  , simpleField "size" [t| Int |]
440
  , defaultField [| DiskRdWr |] $ simpleField "mode" [t| DiskMode |]
441
  , optionalField $ simpleField "name" [t| String |]
442
  , optionalField $ simpleField "spindles" [t| Int |]
443
  ]
444
  ++ uuidFields)
445

    
446
instance UuidObject Disk where
447
  uuidOf = diskUuid
448

    
449
-- * Instance definitions
450

    
451
$(declareSADT "AdminState"
452
  [ ("AdminOffline", 'C.adminstOffline)
453
  , ("AdminDown",    'C.adminstDown)
454
  , ("AdminUp",      'C.adminstUp)
455
  ])
456
$(makeJSONInstance ''AdminState)
457

    
458
$(buildParam "Be" "bep"
459
  [ simpleField "minmem"       [t| Int  |]
460
  , simpleField "maxmem"       [t| Int  |]
461
  , simpleField "vcpus"        [t| Int  |]
462
  , simpleField "auto_balance" [t| Bool |]
463
  ])
464

    
465
$(buildObject "Instance" "inst" $
466
  [ simpleField "name"           [t| String             |]
467
  , simpleField "primary_node"   [t| String             |]
468
  , simpleField "os"             [t| String             |]
469
  , simpleField "hypervisor"     [t| Hypervisor         |]
470
  , simpleField "hvparams"       [t| HvParams           |]
471
  , simpleField "beparams"       [t| PartialBeParams    |]
472
  , simpleField "osparams"       [t| OsParams           |]
473
  , simpleField "admin_state"    [t| AdminState         |]
474
  , simpleField "nics"           [t| [PartialNic]       |]
475
  , simpleField "disks"          [t| [Disk]             |]
476
  , simpleField "disk_template"  [t| DiskTemplate       |]
477
  , optionalField $ simpleField "network_port" [t| Int  |]
478
  ]
479
  ++ timeStampFields
480
  ++ uuidFields
481
  ++ serialFields
482
  ++ tagsFields)
483

    
484
instance TimeStampObject Instance where
485
  cTimeOf = instCtime
486
  mTimeOf = instMtime
487

    
488
instance UuidObject Instance where
489
  uuidOf = instUuid
490

    
491
instance SerialNoObject Instance where
492
  serialOf = instSerial
493

    
494
instance TagsObject Instance where
495
  tagsOf = instTags
496

    
497
-- * IPolicy definitions
498

    
499
$(buildParam "ISpec" "ispec"
500
  [ simpleField C.ispecMemSize     [t| Int |]
501
  , simpleField C.ispecDiskSize    [t| Int |]
502
  , simpleField C.ispecDiskCount   [t| Int |]
503
  , simpleField C.ispecCpuCount    [t| Int |]
504
  , simpleField C.ispecNicCount    [t| Int |]
505
  , simpleField C.ispecSpindleUse  [t| Int |]
506
  ])
507

    
508
$(buildObject "MinMaxISpecs" "mmis"
509
  [ renameField "MinSpec" $ simpleField "min" [t| FilledISpecParams |]
510
  , renameField "MaxSpec" $ simpleField "max" [t| FilledISpecParams |]
511
  ])
512

    
513
-- | Custom partial ipolicy. This is not built via buildParam since it
514
-- has a special 2-level inheritance mode.
515
$(buildObject "PartialIPolicy" "ipolicy"
516
  [ optionalField . renameField "MinMaxISpecsP"
517
                    $ simpleField C.ispecsMinmax   [t| [MinMaxISpecs] |]
518
  , optionalField . renameField "StdSpecP"
519
                    $ simpleField "std"            [t| PartialISpecParams |]
520
  , optionalField . renameField "SpindleRatioP"
521
                    $ simpleField "spindle-ratio"  [t| Double |]
522
  , optionalField . renameField "VcpuRatioP"
523
                    $ simpleField "vcpu-ratio"     [t| Double |]
524
  , optionalField . renameField "DiskTemplatesP"
525
                    $ simpleField "disk-templates" [t| [DiskTemplate] |]
526
  ])
527

    
528
-- | Custom filled ipolicy. This is not built via buildParam since it
529
-- has a special 2-level inheritance mode.
530
$(buildObject "FilledIPolicy" "ipolicy"
531
  [ renameField "MinMaxISpecs"
532
    $ simpleField C.ispecsMinmax [t| [MinMaxISpecs] |]
533
  , renameField "StdSpec" $ simpleField "std" [t| FilledISpecParams |]
534
  , simpleField "spindle-ratio"  [t| Double |]
535
  , simpleField "vcpu-ratio"     [t| Double |]
536
  , simpleField "disk-templates" [t| [DiskTemplate] |]
537
  ])
538

    
539
-- | Custom filler for the ipolicy types.
540
fillIPolicy :: FilledIPolicy -> PartialIPolicy -> FilledIPolicy
541
fillIPolicy (FilledIPolicy { ipolicyMinMaxISpecs  = fminmax
542
                           , ipolicyStdSpec       = fstd
543
                           , ipolicySpindleRatio  = fspindleRatio
544
                           , ipolicyVcpuRatio     = fvcpuRatio
545
                           , ipolicyDiskTemplates = fdiskTemplates})
546
            (PartialIPolicy { ipolicyMinMaxISpecsP  = pminmax
547
                            , ipolicyStdSpecP       = pstd
548
                            , ipolicySpindleRatioP  = pspindleRatio
549
                            , ipolicyVcpuRatioP     = pvcpuRatio
550
                            , ipolicyDiskTemplatesP = pdiskTemplates}) =
551
  FilledIPolicy { ipolicyMinMaxISpecs  = fromMaybe fminmax pminmax
552
                , ipolicyStdSpec       = case pstd of
553
                                         Nothing -> fstd
554
                                         Just p -> fillISpecParams fstd p
555
                , ipolicySpindleRatio  = fromMaybe fspindleRatio pspindleRatio
556
                , ipolicyVcpuRatio     = fromMaybe fvcpuRatio pvcpuRatio
557
                , ipolicyDiskTemplates = fromMaybe fdiskTemplates
558
                                         pdiskTemplates
559
                }
560
-- * Node definitions
561

    
562
$(buildParam "ND" "ndp"
563
  [ simpleField "oob_program"   [t| String |]
564
  , simpleField "spindle_count" [t| Int    |]
565
  , simpleField "exclusive_storage" [t| Bool |]
566
  ])
567

    
568
$(buildObject "Node" "node" $
569
  [ simpleField "name"             [t| String |]
570
  , simpleField "primary_ip"       [t| String |]
571
  , simpleField "secondary_ip"     [t| String |]
572
  , simpleField "master_candidate" [t| Bool   |]
573
  , simpleField "offline"          [t| Bool   |]
574
  , simpleField "drained"          [t| Bool   |]
575
  , simpleField "group"            [t| String |]
576
  , simpleField "master_capable"   [t| Bool   |]
577
  , simpleField "vm_capable"       [t| Bool   |]
578
  , simpleField "ndparams"         [t| PartialNDParams |]
579
  , simpleField "powered"          [t| Bool   |]
580
  ]
581
  ++ timeStampFields
582
  ++ uuidFields
583
  ++ serialFields
584
  ++ tagsFields)
585

    
586
instance TimeStampObject Node where
587
  cTimeOf = nodeCtime
588
  mTimeOf = nodeMtime
589

    
590
instance UuidObject Node where
591
  uuidOf = nodeUuid
592

    
593
instance SerialNoObject Node where
594
  serialOf = nodeSerial
595

    
596
instance TagsObject Node where
597
  tagsOf = nodeTags
598

    
599
-- * NodeGroup definitions
600

    
601
-- | The disk parameters type.
602
type DiskParams = Container (Container JSValue)
603

    
604
-- | A mapping from network UUIDs to nic params of the networks.
605
type Networks = Container PartialNicParams
606

    
607
$(buildObject "NodeGroup" "group" $
608
  [ simpleField "name"         [t| String |]
609
  , defaultField [| [] |] $ simpleField "members" [t| [String] |]
610
  , simpleField "ndparams"     [t| PartialNDParams |]
611
  , simpleField "alloc_policy" [t| AllocPolicy     |]
612
  , simpleField "ipolicy"      [t| PartialIPolicy  |]
613
  , simpleField "diskparams"   [t| DiskParams      |]
614
  , simpleField "networks"     [t| Networks        |]
615
  ]
616
  ++ timeStampFields
617
  ++ uuidFields
618
  ++ serialFields
619
  ++ tagsFields)
620

    
621
instance TimeStampObject NodeGroup where
622
  cTimeOf = groupCtime
623
  mTimeOf = groupMtime
624

    
625
instance UuidObject NodeGroup where
626
  uuidOf = groupUuid
627

    
628
instance SerialNoObject NodeGroup where
629
  serialOf = groupSerial
630

    
631
instance TagsObject NodeGroup where
632
  tagsOf = groupTags
633

    
634
-- | IP family type
635
$(declareIADT "IpFamily"
636
  [ ("IpFamilyV4", 'C.ip4Family)
637
  , ("IpFamilyV6", 'C.ip6Family)
638
  ])
639
$(makeJSONInstance ''IpFamily)
640

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

    
647
-- | Cluster HvParams (hvtype to hvparams mapping).
648
type ClusterHvParams = Container HvParams
649

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

    
653
-- | Cluser BeParams.
654
type ClusterBeParams = Container FilledBeParams
655

    
656
-- | Cluster OsParams.
657
type ClusterOsParams = Container OsParams
658

    
659
-- | Cluster NicParams.
660
type ClusterNicParams = Container FilledNicParams
661

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

    
665
-- * Cluster definitions
666
$(buildObject "Cluster" "cluster" $
667
  [ simpleField "rsahostkeypub"           [t| String           |]
668
  , simpleField "highest_used_port"       [t| Int              |]
669
  , simpleField "tcpudp_port_pool"        [t| [Int]            |]
670
  , simpleField "mac_prefix"              [t| String           |]
671
  , optionalField $
672
    simpleField "volume_group_name"       [t| String           |]
673
  , simpleField "reserved_lvs"            [t| [String]         |]
674
  , optionalField $
675
    simpleField "drbd_usermode_helper"    [t| String           |]
676
  , simpleField "master_node"             [t| String           |]
677
  , simpleField "master_ip"               [t| String           |]
678
  , simpleField "master_netdev"           [t| String           |]
679
  , simpleField "master_netmask"          [t| Int              |]
680
  , simpleField "use_external_mip_script" [t| Bool             |]
681
  , simpleField "cluster_name"            [t| String           |]
682
  , simpleField "file_storage_dir"        [t| String           |]
683
  , simpleField "shared_file_storage_dir" [t| String           |]
684
  , simpleField "enabled_hypervisors"     [t| [Hypervisor]     |]
685
  , simpleField "hvparams"                [t| ClusterHvParams  |]
686
  , simpleField "os_hvp"                  [t| OsHvParams       |]
687
  , simpleField "beparams"                [t| ClusterBeParams  |]
688
  , simpleField "osparams"                [t| ClusterOsParams  |]
689
  , simpleField "nicparams"               [t| ClusterNicParams |]
690
  , simpleField "ndparams"                [t| FilledNDParams   |]
691
  , simpleField "diskparams"              [t| DiskParams       |]
692
  , simpleField "candidate_pool_size"     [t| Int              |]
693
  , simpleField "modify_etc_hosts"        [t| Bool             |]
694
  , simpleField "modify_ssh_setup"        [t| Bool             |]
695
  , simpleField "maintain_node_health"    [t| Bool             |]
696
  , simpleField "uid_pool"                [t| UidPool          |]
697
  , simpleField "default_iallocator"      [t| String           |]
698
  , simpleField "hidden_os"               [t| [String]         |]
699
  , simpleField "blacklisted_os"          [t| [String]         |]
700
  , simpleField "primary_ip_family"       [t| IpFamily         |]
701
  , simpleField "prealloc_wipe_disks"     [t| Bool             |]
702
  , simpleField "ipolicy"                 [t| FilledIPolicy    |]
703
  , simpleField "enabled_disk_templates"  [t| [DiskTemplate]   |]
704
 ]
705
 ++ timeStampFields
706
 ++ uuidFields
707
 ++ serialFields
708
 ++ tagsFields)
709

    
710
instance TimeStampObject Cluster where
711
  cTimeOf = clusterCtime
712
  mTimeOf = clusterMtime
713

    
714
instance UuidObject Cluster where
715
  uuidOf = clusterUuid
716

    
717
instance SerialNoObject Cluster where
718
  serialOf = clusterSerial
719

    
720
instance TagsObject Cluster where
721
  tagsOf = clusterTags
722

    
723
-- * ConfigData definitions
724

    
725
$(buildObject "ConfigData" "config" $
726
--  timeStampFields ++
727
  [ simpleField "version"    [t| Int                 |]
728
  , simpleField "cluster"    [t| Cluster             |]
729
  , simpleField "nodes"      [t| Container Node      |]
730
  , simpleField "nodegroups" [t| Container NodeGroup |]
731
  , simpleField "instances"  [t| Container Instance  |]
732
  , simpleField "networks"   [t| Container Network   |]
733
  ]
734
  ++ serialFields)
735

    
736
instance SerialNoObject ConfigData where
737
  serialOf = configSerial