Objects.hs 26.1 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, 2014 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
32
  ( HvParams
Iustin Pop's avatar
Iustin Pop committed
33
  , OsParams
34
  , OsParamsPrivate
Iustin Pop's avatar
Iustin Pop committed
35
36
37
  , PartialNicParams(..)
  , FilledNicParams(..)
  , fillNicParams
38
  , allNicParamFields
Iustin Pop's avatar
Iustin Pop committed
39
  , PartialNic(..)
40
  , FileDriver(..)
41
  , DiskLogicalId(..)
42
  , Disk(..)
43
  , includesLogicalId
44
  , DiskTemplate(..)
Iustin Pop's avatar
Iustin Pop committed
45
46
47
  , PartialBeParams(..)
  , FilledBeParams(..)
  , fillBeParams
48
  , allBeParamFields
49
50
  , Instance(..)
  , toDictInstance
Hrvoje Ribicic's avatar
Hrvoje Ribicic committed
51
  , getDiskSizeRequirements
52
53
54
  , PartialNDParams(..)
  , FilledNDParams(..)
  , fillNDParams
55
  , allNDParamFields
56
57
  , Node(..)
  , AllocPolicy(..)
58
59
60
  , FilledISpecParams(..)
  , PartialISpecParams(..)
  , fillISpecParams
61
  , allISpecParamFields
62
  , MinMaxISpecs(..)
63
64
65
  , FilledIPolicy(..)
  , PartialIPolicy(..)
  , fillIPolicy
Iustin Pop's avatar
Iustin Pop committed
66
  , DiskParams
67
  , NodeGroup(..)
Iustin Pop's avatar
Iustin Pop committed
68
69
  , IpFamily(..)
  , ipFamilyToVersion
Iustin Pop's avatar
Iustin Pop committed
70
  , fillDict
Iustin Pop's avatar
Iustin Pop committed
71
72
73
74
  , ClusterHvParams
  , OsHvParams
  , ClusterBeParams
  , ClusterOsParams
75
  , ClusterOsParamsPrivate
Iustin Pop's avatar
Iustin Pop committed
76
  , ClusterNicParams
77
78
  , Cluster(..)
  , ConfigData(..)
79
80
81
82
  , TimeStampObject(..)
  , UuidObject(..)
  , SerialNoObject(..)
  , TagsObject(..)
83
  , DictObject(..) -- re-exported from THH
84
  , TagSet -- re-exported from THH
85
  , Network(..)
86
87
88
89
  , Ip4Address(..)
  , Ip4Network(..)
  , readIp4Address
  , nextIp4Address
90
  , IAllocatorParams
91
92
  ) where

93
import Control.Applicative
Iustin Pop's avatar
Iustin Pop committed
94
import Data.List (foldl')
95
import Data.Maybe
Iustin Pop's avatar
Iustin Pop committed
96
import qualified Data.Map as Map
97
import qualified Data.Set as Set
98
import Data.Word
99
import System.Time (ClockTime(..))
100
import Text.JSON (showJSON, readJSON, JSON, JSValue(..), fromJSString)
101
import qualified Text.JSON as J
102

103
import qualified AutoConf
104
import qualified Ganeti.Constants as C
105
import qualified Ganeti.ConstantUtils as ConstantUtils
106
import Ganeti.JSON
107
import Ganeti.Types
108
import Ganeti.THH
109
import Ganeti.Utils (sepSplit, tryRead, parseUnitAssumeBinary)
110

Iustin Pop's avatar
Iustin Pop committed
111
112
113
114
115
116
117
118
119
-- * 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
120
121
122
123
124
125
126
127
-- | 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
128
type OsParamsPrivate = Container (Private String)
Iustin Pop's avatar
Iustin Pop committed
129

130
131
-- | Class of objects that have timestamps.
class TimeStampObject a where
132
133
  cTimeOf :: a -> ClockTime
  mTimeOf :: a -> ClockTime
134
135
136
137
138
139
140
141
142
143
144
145
146

-- | 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

147
148
-- * Network definitions

149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
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
-- ** 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.

213
214
215
216
217
218
-- 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 |]
219
  , simpleField "network"          [t| Ip4Network |]
