Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Objects.hs @ 8c3b6093

History | View | Annotate | Download (24.1 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
  , optionalField $
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
  ++ 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
-- * NIC definitions
276

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

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

    
290
instance UuidObject PartialNic where
291
  uuidOf = nicUuid
292

    
293
-- * Disk definitions
294

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

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

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

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

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

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

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

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

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

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

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

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

    
447
instance UuidObject Disk where
448
  uuidOf = diskUuid
449

    
450
-- * Instance definitions
451

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

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

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

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

    
489
instance UuidObject Instance where
490
  uuidOf = instUuid
491

    
492
instance SerialNoObject Instance where
493
  serialOf = instSerial
494

    
495
instance TagsObject Instance where
496
  tagsOf = instTags
497

    
498
-- * IPolicy definitions
499

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

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

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

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

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

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

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

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

    
591
instance UuidObject Node where
592
  uuidOf = nodeUuid
593

    
594
instance SerialNoObject Node where
595
  serialOf = nodeSerial
596

    
597
instance TagsObject Node where
598
  tagsOf = nodeTags
599

    
600
-- * NodeGroup definitions
601

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

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

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

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

    
626
instance UuidObject NodeGroup where
627
  uuidOf = groupUuid
628

    
629
instance SerialNoObject NodeGroup where
630
  serialOf = groupSerial
631

    
632
instance TagsObject NodeGroup where
633
  tagsOf = groupTags
634

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

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

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

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

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

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

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

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

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

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

    
715
instance UuidObject Cluster where
716
  uuidOf = clusterUuid
717

    
718
instance SerialNoObject Cluster where
719
  serialOf = clusterSerial
720

    
721
instance TagsObject Cluster where
722
  tagsOf = clusterTags
723

    
724
-- * ConfigData definitions
725

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

    
737
instance SerialNoObject ConfigData where
738
  serialOf = configSerial