Objects.hs 26.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, 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
  , Instance(..)
Hrvoje Ribicic's avatar
Hrvoje Ribicic committed
50
  , getDiskSizeRequirements
51
52
53
  , PartialNDParams(..)
  , FilledNDParams(..)
  , fillNDParams
54
  , allNDParamFields
55
56
  , Node(..)
  , AllocPolicy(..)
57
58
59
  , FilledISpecParams(..)
  , PartialISpecParams(..)
  , fillISpecParams
60
  , allISpecParamFields
61
  , MinMaxISpecs(..)
62
63
64
  , FilledIPolicy(..)
  , PartialIPolicy(..)
  , fillIPolicy
Iustin Pop's avatar
Iustin Pop committed
65
  , DiskParams
66
  , NodeGroup(..)
Iustin Pop's avatar
Iustin Pop committed
67
  , IpFamily(..)
68
  , ipFamilyToRaw
Iustin Pop's avatar
Iustin Pop committed
69
  , 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
79
  , UidPool
  , formatUidRange
  , UidRange
80
81
  , Cluster(..)
  , ConfigData(..)
82
83
84
85
  , TimeStampObject(..)
  , UuidObject(..)
  , SerialNoObject(..)
  , TagsObject(..)
86
  , DictObject(..) -- re-exported from THH
87
  , TagSet -- re-exported from THH
88
  , Network(..)
89
90
91
92
  , Ip4Address(..)
  , Ip4Network(..)
  , readIp4Address
  , nextIp4Address
93
  , IAllocatorParams
94
95
  ) where

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

106
import qualified AutoConf
107
import qualified Ganeti.Constants as C
108
import qualified Ganeti.ConstantUtils as ConstantUtils
109
import Ganeti.JSON
110
import Ganeti.Types
111
import Ganeti.THH
112
import Ganeti.THH.Field
113
import Ganeti.Utils (sepSplit, tryRead, parseUnitAssumeBinary)
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
-- | 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
132
type OsParamsPrivate = Container (Private String)
Iustin Pop's avatar
Iustin Pop committed
133

134
135
-- | Class of objects that have timestamps.
class TimeStampObject a where
136
137
  cTimeOf :: a -> ClockTime
  mTimeOf :: a -> ClockTime
138
139
140
141
142
143
144
145
146
147
148
149
150

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

151
152
-- * Network definitions

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
213
214
215
216
-- ** 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.

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

instance SerialNoObject Network where
  serialOf = networkSerial

instance TagsObject Network where
  tagsOf = networkTags

246
247
248
instance UuidObject Network where
  uuidOf = networkUuid

249
250
251
252
instance TimeStampObject Network where
  cTimeOf = networkCtime
  mTimeOf = networkMtime

253
254
-- * NIC definitions

Iustin Pop's avatar
Iustin Pop committed
255
$(buildParam "Nic" "nicp"
256
257
  [ simpleField "mode" [t| NICMode |]
  , simpleField "link" [t| String  |]
258
  , simpleField "vlan" [t| String |]
259
260
  ])

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

instance UuidObject PartialNic where
  uuidOf = nicUuid
271
272
273

-- * Disk definitions

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

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

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

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

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

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

instance UuidObject Disk where
  uuidOf = diskUuid
424

425
426
427
428
429
430
431
432
433
434
435
-- | 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

436
437
-- * Instance definitions

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

$(buildObject "Instance" "inst" $
450
451
452
453
454
455
456
457
458
459
460
461
462
  [ 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
463
  , optionalField $ simpleField "network_port" [t| Int  |]
464
465
466
  ]
  ++ timeStampFields
  ++ uuidFields
467
468
  ++ serialFields
  ++ tagsFields)
469

470
471
472
473
474
475
476
477
478
479
480
481
482
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
483
484
485
486
487
488
489
490
491
492
493
494
495
-- | 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

496
497
-- * IPolicy definitions

Iustin Pop's avatar
Iustin Pop committed
498
$(buildParam "ISpec" "ispec"
499
500
501
502
503
504
  [ 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 |]
505
506
  ])

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

512
513
-- | 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
514
$(buildObject "PartialIPolicy" "ipolicy"
515
516
517
518
519
520
521
522
523
524
  [ 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] |]
525
526
527
528
  ])