220
221
222
  , optionalField $
    simpleField "network6"         [t| String |]
  , optionalField $
223
    simpleField "gateway"          [t| Ip4Address |]
224
225
226
227
228
229
230
  , optionalField $
    simpleField "gateway6"         [t| String |]
  , optionalField $
    simpleField "reservations"     [t| String |]
  , optionalField $
    simpleField "ext_reservations" [t| String |]
  ]
231
  ++ uuidFields
232
  ++ timeStampFields
233
234
235
236
237
238
239
240
241
  ++ serialFields
  ++ tagsFields)

instance SerialNoObject Network where
  serialOf = networkSerial

instance TagsObject Network where
  tagsOf = networkTags

242
243
244
instance UuidObject Network where
  uuidOf = networkUuid

245
246
247
248
instance TimeStampObject Network where
  cTimeOf = networkCtime
  mTimeOf = networkMtime

249
250
-- * NIC definitions

Iustin Pop's avatar
Iustin Pop committed
251
$(buildParam "Nic" "nicp"
252
253
  [ simpleField "mode" [t| NICMode |]
  , simpleField "link" [t| String  |]
254
  , simpleField "vlan" [t| String |]
255
256
  ])

257
$(buildObject "PartialNic" "nic" $
258
259
  [ simpleField "mac" [t| String |]
  , optionalField $ simpleField "ip" [t| String |]
Iustin Pop's avatar
Iustin Pop committed
260
  , simpleField "nicparams" [t| PartialNicParams |]
261
  , optionalField $ simpleField "network" [t| String |]
262
263
264
265
266
  , optionalField $ simpleField "name" [t| String |]
  ] ++ uuidFields)

instance UuidObject PartialNic where
  uuidOf = nicUuid
267
268
269

-- * Disk definitions

270
271
272
273
274
275
276
277
278
279
280
281
282
-- | 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
283
  | LIDSharedFile FileDriver String -- ^ Driver, path
284
285
  | LIDBlockDev BlockDriver String -- ^ Driver, path (must be under /dev)
  | LIDRados String String -- ^ Unused, path
286
  | LIDExt String String -- ^ ExtProvider, unique name
287
    deriving (Show, Eq)
288
289

-- | Mapping from a logical id to a disk type.
290
291
292
293
294
295
296
297
lidDiskType :: DiskLogicalId -> DiskTemplate
lidDiskType (LIDPlain {}) = DTPlain
lidDiskType (LIDDrbd8 {}) = DTDrbd8
lidDiskType (LIDFile  {}) = DTFile
lidDiskType (LIDSharedFile  {}) = DTSharedFile
lidDiskType (LIDBlockDev {}) = DTBlock
lidDiskType (LIDRados {}) = DTRbd
lidDiskType (LIDExt {}) = DTExt
298
299
300
301
302
303
304
305
306
307
308
309
310

-- | 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]
311
312
encodeDLId (LIDSharedFile driver name) =
  JSArray [showJSON driver, showJSON name]
313
encodeDLId (LIDBlockDev driver name) = JSArray [showJSON driver, showJSON name]
Iustin Pop's avatar
Iustin Pop committed
314
315
encodeDLId (LIDExt extprovider name) =
  JSArray [showJSON extprovider, showJSON name]
316
317
318
319
320
321
322
323
324
325
326
327

-- | 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
328
    DTDrbd8 ->
329
330
331
332
333
334
335
336
337
      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
338
        _ -> fail "Can't read logical_id for DRBD8 type"
339
    DTPlain ->
340
341
342
343
344
      case lid of
        JSArray [vg, lv] -> do
          vg' <- readJSON vg
          lv' <- readJSON lv
          return $ LIDPlain vg' lv'
Iustin Pop's avatar
Iustin Pop committed
345
        _ -> fail "Can't read logical_id for plain type"
