Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Objects.hs @ 1ca6e10e

History | View | Annotate | Download (24.7 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
  , includesLogicalId
48
  , DiskTemplate(..)
49
  , PartialBeParams(..)
50
  , FilledBeParams(..)
51
  , fillBeParams
52
  , allBeParamFields
53
  , AdminState(..)
54
  , adminStateFromRaw
55
  , Instance(..)
56
  , toDictInstance
57
  , PartialNDParams(..)
58
  , FilledNDParams(..)
59
  , fillNDParams
60
  , allNDParamFields
61
  , Node(..)
62
  , NodeRole(..)
63
  , nodeRoleToRaw
64
  , roleDescription
65
  , AllocPolicy(..)
66
  , FilledISpecParams(..)
67
  , PartialISpecParams(..)
68
  , fillISpecParams
69
  , allISpecParamFields
70
  , MinMaxISpecs(..)
71
  , FilledIPolicy(..)
72
  , PartialIPolicy(..)
73
  , fillIPolicy
74
  , DiskParams
75
  , NodeGroup(..)
76
  , IpFamily(..)
77
  , ipFamilyToVersion
78
  , fillDict
79
  , ClusterHvParams
80
  , OsHvParams
81
  , ClusterBeParams
82
  , ClusterOsParams
83
  , ClusterNicParams
84
  , Cluster(..)
85
  , ConfigData(..)
86
  , TimeStampObject(..)
87
  , UuidObject(..)
88
  , SerialNoObject(..)
89
  , TagsObject(..)
90
  , DictObject(..) -- re-exported from THH
91
  , TagSet -- re-exported from THH
92
  , Network(..)
93
  , Ip4Address(..)
94
  , Ip4Network(..)
95
  , readIp4Address
96
  , nextIp4Address
97
  ) where
98

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

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

    
114
-- * Generic definitions
115

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

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

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

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

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

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

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

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

    
159
-- * Node role object
160

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

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

    
178
-- * Network definitions
179

    
180
-- ** Ipv4 types
181

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

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

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

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

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

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

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

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

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

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

    
267
instance SerialNoObject Network where
268
  serialOf = networkSerial
269

    
270
instance TagsObject Network where
271
  tagsOf = networkTags
272

    
273
instance UuidObject Network where
274
  uuidOf = networkUuid
275

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

    
280
-- * NIC definitions
281

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

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

    
296
instance UuidObject PartialNic where
297
  uuidOf = nicUuid
298

    
299
-- * Disk definitions
300

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

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

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

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

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

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

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

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

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

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

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

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

    
453
instance UuidObject Disk where
454
  uuidOf = diskUuid
455

    
456
-- | Determines whether a disk or one of his children has the given logical id
457
-- (determined by the volume group name and by the logical volume name).
458
-- This can be true only for DRBD or LVM disks.
459
includesLogicalId :: String -> String -> Disk -> Bool
460
includesLogicalId vg_name lv_name disk =
461
  case diskLogicalId disk of
462
    LIDPlain vg lv -> vg_name == vg && lv_name == lv
463
    LIDDrbd8 {} ->
464
      any (includesLogicalId vg_name lv_name) $ diskChildren disk
465
    _ -> False
