Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Objects.hs @ 9c8c69bc

History | View | Annotate | Download (24.6 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
  , FilledMinMaxISpecs(..)
70
  , PartialMinMaxISpecs(..)
71
  , fillMinMaxISpecs
72
  , FilledIPolicy(..)
73
  , PartialIPolicy(..)
74
  , fillIPolicy
75
  , DiskParams
76
  , NodeGroup(..)
77
  , IpFamily(..)
78
  , ipFamilyToVersion
79
  , fillDict
80
  , ClusterHvParams
81
  , OsHvParams
82
  , ClusterBeParams
83
  , ClusterOsParams
84
  , ClusterNicParams
85
  , Cluster(..)
86
  , ConfigData(..)
87
  , TimeStampObject(..)
88
  , UuidObject(..)
89
  , SerialNoObject(..)
90
  , TagsObject(..)
91
  , DictObject(..) -- re-exported from THH
92
  , TagSet -- re-exported from THH
93
  , Network(..)
94
  , Ip4Address(..)
95
  , Ip4Network(..)
96
  , readIp4Address
97
  , nextIp4Address
98
  ) where
99

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

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

    
115
-- * Generic definitions
116

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

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

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

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

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

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

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

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

    
160
-- * Node role object
161

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

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

    
179
-- * Network definitions
180

    
181
-- ** Ipv4 types
182

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

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

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

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

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

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

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

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

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

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

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

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

    
290
-- * Disk definitions
291

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

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

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

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

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

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

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

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

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

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

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

    
428
$(buildObjectSerialisation "Disk"
429
  [ customField 'decodeDLId 'encodeFullDLId ["dev_type"] $
430
      simpleField "logical_id"    [t| DiskLogicalId   |]
431
--  , simpleField "physical_id" [t| String   |]
432
  , defaultField  [| [] |] $ simpleField "children" [t| [Disk] |]
433
  , defaultField [| "" |] $ simpleField "iv_name" [t| String |]
434
  , simpleField "size" [t| Int |]
435
  , defaultField [| DiskRdWr |] $ simpleField "mode" [t| DiskMode |]
436
  ])
