Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Objects.hs @ 3022ea9f

History | View | Annotate | Download (24.2 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
  ++ timeStampFields
263
  ++ serialFields
264
  ++ tagsFields)
265

    
266
instance SerialNoObject Network where
267
  serialOf = networkSerial
268

    
269
instance TagsObject Network where
270
  tagsOf = networkTags
271

    
272
instance UuidObject Network where
273
  uuidOf = networkUuid
274

    
275
instance TimeStampObject Network where
276
  cTimeOf = networkCtime
277
  mTimeOf = networkMtime
278

    
279
-- * NIC definitions
280

    
281
$(buildParam "Nic" "nicp"
282
  [ simpleField "mode" [t| NICMode |]
283
  , simpleField "link" [t| String  |]
284
  ])
285

    
286
$(buildObject "PartialNic" "nic" $
287
  [ simpleField "mac" [t| String |]
288
  , optionalField $ simpleField "ip" [t| String |]
289
  , simpleField "nicparams" [t| PartialNicParams |]
290
  , optionalField $ simpleField "network" [t| String |]
291
  , optionalField $ simpleField "name" [t| String |]
292
  ] ++ uuidFields)
293

    
294
instance UuidObject PartialNic where
295
  uuidOf = nicUuid
296

    
297
-- * Disk definitions
298

    
299
$(declareSADT "DiskMode"
300
  [ ("DiskRdOnly", 'C.diskRdonly)
301
  , ("DiskRdWr",   'C.diskRdwr)
302
  ])
303
$(makeJSONInstance ''DiskMode)
304

    
305
$(declareSADT "DiskType"
306
  [ ("LD_LV",       'C.ldLv)
307
  , ("LD_DRBD8",    'C.ldDrbd8)
308
  , ("LD_FILE",     'C.ldFile)
309
  , ("LD_BLOCKDEV", 'C.ldBlockdev)
310
  , ("LD_RADOS",    'C.ldRbd)
311
  , ("LD_EXT",      'C.ldExt)
312
  ])
313
$(makeJSONInstance ''DiskType)
314

    
315
-- | The persistent block driver type. Currently only one type is allowed.
316
$(declareSADT "BlockDriver"
317
  [ ("BlockDrvManual", 'C.blockdevDriverManual)
318
  ])
319
$(makeJSONInstance ''BlockDriver)
320

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

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

    
339
-- | Mapping from a logical id to a disk type.
340
lidDiskType :: DiskLogicalId -> DiskType
341
lidDiskType (LIDPlain {}) = LD_LV
342
lidDiskType (LIDDrbd8 {}) = LD_DRBD8
343
lidDiskType (LIDFile  {}) = LD_FILE
344
lidDiskType (LIDBlockDev {}) = LD_BLOCKDEV
345
lidDiskType (LIDRados {}) = LD_RADOS
346
lidDiskType (LIDExt {}) = LD_EXT
347

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

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

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

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

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

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

    
449
instance UuidObject Disk where
450
  uuidOf = diskUuid
451

    
452
-- * Instance definitions
453

    
454
$(declareSADT "AdminState"
455
  [ ("AdminOffline", 'C.adminstOffline)
456
  , ("AdminDown",    'C.adminstDown)
457
  , ("AdminUp",      'C.adminstUp)
458
  ])
459
$(makeJSONInstance ''AdminState)
460

    
461
$(buildParam "Be" "bep"
462
  [ simpleField "minmem"       [t| Int  |]
463
  , simpleField "maxmem"       [t| Int  |]
464
  , simpleField "vcpus"        [t| Int  |]
465
  , simpleField "auto_balance" [t| Bool |]
466
  ])
467

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

    
488
instance TimeStampObject Instance where
489
  cTimeOf = instCtime
490
  mTimeOf = instMtime
491

    
492
instance UuidObject Instance where
493
  uuidOf = instUuid
494

    
495
instance SerialNoObject Instance where
496
  serialOf = instSerial
497

    
498
instance TagsObject Instance where
499
  tagsOf = instTags
500

    
501
-- * IPolicy definitions
502

    
503
$(buildParam "ISpec" "ispec"
504
  [ simpleField C.ispecMemSize     [t| Int |]
505
  , simpleField C.ispecDiskSize    [t| Int |]
506
  , simpleField C.ispecDiskCount   [t| Int |]
507
  , simpleField C.ispecCpuCount    [t| Int |]
508
  , simpleField C.ispecNicCount    [t| Int |]
509
  , simpleField C.ispecSpindleUse  [t| Int |]
510
  ])
511

    
512
$(buildObject "MinMaxISpecs" "mmis"
513
  [ renameField "MinSpec" $ simpleField "min" [t| FilledISpecParams |]
514
  , renameField "MaxSpec" $ simpleField "max" [t| FilledISpecParams |]
515
  ])
516

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

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

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

    
566
$(buildParam "ND" "ndp"
567
  [ simpleField "oob_program"   [t| String |]
568
  , simpleField "spindle_count" [t| Int    |]
569
  , simpleField "exclusive_storage" [t| Bool |]
570
  ])
571

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

    
590
instance TimeStampObject Node where
591
  cTimeOf = nodeCtime
592
  mTimeOf = nodeMtime
593

    
594
instance UuidObject Node where
595
  uuidOf = nodeUuid
596

    
597
instance SerialNoObject Node where
598
  serialOf = nodeSerial
599

    
600
instance TagsObject Node where
601
  tagsOf = nodeTags
602

    
603
-- * NodeGroup definitions
604

    
605
-- | The disk parameters type.
606
type DiskParams = Container (Container JSValue)
607

    
608
-- | A mapping from network UUIDs to nic params of the networks.
609
type Networks = Container PartialNicParams
610

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

    
625
instance TimeStampObject NodeGroup where
626
  cTimeOf = groupCtime
627
  mTimeOf = groupMtime
628

    
629
instance UuidObject NodeGroup where
630
  uuidOf = groupUuid
631

    
632
instance SerialNoObject NodeGroup where
633
  serialOf = groupSerial
634

    
635
instance TagsObject NodeGroup where
636
  tagsOf = groupTags
637

    
638
-- | IP family type
639
$(declareIADT "IpFamily"
640
  [ ("IpFamilyV4", 'C.ip4Family)
641
  , ("IpFamilyV6", 'C.ip6Family)
642
  ])
643
$(makeJSONInstance ''IpFamily)
644

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

    
651
-- | Cluster HvParams (hvtype to hvparams mapping).
652
type ClusterHvParams = Container HvParams
653

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

    
657
-- | Cluser BeParams.
658
type ClusterBeParams = Container FilledBeParams
659

    
660
-- | Cluster OsParams.
661
type ClusterOsParams = Container OsParams
662

    
663
-- | Cluster NicParams.
664
type ClusterNicParams = Container FilledNicParams
665

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

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

    
716
instance TimeStampObject Cluster where
717
  cTimeOf = clusterCtime
718
  mTimeOf = clusterMtime
719

    
720
instance UuidObject Cluster where
721
  uuidOf = clusterUuid
722

    
723
instance SerialNoObject Cluster where
724
  serialOf = clusterSerial
725

    
726
instance TagsObject Cluster where
727
  tagsOf = clusterTags
728

    
729
-- * ConfigData definitions
730

    
731
$(buildObject "ConfigData" "config" $
732
--  timeStampFields ++
733
  [ simpleField "version"    [t| Int                 |]
734
  , simpleField "cluster"    [t| Cluster             |]
735
  , simpleField "nodes"      [t| Container Node      |]
736
  , simpleField "nodegroups" [t| Container NodeGroup |]
737
  , simpleField "instances"  [t| Container Instance  |]
738
  , simpleField "networks"   [t| Container Network   |]
739
  ]
740
  ++ serialFields)
741

    
742
instance SerialNoObject ConfigData where
743
  serialOf = configSerial