346
    DTFile ->
347
348
349
350
351
      case lid of
        JSArray [driver, path] -> do
          driver' <- readJSON driver
          path'   <- readJSON path
          return $ LIDFile driver' path'
Iustin Pop's avatar
Iustin Pop committed
352
        _ -> fail "Can't read logical_id for file type"
353
354
355
356
357
358
359
    DTSharedFile ->
      case lid of
        JSArray [driver, path] -> do
          driver' <- readJSON driver
          path'   <- readJSON path
          return $ LIDSharedFile driver' path'
        _ -> fail "Can't read logical_id for shared file type"
Santi Raffa's avatar
Santi Raffa committed
360
361
362
363
364
365
366
    DTGluster ->
      case lid of
        JSArray [driver, path] -> do
          driver' <- readJSON driver
          path'   <- readJSON path
          return $ LIDSharedFile driver' path'
        _ -> fail "Can't read logical_id for shared file type"
367
    DTBlock ->
368
369
370
371
372
      case lid of
        JSArray [driver, path] -> do
          driver' <- readJSON driver
          path'   <- readJSON path
          return $ LIDBlockDev driver' path'
Iustin Pop's avatar
Iustin Pop committed
373
        _ -> fail "Can't read logical_id for blockdev type"
374
    DTRbd ->
375
376
377
378
379
      case lid of
        JSArray [driver, path] -> do
          driver' <- readJSON driver
          path'   <- readJSON path
          return $ LIDRados driver' path'
Iustin Pop's avatar
Iustin Pop committed
380
        _ -> fail "Can't read logical_id for rdb type"
381
    DTExt ->
382
383
384
385
386
387
      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"
388
389
    DTDiskless ->
      fail "Retrieved 'diskless' disk."
390

391
392
393
394
395
-- | 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
396
  { diskLogicalId  :: DiskLogicalId
397
398
399
400
  , diskChildren   :: [Disk]
  , diskIvName     :: String
  , diskSize       :: Int
  , diskMode       :: DiskMode
401
  , diskName       :: Maybe String
402
  , diskSpindles   :: Maybe Int
403
  , diskUuid       :: String
404
  } deriving (Show, Eq)
405

406
$(buildObjectSerialisation "Disk" $
Iustin Pop's avatar
Iustin Pop committed
407
  [ customField 'decodeDLId 'encodeFullDLId ["dev_type"] $
408
      simpleField "logical_id"    [t| DiskLogicalId   |]
409
410
411
412
  , defaultField  [| [] |] $ simpleField "children" [t| [Disk] |]
  , defaultField [| "" |] $ simpleField "iv_name" [t| String |]
  , simpleField "size" [t| Int |]
  , defaultField [| DiskRdWr |] $ simpleField "mode" [t| DiskMode |]
413
  , optionalField $ simpleField "name" [t| String |]
414
  , optionalField $ simpleField "spindles" [t| Int |]
415
416
417
418
419
  ]
  ++ uuidFields)

instance UuidObject Disk where
  uuidOf = diskUuid
420

421
422
423
424
425
426
427
428
429
430
431
-- | Determines whether a disk or one of his children has the given logical id
-- (determined by the volume group name and by the logical volume name).
-- This can be true only for DRBD or LVM disks.
includesLogicalId :: String -> String -> Disk -> Bool
includesLogicalId vg_name lv_name disk =
  case diskLogicalId disk of
    LIDPlain vg lv -> vg_name == vg && lv_name == lv
    LIDDrbd8 {} ->
      any (includesLogicalId vg_name lv_name) $ diskChildren disk
    _ -> False

432
433
-- * Instance definitions