466

    
467

    
468
-- * Instance definitions
469

    
470
$(declareSADT "AdminState"
471
  [ ("AdminOffline", 'C.adminstOffline)
472
  , ("AdminDown",    'C.adminstDown)
473
  , ("AdminUp",      'C.adminstUp)
474
  ])
475
$(makeJSONInstance ''AdminState)
476

    
477
$(buildParam "Be" "bep"
478
  [ simpleField "minmem"       [t| Int  |]
479
  , simpleField "maxmem"       [t| Int  |]
480
  , simpleField "vcpus"        [t| Int  |]
481
  , simpleField "auto_balance" [t| Bool |]
482
  ])
483

    
484
$(buildObject "Instance" "inst" $
485
  [ simpleField "name"           [t| String             |]
486
  , simpleField "primary_node"   [t| String             |]
487
  , simpleField "os"             [t| String             |]
488
  , simpleField "hypervisor"     [t| Hypervisor         |]
489
  , simpleField "hvparams"       [t| HvParams           |]
490
  , simpleField "beparams"       [t| PartialBeParams    |]
491
  , simpleField "osparams"       [t| OsParams           |]
492
  , simpleField "admin_state"    [t| AdminState         |]
493
  , simpleField "nics"           [t| [PartialNic]       |]
494
  , simpleField "disks"          [t| [Disk]             |]
495
  , simpleField "disk_template"  [t| DiskTemplate       |]
496
  , simpleField "disks_active"   [t| Bool               |]
497
  , optionalField $ simpleField "network_port" [t| Int  |]
498
  ]
499
  ++ timeStampFields
500
  ++ uuidFields
501
  ++ serialFields
502
  ++ tagsFields)
503

    
504
instance TimeStampObject Instance where
505
  cTimeOf = instCtime
506
  mTimeOf = instMtime
507

    
508
instance UuidObject Instance where
509
  uuidOf = instUuid
510

    
511
instance SerialNoObject Instance where
512
  serialOf = instSerial
513

    
514
instance TagsObject Instance where
515
  tagsOf = instTags
516

    
517
-- * IPolicy definitions
518

    
519
$(buildParam "ISpec" "ispec"
520
  [ simpleField C.ispecMemSize     [t| Int |]
521
  , simpleField C.ispecDiskSize    [t| Int |]
522
  , simpleField C.ispecDiskCount   [t| Int |]
523
  , simpleField C.ispecCpuCount    [t| Int |]
524
  , simpleField C.ispecNicCount    [t| Int |]
525
  , simpleField C.ispecSpindleUse  [t| Int |]
526
  ])
527

    
528
$(buildObject "MinMaxISpecs" "mmis"
529
  [ renameField "MinSpec" $ simpleField "min" [t| FilledISpecParams |]
530
  , renameField "MaxSpec" $ simpleField "max" [t| FilledISpecParams |]
531
  ])
532

    
533
-- | Custom partial ipolicy. This is not built via buildParam since it
534
-- has a special 2-level inheritance mode.
535
$(buildObject "PartialIPolicy" "ipolicy"
536
  [ optionalField . renameField "MinMaxISpecsP"
537
                    $ simpleField C.ispecsMinmax   [t| [MinMaxISpecs] |]
538
  , optionalField . renameField "StdSpecP"
539
                    $ simpleField "std"            [t| PartialISpecParams |]
540
  , optionalField . renameField "SpindleRatioP"
541
                    $ simpleField "spindle-ratio"  [t| Double |]
542
  , optionalField . renameField "VcpuRatioP"
543
                    $ simpleField "vcpu-ratio"     [t| Double |]
544
  , optionalField . renameField "DiskTemplatesP"
545
                    $ simpleField "disk-templates" [t| [DiskTemplate] |]
546
  ])
547

    
548
-- | Custom filled ipolicy. This is not built via buildParam since it
549
-- has a special 2-level inheritance mode.
550
$(buildObject "FilledIPolicy" "ipolicy"
551
  [ renameField "MinMaxISpecs"
552
    $ simpleField C.ispecsMinmax [t| [MinMaxISpecs] |]
553
  , renameField "StdSpec" $ simpleField "std" [t| FilledISpecParams |]
554
  , simpleField "spindle-ratio"  [t| Double |]
555
  , simpleField "vcpu-ratio"     [t| Double |]
556
  , simpleField "disk-templates" [t| [DiskTemplate] |]
557
  ])
558

    
559
-- | Custom filler for the ipolicy types.
560
fillIPolicy :: FilledIPolicy -> PartialIPolicy -> FilledIPolicy
561
fillIPolicy (FilledIPolicy { ipolicyMinMaxISpecs  = fminmax
562
                           , ipolicyStdSpec       = fstd
563
                           , ipolicySpindleRatio  = fspindleRatio
564
                           , ipolicyVcpuRatio     = fvcpuRatio
565
                           , ipolicyDiskTemplates = fdiskTemplates})
566
            (PartialIPolicy { ipolicyMinMaxISpecsP  = pminmax
567
                            , ipolicyStdSpecP       = pstd
568
                            , ipolicySpindleRatioP  = pspindleRatio
569
                            , ipolicyVcpuRatioP     = pvcpuRatio
570
                            , ipolicyDiskTemplatesP = pdiskTemplates}) =
571
  FilledIPolicy { ipolicyMinMaxISpecs  = fromMaybe fminmax pminmax
572
                , ipolicyStdSpec       = case pstd of
573
                                         Nothing -> fstd
574
                                         Just p -> fillISpecParams fstd p
575
                , ipolicySpindleRatio  = fromMaybe fspindleRatio pspindleRatio
576
                , ipolicyVcpuRatio     = fromMaybe fvcpuRatio pvcpuRatio
577
                , ipolicyDiskTemplates = fromMaybe fdiskTemplates
578
                                         pdiskTemplates
579
                }
580
-- * Node definitions
581

    
582
$(buildParam "ND" "ndp"
583
  [ simpleField "oob_program"   [t| String |]
584
  , simpleField "spindle_count" [t| Int    |]
585
  , simpleField "exclusive_storage" [t| Bool |]
586
  ])
587

    
588
$(buildObject "Node" "node" $
589
  [ simpleField "name"             [t| String |]
590
  , simpleField "primary_ip"       [t| String |]
591
  , simpleField "secondary_ip"     [t| String |]
592
  , simpleField "master_candidate" [t| Bool   |]
593
  , simpleField "offline"          [t| Bool   |]
594
  , simpleField "drained"          [t| Bool   |]
595
  , simpleField "group"            [t| String |]
596
  , simpleField "master_capable"   [t| Bool   |]
597
  , simpleField "vm_capable"       [t| Bool   |]
598
  , simpleField "ndparams"         [t| PartialNDParams |]
599
  , simpleField "powered"          [t| Bool   |]
600
  ]
601
  ++ timeStampFields
602
  ++ uuidFields
603
  ++ serialFields
604
  ++ tagsFields)
605

    
606
instance TimeStampObject Node where
607
  cTimeOf = nodeCtime
608
  mTimeOf = nodeMtime
609

    
610
instance UuidObject Node where
611
  uuidOf = nodeUuid
612

    
613
instance SerialNoObject Node where
614
  serialOf = nodeSerial
615

    
616
instance TagsObject Node where
617
  tagsOf = nodeTags
618

    
619
-- * NodeGroup definitions
620

    
621
-- | The disk parameters type.
622
type DiskParams = Container (Container JSValue)
623

    
624
-- | A mapping from network UUIDs to nic params of the networks.
625
type Networks = Container PartialNicParams
626

    
627
$(buildObject "NodeGroup" "group" $
628
  [ simpleField "name"         [t| String |]
629
  , defaultField [| [] |] $ simpleField "members" [t| [String] |]
630
  , simpleField "ndparams"     [t| PartialNDParams |]
631
  , simpleField "alloc_policy" [t| AllocPolicy     |]
632
  , simpleField "ipolicy"      [t| PartialIPolicy  |]
633
  , simpleField "diskparams"   [t| DiskParams      |]
634
  , simpleField "networks"     [t| Networks        |]
635
  ]
636
  ++ timeStampFields
637
  ++ uuidFields
638
  ++ serialFields
639
  ++ tagsFields)
640

    
641
instance TimeStampObject NodeGroup where
642
  cTimeOf = groupCtime
643
  mTimeOf = groupMtime
644

    
645
instance UuidObject NodeGroup where
646
  uuidOf = groupUuid
647

    
648
instance SerialNoObject NodeGroup where
649
  serialOf = groupSerial
650

    
651
instance TagsObject NodeGroup where
652
  tagsOf = groupTags
653

    
654
-- | IP family type
655
$(declareIADT "IpFamily"
656
  [ ("IpFamilyV4", 'C.ip4Family)
657
  , ("IpFamilyV6", 'C.ip6Family)
658
  ])
659
$(makeJSONInstance ''IpFamily)
660

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

    
667
-- | Cluster HvParams (hvtype to hvparams mapping).
668
type ClusterHvParams = Container HvParams
669

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

    
673
-- | Cluser BeParams.
674
type ClusterBeParams = Container FilledBeParams
675

    
676
-- | Cluster OsParams.
677
type ClusterOsParams = Container OsParams
678

    
679
-- | Cluster NicParams.
680
type ClusterNicParams = Container FilledNicParams
681

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

    
685
-- * Cluster definitions
686
$(buildObject "Cluster" "cluster" $
687
  [ simpleField "rsahostkeypub"           [t| String           |]
688
  , simpleField "highest_used_port"       [t| Int              |]
689
  , simpleField "tcpudp_port_pool"        [t| [Int]            |]
690
  , simpleField "mac_prefix"              [t| String           |]
691
  , optionalField $
692
    simpleField "volume_group_name"       [t| String           |]
693
  , simpleField "reserved_lvs"            [t| [String]         |]
694
  , optionalField $
695
    simpleField "drbd_usermode_helper"    [t| String           |]
696
  , simpleField "master_node"             [t| String           |]
697
  , simpleField "master_ip"               [t| String           |]
698
  , simpleField "master_netdev"           [t| String           |]
699
  , simpleField "master_netmask"          [t| Int              |]
700
  , simpleField "use_external_mip_script" [t| Bool             |]
701
  , simpleField "cluster_name"            [t| String           |]
702
  , simpleField "file_storage_dir"        [t| String           |]
703
  , simpleField "shared_file_storage_dir" [t| String           |]
704
  , simpleField "enabled_hypervisors"     [t| [Hypervisor]     |]
705
  , simpleField "hvparams"                [t| ClusterHvParams  |]
706
  , simpleField "os_hvp"                  [t| OsHvParams       |]
707
  , simpleField "beparams"                [t| ClusterBeParams  |]
708
  , simpleField "osparams"                [t| ClusterOsParams  |]
709
  , simpleField "nicparams"               [t| ClusterNicParams |]
710
  , simpleField "ndparams"                [t| FilledNDParams   |]
711
  , simpleField "diskparams"              [t| DiskParams       |]
712
  , simpleField "candidate_pool_size"     [t| Int              |]
713
  , simpleField "modify_etc_hosts"        [t| Bool             |]
714
  , simpleField "modify_ssh_setup"        [t| Bool             |]
715
  , simpleField "maintain_node_health"    [t| Bool             |]
716
  , simpleField "uid_pool"                [t| UidPool          |]
717
  , simpleField "default_iallocator"      [t| String           |]
718
  , simpleField "hidden_os"               [t| [String]         |]
719
  , simpleField "blacklisted_os"          [t| [String]         |]
720
  , simpleField "primary_ip_family"       [t| IpFamily         |]
721
  , simpleField "prealloc_wipe_disks"     [t| Bool             |]
722
  , simpleField "ipolicy"                 [t| FilledIPolicy    |]
723
  , simpleField "enabled_disk_templates"  [t| [DiskTemplate]   |]
724
 ]
725
 ++ timeStampFields
726
 ++ uuidFields
727
 ++ serialFields
728
 ++ tagsFields)
729

    
730
instance TimeStampObject Cluster where
731
  cTimeOf = clusterCtime
732
  mTimeOf = clusterMtime
733

    
734
instance UuidObject Cluster where
735
  uuidOf = clusterUuid
736

    
737
instance SerialNoObject Cluster where
738
  serialOf = clusterSerial
739

    
740
instance TagsObject Cluster where
741
  tagsOf = clusterTags
742

    
743
-- * ConfigData definitions
744

    
745
$(buildObject "ConfigData" "config" $
746
--  timeStampFields ++
747
  [ simpleField "version"    [t| Int                 |]
748
  , simpleField "cluster"    [t| Cluster             |]
749
  , simpleField "nodes"      [t| Container Node      |]
750
  , simpleField "nodegroups" [t| Container NodeGroup |]
751
  , simpleField "instances"  [t| Container Instance  |]
752
  , simpleField "networks"   [t| Container Network   |]
753
  ]
754
  ++ serialFields)
755

    
756
instance SerialNoObject ConfigData where
757
  serialOf = configSerial