Objects.hs 24.6 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
{-# LANGUAGE TemplateHaskell #-}

{-| Implementation of the Ganeti config objects.

Some object fields are not implemented yet, and as such they are
commented out below.

-}

{-

12
Copyright (C) 2011, 2012, 2013 Google Inc.
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.

-}

module Ganeti.Objects
Iustin Pop's avatar
Iustin Pop committed
32
33
34
  ( VType(..)
  , vTypeFromRaw
  , HvParams
Iustin Pop's avatar
Iustin Pop committed
35
36
37
38
  , OsParams
  , PartialNicParams(..)
  , FilledNicParams(..)
  , fillNicParams
39
  , allNicParamFields
Iustin Pop's avatar
Iustin Pop committed
40
  , PartialNic(..)
41
42
  , FileDriver(..)
  , BlockDriver(..)
43
44
  , DiskMode(..)
  , DiskType(..)
45
  , DiskLogicalId(..)
46
47
  , Disk(..)
  , DiskTemplate(..)
Iustin Pop's avatar
Iustin Pop committed
48
49
50
  , PartialBeParams(..)
  , FilledBeParams(..)
  , fillBeParams
51
  , allBeParamFields
52
53
  , AdminState(..)
  , adminStateFromRaw
54
55
56
57
58
  , Instance(..)
  , toDictInstance
  , PartialNDParams(..)
  , FilledNDParams(..)
  , fillNDParams
59
  , allNDParamFields
60
  , Node(..)
61
62
63
  , NodeRole(..)
  , nodeRoleToRaw
  , roleDescription
64
  , AllocPolicy(..)
65
66
67
  , FilledISpecParams(..)
  , PartialISpecParams(..)
  , fillISpecParams
68
  , allISpecParamFields
69
70
71
  , FilledMinMaxISpecs(..)
  , PartialMinMaxISpecs(..)
  , fillMinMaxISpecs
72
73
74
  , FilledIPolicy(..)
  , PartialIPolicy(..)
  , fillIPolicy
Iustin Pop's avatar
Iustin Pop committed
75
  , DiskParams
76
  , NodeGroup(..)
Iustin Pop's avatar
Iustin Pop committed
77
78
  , IpFamily(..)
  , ipFamilyToVersion
Iustin Pop's avatar
Iustin Pop committed
79
  , fillDict
Iustin Pop's avatar
Iustin Pop committed
80
81
82
83
84
  , ClusterHvParams
  , OsHvParams
  , ClusterBeParams
  , ClusterOsParams
  , ClusterNicParams
85
86
  , Cluster(..)
  , ConfigData(..)
87
88
89
90
  , TimeStampObject(..)
  , UuidObject(..)
  , SerialNoObject(..)
  , TagsObject(..)
91
  , DictObject(..) -- re-exported from THH
92
  , TagSet -- re-exported from THH
93
  , Network(..)
94
95
96
97
  , Ip4Address(..)
  , Ip4Network(..)
  , readIp4Address
  , nextIp4Address
98
99
  ) where

100
import Control.Applicative
Iustin Pop's avatar
Iustin Pop committed
101
import Data.List (foldl')
102
import Data.Maybe
Iustin Pop's avatar
Iustin Pop committed
103
import qualified Data.Map as Map
104
import qualified Data.Set as Set
105
106
import Data.Word
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

Iustin Pop's avatar
Iustin Pop committed
115
116
117
118
119
120
121
122
123
-- * Generic definitions

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

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

Iustin Pop's avatar
Iustin Pop committed
134
135
136
137
138
139
140
141
142
-- | The hypervisor parameter type. This is currently a simple map,
-- without type checking on key/value pairs.
type HvParams = Container JSValue

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

143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
-- | Class of objects that have timestamps.
class TimeStampObject a where
  cTimeOf :: a -> Double
  mTimeOf :: a -> Double

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

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

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

160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
-- * Node role object

$(declareSADT "NodeRole"
  [ ("NROffline",   'C.nrOffline)
  , ("NRDrained",   'C.nrDrained)
  , ("NRRegular",   'C.nrRegular)
  , ("NRCandidate", 'C.nrMcandidate)
  , ("NRMaster",    'C.nrMaster)
  ])
$(makeJSONInstance ''NodeRole)

-- | The description of the node role.
roleDescription :: NodeRole -> String
roleDescription NROffline   = "offline"
roleDescription NRDrained   = "drained"
roleDescription NRRegular   = "regular"
roleDescription NRCandidate = "master candidate"
roleDescription NRMaster    = "master"

179
180
-- * Network definitions

181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
-- ** Ipv4 types

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

instance Show Ip4Address where
  show (Ip4Address a b c d) = show a ++ "." ++ show b ++ "." ++
                              show c ++ "." ++ show d

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

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

-- | \"Next\" address implementation for IPv4 addresses.
--
-- Note that this loops! Note also that this is a very dumb
-- implementation.
nextIp4Address :: Ip4Address -> Ip4Address
nextIp4Address (Ip4Address a b c d) =
  let inc xs y = if all (==0) xs then y + 1 else y
      d' = d + 1
      c' = inc [d'] c
      b' = inc [c', d'] b
      a' = inc [b', c', d'] a
  in Ip4Address a' b' c' d'

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

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

-- | JSON instance for 'Ip4Network'.
instance JSON Ip4Network where
  showJSON = showJSON . show
  readJSON (JSString s) =
    case sepSplit '/' (fromJSString s) of
      [ip, nm] -> do
        ip' <- readIp4Address ip
        nm' <- tryRead "parsing netmask" nm
        if nm' >= 0 && nm' <= 32
          then return $ Ip4Network ip' nm'
          else fail $ "Invalid netmask " ++ show nm' ++ " from string " ++
                      fromJSString s
      _ -> fail $ "Can't parse IPv4 network from string " ++ fromJSString s
  readJSON v = fail $ "Invalid JSON value " ++ show v ++ " for an IPv4 network"

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

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

instance SerialNoObject Network where
  serialOf = networkSerial

instance TagsObject Network where
  tagsOf = networkTags

273
274
275
instance UuidObject Network where
  uuidOf = networkUuid

276
277
-- * NIC definitions

Iustin Pop's avatar
Iustin Pop committed
278
$(buildParam "Nic" "nicp"
279
280
281
282
  [ simpleField "mode" [t| NICMode |]
  , simpleField "link" [t| String  |]
  ])

Iustin Pop's avatar
Iustin Pop committed
283
$(buildObject "PartialNic" "nic"
284
285
  [ simpleField "mac" [t| String |]
  , optionalField $ simpleField "ip" [t| String |]
Iustin Pop's avatar
Iustin Pop committed
286
  , simpleField "nicparams" [t| PartialNicParams |]
287
  , optionalField $ simpleField "network" [t| String |]
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
  ])

-- * Disk definitions

$(declareSADT "DiskMode"
  [ ("DiskRdOnly", 'C.diskRdonly)
  , ("DiskRdWr",   'C.diskRdwr)
  ])
$(makeJSONInstance ''DiskMode)

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

308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
-- | The persistent block driver type. Currently only one type is allowed.
$(declareSADT "BlockDriver"
  [ ("BlockDrvManual", 'C.blockdevDriverManual)
  ])
$(makeJSONInstance ''BlockDriver)

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

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

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

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

-- | Custom encoder for DiskLogicalId (logical id only).
encodeDLId :: DiskLogicalId -> JSValue
encodeDLId (LIDPlain vg lv) = JSArray [showJSON vg, showJSON lv]
encodeDLId (LIDDrbd8 nodeA nodeB port minorA minorB key) =
  JSArray [ showJSON nodeA, showJSON nodeB, showJSON port
          , showJSON minorA, showJSON minorB, showJSON key ]
encodeDLId (LIDRados pool name) = JSArray [showJSON pool, showJSON name]
encodeDLId (LIDFile driver name) = JSArray [showJSON driver, showJSON name]
encodeDLId (LIDBlockDev driver name) = JSArray [showJSON driver, showJSON name]
Iustin Pop's avatar
Iustin Pop committed
354
355
encodeDLId (LIDExt extprovider name) =
  JSArray [showJSON extprovider, showJSON name]
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377

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

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

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

$(buildObjectSerialisation "Disk"
Iustin Pop's avatar
Iustin Pop committed
429
  [ customField 'decodeDLId 'encodeFullDLId ["dev_type"] $
430
      simpleField "logical_id"    [t| DiskLogicalId   |]
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
--  , simpleField "physical_id" [t| String   |]
  , defaultField  [| [] |] $ simpleField "children" [t| [Disk] |]
  , defaultField [| "" |] $ simpleField "iv_name" [t| String |]
  , simpleField "size" [t| Int |]
  , defaultField [| DiskRdWr |] $ simpleField "mode" [t| DiskMode |]
  ])

-- * Instance definitions

$(declareSADT "AdminState"
  [ ("AdminOffline", 'C.adminstOffline)
  , ("AdminDown",    'C.adminstDown)
  , ("AdminUp",      'C.adminstUp)
  ])
$(makeJSONInstance ''AdminState)

Iustin Pop's avatar
Iustin Pop committed
447
$(buildParam "Be" "bep"
448
449
450
451
452
453
454
455
456
457
  [ simpleField "minmem"       [t| Int  |]
  , simpleField "maxmem"       [t| Int  |]
  , simpleField "vcpus"        [t| Int  |]
  , simpleField "auto_balance" [t| Bool |]
  ])

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

473
474
475
476
477
478
479
480
481
482
483
484
485
instance TimeStampObject Instance where
  cTimeOf = instCtime
  mTimeOf = instMtime

instance UuidObject Instance where
  uuidOf = instUuid

instance SerialNoObject Instance where
  serialOf = instSerial

instance TagsObject Instance where
  tagsOf = instTags

486
487
-- * IPolicy definitions

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

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

-- | Filled min-max instance specs. This is not built via buildParam since
-- it has a special 2-level inheritance mode.
$(buildObject "FilledMinMaxISpecs" "mmis"
  [ renameField "MinSpec" $ simpleField "min" [t| FilledISpecParams |]
  , renameField "MaxSpec" $ simpleField "max" [t| FilledISpecParams |]
  ])

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

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

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

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

Iustin Pop's avatar
Iustin Pop committed
568
$(buildParam "ND" "ndp"
569
570
  [ simpleField "oob_program"   [t| String |]
  , simpleField "spindle_count" [t| Int    |]
571
  , simpleField "exclusive_storage" [t| Bool |]
572
573
574
575
576
577
578
579
580
581
582
583
  ])

$(buildObject "Node" "node" $
  [ simpleField "name"             [t| String |]
  , simpleField "primary_ip"       [t| String |]
  , simpleField "secondary_ip"     [t| String |]
  , simpleField "master_candidate" [t| Bool   |]
  , simpleField "offline"          [t| Bool   |]
  , simpleField "drained"          [t| Bool   |]
  , simpleField "group"            [t| String |]
  , simpleField "master_capable"   [t| Bool   |]
  , simpleField "vm_capable"       [t| Bool   |]
Iustin Pop's avatar
Iustin Pop committed
584
  , simpleField "ndparams"         [t| PartialNDParams |]
585
586
587
588
  , simpleField "powered"          [t| Bool   |]
  ]
  ++ timeStampFields
  ++ uuidFields
589
590
  ++ serialFields
  ++ tagsFields)
591

592
593
594
595
596
597
598
599
600
601
602
603
604
instance TimeStampObject Node where
  cTimeOf = nodeCtime
  mTimeOf = nodeMtime

instance UuidObject Node where
  uuidOf = nodeUuid

instance SerialNoObject Node where
  serialOf = nodeSerial

instance TagsObject Node where
  tagsOf = nodeTags

605
606
-- * NodeGroup definitions

Iustin Pop's avatar
Iustin Pop committed
607
608
609
-- | The disk parameters type.
type DiskParams = Container (Container JSValue)

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

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

627
628
629
630
631
632
633
634
635
636
637
638
639
instance TimeStampObject NodeGroup where
  cTimeOf = groupCtime
  mTimeOf = groupMtime

instance UuidObject NodeGroup where
  uuidOf = groupUuid

instance SerialNoObject NodeGroup where
  serialOf = groupSerial

instance TagsObject NodeGroup where
  tagsOf = groupTags

Iustin Pop's avatar
Iustin Pop committed
640
641
642
643
644
645
646
647
648
649
650
651
652
-- | IP family type
$(declareIADT "IpFamily"
  [ ("IpFamilyV4", 'C.ip4Family)
  , ("IpFamilyV6", 'C.ip6Family)
  ])
$(makeJSONInstance ''IpFamily)

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

Iustin Pop's avatar
Iustin Pop committed
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
-- | Cluster HvParams (hvtype to hvparams mapping).
type ClusterHvParams = Container HvParams

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

-- | Cluser BeParams.
type ClusterBeParams = Container FilledBeParams

-- | Cluster OsParams.
type ClusterOsParams = Container OsParams

-- | Cluster NicParams.
type ClusterNicParams = Container FilledNicParams

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

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

716
717
718
719
720
721
722
723
724
725
726
727
728
instance TimeStampObject Cluster where
  cTimeOf = clusterCtime
  mTimeOf = clusterMtime

instance UuidObject Cluster where
  uuidOf = clusterUuid

instance SerialNoObject Cluster where
  serialOf = clusterSerial

instance TagsObject Cluster where
  tagsOf = clusterTags

729
730
731
732
-- * ConfigData definitions

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

instance SerialNoObject ConfigData where
  serialOf = configSerial