Iustin Pop's avatar
Iustin Pop committed
434
$(buildParam "Be" "bep"
435
436
437
438
  [ specialNumericalField 'parseUnitAssumeBinary
      $ simpleField "minmem"      [t| Int  |]
  , specialNumericalField 'parseUnitAssumeBinary
      $ simpleField "maxmem"      [t| Int  |]
Hrvoje Ribicic's avatar
Hrvoje Ribicic committed
439
440
441
442
  , simpleField "vcpus"           [t| Int  |]
  , simpleField "auto_balance"    [t| Bool |]
  , simpleField "always_failover" [t| Bool |]
  , simpleField "spindle_use"     [t| Int  |]
443
444
445
  ])

$(buildObject "Instance" "inst" $
446
447
448
449
450
451
452
453
454
455
456
457
458
  [ simpleField "name"             [t| String             |]
  , simpleField "primary_node"     [t| String             |]
  , simpleField "os"               [t| String             |]
  , simpleField "hypervisor"       [t| Hypervisor         |]
  , simpleField "hvparams"         [t| HvParams           |]
  , simpleField "beparams"         [t| PartialBeParams    |]
  , simpleField "osparams"         [t| OsParams           |]
  , simpleField "osparams_private" [t| OsParamsPrivate    |]
  , simpleField "admin_state"      [t| AdminState         |]
  , simpleField "nics"             [t| [PartialNic]       |]
  , simpleField "disks"            [t| [Disk]             |]
  , simpleField "disk_template"    [t| DiskTemplate       |]
  , simpleField "disks_active"     [t| Bool               |]
Iustin Pop's avatar
Iustin Pop committed
459
  , optionalField $ simpleField "network_port" [t| Int  |]
460
461
462
  ]
  ++ timeStampFields
  ++ uuidFields
463
464
  ++ serialFields
  ++ tagsFields)
465

466
467
468
469
470
471
472
473
474
475
476
477
478
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

Hrvoje Ribicic's avatar
Hrvoje Ribicic committed
479
480
481
482
483
484
485
486
487
488
489
490
491
-- | Retrieves the real disk size requirements for all the disks of the
-- instance. This includes the metadata etc. and is different from the values
-- visible to the instance.
getDiskSizeRequirements :: Instance -> Int
getDiskSizeRequirements inst =
  sum . map
    (\disk -> case instDiskTemplate inst of
                DTDrbd8    -> diskSize disk + C.drbdMetaSize
                DTDiskless -> 0
                DTBlock    -> 0
                _          -> diskSize disk )
    $ instDisks inst

492
493
-- * IPolicy definitions

Iustin Pop's avatar
Iustin Pop committed
494
$(buildParam "ISpec" "ispec"
495
496
497
498
499
500
  [ simpleField ConstantUtils.ispecMemSize     [t| Int |]
  , simpleField ConstantUtils.ispecDiskSize    [t| Int |]
  , simpleField ConstantUtils.ispecDiskCount   [t| Int |]
  , simpleField ConstantUtils.ispecCpuCount    [t| Int |]
  , simpleField ConstantUtils.ispecNicCount    [t| Int |]
  , simpleField ConstantUtils.ispecSpindleUse  [t| Int |]
501
502
  ])

503
$(buildObject "MinMaxISpecs" "mmis"
504
505
506
507
  [ renameField "MinSpec" $ simpleField "min" [t| FilledISpecParams |]
  , renameField "MaxSpec" $ simpleField "max" [t| FilledISpecParams |]
  ])

508
509
-- | 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
510
$(buildObject "PartialIPolicy" "ipolicy"
511
512
513
514
515
516
517
518
519
520
  [ optionalField . renameField "MinMaxISpecsP" $
    simpleField ConstantUtils.ispecsMinmax [t| [MinMaxISpecs] |]
  , optionalField . 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] |]
521
522
523
524
  ])

-- | 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
525
$(buildObject "FilledIPolicy" "ipolicy"
526
527
  [ renameField "MinMaxISpecs" $
    simpleField ConstantUtils.ispecsMinmax [t| [MinMaxISpecs] |]
528
529
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] |]
  ])

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