-- | 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
529
$(buildObject "FilledIPolicy" "ipolicy"
530
531
  [ renameField "MinMaxISpecs" $
    simpleField ConstantUtils.ispecsMinmax [t| [MinMaxISpecs] |]
532
533
534
535
536
537
538
539
  , 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
540
fillIPolicy (FilledIPolicy { ipolicyMinMaxISpecs  = fminmax
541
542
543
544
                           , ipolicyStdSpec       = fstd
                           , ipolicySpindleRatio  = fspindleRatio
                           , ipolicyVcpuRatio     = fvcpuRatio
                           , ipolicyDiskTemplates = fdiskTemplates})
545
            (PartialIPolicy { ipolicyMinMaxISpecsP  = pminmax
546
547
548
549
                            , ipolicyStdSpecP       = pstd
                            , ipolicySpindleRatioP  = pspindleRatio
                            , ipolicyVcpuRatioP     = pvcpuRatio
                            , ipolicyDiskTemplatesP = pdiskTemplates}) =
550
551
552
553
  FilledIPolicy { ipolicyMinMaxISpecs  = fromMaybe fminmax pminmax
                , ipolicyStdSpec       = case pstd of
                                         Nothing -> fstd
                                         Just p -> fillISpecParams fstd p
554
555
556
557
558
                , ipolicySpindleRatio  = fromMaybe fspindleRatio pspindleRatio
                , ipolicyVcpuRatio     = fromMaybe fvcpuRatio pvcpuRatio
                , ipolicyDiskTemplates = fromMaybe fdiskTemplates
                                         pdiskTemplates
                }
559
560
-- * Node definitions

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

$(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
582
  , simpleField "ndparams"         [t| PartialNDParams |]
583
584
585
586
  , simpleField "powered"          [t| Bool   |]
  ]
  ++ timeStampFields
  ++ uuidFields
587
588
  ++ serialFields
  ++ tagsFields)
589

590
591
592
593
594
595
596
597
598
599
600
601
602
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

603
604
-- * NodeGroup definitions

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

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

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

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

-- | Cluster NicParams.
type ClusterNicParams = Container FilledNicParams

667
668
669
670
671
672
673
674
-- | A low-high UID ranges.
type UidRange = (Int, Int)

formatUidRange :: UidRange -> String
formatUidRange (lower, higher)
  | lower == higher = show lower
  | otherwise       = show lower ++ "-" ++ show higher

Iustin Pop's avatar
Iustin Pop committed
675
-- | Cluster UID Pool, list (low, high) UID ranges.
676
type UidPool = [UidRange]
Iustin Pop's avatar
Iustin Pop committed
677

678
679
680
-- | The iallocator parameters type.
type IAllocatorParams = Container JSValue

681
682
683
-- | The master candidate client certificate digests
type CandidateCertificates = Container String

684
685
-- * Cluster definitions
$(buildObject "Cluster" "cluster" $
686
  [ simpleField "rsahostkeypub"                  [t| String                 |]
687
  , optionalField $
688
689
690
691
    simpleField "dsahostkeypub"                  [t| String                 |]
  , simpleField "highest_used_port"              [t| Int                    |]
  , simpleField "tcpudp_port_pool"               [t| [Int]                  |]
  , simpleField "mac_prefix"                     [t| String                 |]
692
  , optionalField $
693
694
    simpleField "volume_group_name"              [t| String                 |]
  , simpleField "reserved_lvs"                   [t| [String]               |]
Iustin Pop's avatar
Iustin Pop committed
695
  , optionalField $
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
    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                 |]
Hrvoje Ribicic's avatar
Hrvoje Ribicic committed
731
  , simpleField "zeroing_image"                  [t| String                 |]
732
 ]
Iustin Pop's avatar
Iustin Pop committed
733
734
 ++ timeStampFields
 ++ uuidFields
735
 ++ serialFields
Iustin Pop's avatar
Iustin Pop committed
736
 ++ tagsFields)
737

738
739
740
741
742
743
744
745
746
747
748
749
750
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

751
752
753
754
-- * ConfigData definitions

$(buildObject "ConfigData" "config" $
--  timeStampFields ++
755
756
757
758
759
  [ simpleField "version"    [t| Int                 |]
  , simpleField "cluster"    [t| Cluster             |]
  , simpleField "nodes"      [t| Container Node      |]
  , simpleField "nodegroups" [t| Container NodeGroup |]
  , simpleField "instances"  [t| Container Instance  |]
760
  , simpleField "networks"   [t| Container Network   |]
761
  ]
Petr Pudlak's avatar
Petr Pudlak committed
762
  ++ timeStampFields
763
  ++ serialFields)
764
765
766

instance SerialNoObject ConfigData where
  serialOf = configSerial
Petr Pudlak's avatar
Petr Pudlak committed
767
768
769
770

instance TimeStampObject ConfigData where
  cTimeOf = configCtime
  mTimeOf = configMtime