Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Objects.hs @ 41044e04

History | View | Annotate | Download (23.9 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
  , diskUuid       :: String
430
  } deriving (Show, Eq)
431

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

    
444
instance UuidObject Disk where
445
  uuidOf = diskUuid
446

    
447
-- * Instance definitions
448

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

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

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

    
482
instance TimeStampObject Instance where
483
  cTimeOf = instCtime
484
  mTimeOf = instMtime
485

    
486
instance UuidObject Instance where
487
  uuidOf = instUuid
488

    
489
instance SerialNoObject Instance where
490
  serialOf = instSerial
491

    
492
instance TagsObject Instance where
493
  tagsOf = instTags
494

    
495
-- * IPolicy definitions
496

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

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

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

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

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

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

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

    
584
instance TimeStampObject Node where
585
  cTimeOf = nodeCtime
586
  mTimeOf = nodeMtime
587

    
588
instance UuidObject Node where
589
  uuidOf = nodeUuid
590

    
591
instance SerialNoObject Node where
592
  serialOf = nodeSerial
593

    
594
instance TagsObject Node where
595
  tagsOf = nodeTags
596

    
597
-- * NodeGroup definitions
598

    
599
-- | The disk parameters type.
600
type DiskParams = Container (Container JSValue)
601

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

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

    
619
instance TimeStampObject NodeGroup where
620
  cTimeOf = groupCtime
621
  mTimeOf = groupMtime
622

    
623
instance UuidObject NodeGroup where
624
  uuidOf = groupUuid
625

    
626
instance SerialNoObject NodeGroup where
627
  serialOf = groupSerial
628

    
629
instance TagsObject NodeGroup where
630
  tagsOf = groupTags
631

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

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

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

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

    
651
-- | Cluser BeParams.
652
type ClusterBeParams = Container FilledBeParams
653

    
654
-- | Cluster OsParams.
655
type ClusterOsParams = Container OsParams
656

    
657
-- | Cluster NicParams.
658
type ClusterNicParams = Container FilledNicParams
659

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

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

    
708
instance TimeStampObject Cluster where
709
  cTimeOf = clusterCtime
710
  mTimeOf = clusterMtime
711

    
712
instance UuidObject Cluster where
713
  uuidOf = clusterUuid
714

    
715
instance SerialNoObject Cluster where
716
  serialOf = clusterSerial
717

    
718
instance TagsObject Cluster where
719
  tagsOf = clusterTags
720

    
721
-- * ConfigData definitions
722

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

    
734
instance SerialNoObject ConfigData where
735
  serialOf = configSerial