Iustin Pop's avatar
Iustin Pop committed
557
$(buildParam "ND" "ndp"
558
559
  [ simpleField "oob_program"   [t| String |]
  , simpleField "spindle_count" [t| Int    |]
560
  , simpleField "exclusive_storage" [t| Bool |]
561
562
563
  , simpleField "ovs"           [t| Bool |]
  , simpleField "ovs_name"       [t| String |]
  , simpleField "ovs_link"       [t| String |]
564
  , simpleField "ssh_port"      [t| Int |]
565
566
567
568
569
570
571
572
573
574
575
576
  ])

$(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
577
  , simpleField "ndparams"         [t| PartialNDParams |]
578
579
580
581
  , simpleField "powered"          [t| Bool   |]
  ]
  ++ timeStampFields
  ++ uuidFields
582
583
  ++ serialFields
  ++ tagsFields)
584

585
586
587
588
589
590
591
592
593
594
595
596
597
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

598
599
-- * NodeGroup definitions

Iustin Pop's avatar
Iustin Pop committed
600
601
602
-- | The disk parameters type.
type DiskParams = Container (Container JSValue)

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

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

620
621
622
623
624
625
626
627
628
629
630
631
632
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
633
634
-- | IP family type
$(declareIADT "IpFamily"
635
636
  [ ("IpFamilyV4", 'AutoConf.pyAfInet4)
  , ("IpFamilyV6", 'AutoConf.pyAfInet6)
Iustin Pop's avatar
Iustin Pop committed
637
638
639
640
641
642
643
644
645
  ])
$(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
646
647
648
649
650
651
652
653
654
655
656
-- | 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
657
type ClusterOsParamsPrivate = Container (Private OsParams)
Iustin Pop's avatar
Iustin Pop committed
658
659
660
661
662
663
664

-- | Cluster NicParams.
type ClusterNicParams = Container FilledNicParams

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

665
666
667
-- | The iallocator parameters type.
type IAllocatorParams = Container JSValue

668
669
670
-- | The master candidate client certificate digests
type CandidateCertificates = Container String

671
672
-- * Cluster definitions
$(buildObject "Cluster" "cluster" $
673
  [ simpleField "rsahostkeypub"                  [t| String                 |]
674
  , optionalField $
675
676
677
678
    simpleField "dsahostkeypub"                  [t| String                 |]
  , simpleField "highest_used_port"              [t| Int                    |]
  , simpleField "tcpudp_port_pool"               [t| [Int]                  |]
  , simpleField "mac_prefix"                     [t| String                 |]
679
  , optionalField $
680
681
    simpleField "volume_group_name"              [t| String                 |]
  , simpleField "reserved_lvs"                   [t| [String]               |]
Iustin Pop's avatar
Iustin Pop committed
682
  , optionalField $
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
    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                 |]
  , simpleField "gluster_storage_dir"            [t| String                 |]
  , simpleField "enabled_hypervisors"            [t| [Hypervisor]           |]
  , simpleField "hvparams"                       [t| ClusterHvParams        |]
  , simpleField "os_hvp"                         [t| OsHvParams             |]
  , simpleField "beparams"                       [t| ClusterBeParams        |]
  , simpleField "osparams"                       [t| ClusterOsParams        |]
  , simpleField "osparams_private_cluster"       [t| ClusterOsParamsPrivate |]
  , 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 "default_iallocator_params"      [t| IAllocatorParams       |]
  , 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          |]
  , simpleField "enabled_disk_templates"         [t| [DiskTemplate]         |]
  , simpleField "candidate_certs"                [t| CandidateCertificates  |]
  , simpleField "max_running_jobs"               [t| Int                    |]
  , simpleField "instance_communication_network" [t| String                 |]
718
 ]
Iustin Pop's avatar
Iustin Pop committed
719
720
 ++ timeStampFields
 ++ uuidFields
721
 ++ serialFields
Iustin Pop's avatar
Iustin Pop committed
722
 ++ tagsFields)
723

724
725
726
727
728
729
730
731
732
733
734
735
736
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

737
738
739
740
-- * ConfigData definitions

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

instance SerialNoObject ConfigData where
  serialOf = configSerial