437

    
438
-- * Instance definitions
439

    
440
$(declareSADT "AdminState"
441
  [ ("AdminOffline", 'C.adminstOffline)
442
  , ("AdminDown",    'C.adminstDown)
443
  , ("AdminUp",      'C.adminstUp)
444
  ])
445
$(makeJSONInstance ''AdminState)
446

    
447
$(buildParam "Be" "bep"
448
  [ simpleField "minmem"       [t| Int  |]
449
  , simpleField "maxmem"       [t| Int  |]
450
  , simpleField "vcpus"        [t| Int  |]
451
  , simpleField "auto_balance" [t| Bool |]
452
  ])
453

    
454
$(buildObject "Instance" "inst" $
455
  [ simpleField "name"           [t| String             |]
456
  , simpleField "primary_node"   [t| String             |]
457
  , simpleField "os"             [t| String             |]
458
  , simpleField "hypervisor"     [t| Hypervisor         |]
459
  , simpleField "hvparams"       [t| HvParams           |]
460
  , simpleField "beparams"       [t| PartialBeParams    |]
461
  , simpleField "osparams"       [t| OsParams           |]
462
  , simpleField "admin_state"    [t| AdminState         |]
463
  , simpleField "nics"           [t| [PartialNic]       |]
464
  , simpleField "disks"          [t| [Disk]             |]
465
  , simpleField "disk_template"  [t| DiskTemplate       |]
466
  , optionalField $ simpleField "network_port" [t| Int  |]
467
  ]
468
  ++ timeStampFields
469
  ++ uuidFields
470
  ++ serialFields
471
  ++ tagsFields)
472

    
473
instance TimeStampObject Instance where
474
  cTimeOf = instCtime
475
  mTimeOf = instMtime
476

    
477
instance UuidObject Instance where
478
  uuidOf = instUuid
479

    
480
instance SerialNoObject Instance where
481
  serialOf = instSerial
482

    
483
instance TagsObject Instance where
484
  tagsOf = instTags
485

    
486
-- * IPolicy definitions
487

    
488
$(buildParam "ISpec" "ispec"
489
  [ simpleField C.ispecMemSize     [t| Int |]
490
  , simpleField C.ispecDiskSize    [t| Int |]
491
  , simpleField C.ispecDiskCount   [t| Int |]
492
  , simpleField C.ispecCpuCount    [t| Int |]
493
  , simpleField C.ispecNicCount    [t| Int |]
494
  , simpleField C.ispecSpindleUse  [t| Int |]
495
  ])
496

    
497
-- | Partial min-max instance specs. These is not built via buildParam since
498
-- it has a special 2-level inheritance mode.
499
$(buildObject "PartialMinMaxISpecs" "mmis"
500
  [ renameField "MinSpecP" $ simpleField "min" [t| PartialISpecParams |]
501
  , renameField "MaxSpecP" $ simpleField "max" [t| PartialISpecParams |]
502
  ])
503

    
504
-- | Filled min-max instance specs. This is not built via buildParam since
505
-- it has a special 2-level inheritance mode.
506
$(buildObject "FilledMinMaxISpecs" "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| PartialMinMaxISpecs |]
516
  , renameField "StdSpecP" $ simpleField "std" [t| PartialISpecParams |]
517
  , optionalField . renameField "SpindleRatioP"
518
                    $ simpleField "spindle-ratio"  [t| Double |]
519
  , optionalField . renameField "VcpuRatioP"
520
                    $ simpleField "vcpu-ratio"     [t| Double |]
521
  , optionalField . renameField "DiskTemplatesP"
522
                    $ simpleField "disk-templates" [t| [DiskTemplate] |]
523
  ])
524

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

    
536
-- | Custom filler for the min-max instance specs.
537
fillMinMaxISpecs :: FilledMinMaxISpecs -> Maybe PartialMinMaxISpecs ->
538
                    FilledMinMaxISpecs
539
fillMinMaxISpecs fminmax Nothing = fminmax
540
fillMinMaxISpecs (FilledMinMaxISpecs { mmisMinSpec = fmin
541
                                     , mmisMaxSpec = fmax })
542
                 (Just PartialMinMaxISpecs { mmisMinSpecP = pmin
543
                                           , mmisMaxSpecP = pmax }) =
544
  FilledMinMaxISpecs { mmisMinSpec = fillISpecParams fmin pmin
545
                     , mmisMaxSpec = fillISpecParams fmax pmax }
546

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

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

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

    
592
instance TimeStampObject Node where
593
  cTimeOf = nodeCtime
594
  mTimeOf = nodeMtime
595

    
596
instance UuidObject Node where
597
  uuidOf = nodeUuid
598

    
599
instance SerialNoObject Node where
600
  serialOf = nodeSerial
601

    
602
instance TagsObject Node where
603
  tagsOf = nodeTags
604

    
605
-- * NodeGroup definitions
606

    
607
-- | The disk parameters type.
608
type DiskParams = Container (Container JSValue)
609

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

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

    
627
instance TimeStampObject NodeGroup where
628
  cTimeOf = groupCtime
629
  mTimeOf = groupMtime
630

    
631
instance UuidObject NodeGroup where
632
  uuidOf = groupUuid
633

    
634
instance SerialNoObject NodeGroup where
635
  serialOf = groupSerial
636

    
637
instance TagsObject NodeGroup where
638
  tagsOf = groupTags
639

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

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

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

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

    
659
-- | Cluser BeParams.
660
type ClusterBeParams = Container FilledBeParams
661

    
662
-- | Cluster OsParams.
663
type ClusterOsParams = Container OsParams
664

    
665
-- | Cluster NicParams.
666
type ClusterNicParams = Container FilledNicParams
667

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

    
671
-- * Cluster definitions
672
$(buildObject "Cluster" "cluster" $
673
  [ simpleField "rsahostkeypub"           [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