Objects.hs 26.4 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
51
52
  , Instance(..)
  , PartialNDParams(..)
  , FilledNDParams(..)
  , fillNDParams
53
  , allNDParamFields
54
55
  , Node(..)
  , AllocPolicy(..)
56
57
58
  , FilledISpecParams(..)
  , PartialISpecParams(..)
  , fillISpecParams
59
  , allISpecParamFields
60
  , MinMaxISpecs(..)
61
62
63
  , FilledIPolicy(..)
  , PartialIPolicy(..)
  , fillIPolicy
64
  , GroupDiskParams
65
  , NodeGroup(..)
Iustin Pop's avatar
Iustin Pop committed
66
  , IpFamily(..)
67
  , ipFamilyToRaw
Iustin Pop's avatar
Iustin Pop committed
68
  , ipFamilyToVersion
Iustin Pop's avatar
Iustin Pop committed
69
  , fillDict
Iustin Pop's avatar
Iustin Pop committed
70
71
72
73
  , ClusterHvParams
  , OsHvParams
  , ClusterBeParams
  , ClusterOsParams
74
  , ClusterOsParamsPrivate
Iustin Pop's avatar
Iustin Pop committed
75
  , ClusterNicParams
76
77
78
  , UidPool
  , formatUidRange
  , UidRange
79
80
  , Cluster(..)
  , ConfigData(..)
81
82
83
84
  , TimeStampObject(..)
  , UuidObject(..)
  , SerialNoObject(..)
  , TagsObject(..)
85
  , DictObject(..) -- re-exported from THH
86
  , TagSet -- re-exported from THH
87
  , Network(..)
88
89
90
91
  , Ip4Address(..)
  , Ip4Network(..)
  , readIp4Address
  , nextIp4Address
92
  , IAllocatorParams
93
94
  ) where

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

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

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

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

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

150
151
-- * Network definitions

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

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

instance SerialNoObject Network where
  serialOf = networkSerial

instance TagsObject Network where
  tagsOf = networkTags

245
246
247
instance UuidObject Network where
  uuidOf = networkUuid

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

252
253
-- * NIC definitions

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

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

instance UuidObject PartialNic where
  uuidOf = nicUuid
270
271
272

-- * Disk definitions

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

277
278
279
-- | The disk parameters type.
type DiskParams = Container JSValue

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

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

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

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

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

415
$(buildObjectSerialisation "Disk" $
Iustin Pop's avatar
Iustin Pop committed
416
  [ customField 'decodeDLId 'encodeFullDLId ["dev_type"] $
417
      simpleField "logical_id"    [t| DiskLogicalId   |]
418
419
420
421
  , defaultField  [| [] |] $ simpleField "children" [t| [Disk] |]
  , defaultField [| "" |] $ simpleField "iv_name" [t| String |]
  , simpleField "size" [t| Int |]
  , defaultField [| DiskRdWr |] $ simpleField "mode" [t| DiskMode |]
422
  , optionalField $ simpleField "name" [t| String |]
423
  , optionalField $ simpleField "spindles" [t| Int |]
424
  ]
425
426
427
  ++ uuidFields
  ++ serialFields
  ++ timeStampFields)
428
429
430

instance UuidObject Disk where
  uuidOf = diskUuid
431

432
433
434
435
436
437
438
439
440
441
442
-- | 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

443
444
-- * Instance definitions

Iustin Pop's avatar
Iustin Pop committed
445
$(buildParam "Be" "bep"
446
447
448
449
  [ specialNumericalField 'parseUnitAssumeBinary
      $ simpleField "minmem"      [t| Int  |]
  , specialNumericalField 'parseUnitAssumeBinary
      $ simpleField "maxmem"      [t| Int  |]
Hrvoje Ribicic's avatar
Hrvoje Ribicic committed
450
451
452
453
  , simpleField "vcpus"           [t| Int  |]
  , simpleField "auto_balance"    [t| Bool |]
  , simpleField "always_failover" [t| Bool |]
  , simpleField "spindle_use"     [t| Int  |]
454
455
456
  ])

$(buildObject "Instance" "inst" $
457
458
459
460
461
462
463
464
465
466
  [ 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]       |]
467
  , simpleField "disks"            [t| [String]           |]
468
469
  , simpleField "disk_template"    [t| DiskTemplate       |]
  , simpleField "disks_active"     [t| Bool               |]
Iustin Pop's avatar
Iustin Pop committed
470
  , optionalField $ simpleField "network_port" [t| Int  |]
471
472
473
  ]
  ++ timeStampFields
  ++ uuidFields
474
475
  ++ serialFields
  ++ tagsFields)
476

477
478
479
480
481
482
483
484
485
486
487
488
489
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

490
491
-- * IPolicy definitions

Iustin Pop's avatar
Iustin Pop committed
492
$(buildParam "ISpec" "ispec"
493
494
495
496
497
498
  [ 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 |]
499
500
  ])

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

506
507
-- | 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
508
$(buildObject "PartialIPolicy" "ipolicy"
509
510
511
512
513
514
515
516
517
518
  [ 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] |]
519
520
521
522
  ])

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

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

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

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

597
598
-- * NodeGroup definitions

599
600
-- | The cluster/group disk parameters type.
type GroupDiskParams = Container DiskParams
Iustin Pop's avatar
Iustin Pop committed
601

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

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

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

-- | Cluster NicParams.
type ClusterNicParams = Container FilledNicParams

661
662
663
664
665
666
667
668
-- | 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
669
-- | Cluster UID Pool, list (low, high) UID ranges.
670
type UidPool = [UidRange]
Iustin Pop's avatar
Iustin Pop committed
671

672
673
674
-- | The iallocator parameters type.
type IAllocatorParams = Container JSValue

675
676
677
-- | The master candidate client certificate digests
type CandidateCertificates = Container String

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

732
733
734
735
736
737
738
739
740
741
742
743
744
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

745
746
747
748
-- * ConfigData definitions

$(buildObject "ConfigData" "config" $
--  timeStampFields ++
749
750
751
752
753
  [ simpleField "version"    [t| Int                 |]
  , simpleField "cluster"    [t| Cluster             |]
  , simpleField "nodes"      [t| Container Node      |]
  , simpleField "nodegroups" [t| Container NodeGroup |]
  , simpleField "instances"  [t| Container Instance  |]
754
  , simpleField "networks"   [t| Container Network   |]
755
  , simpleField "disks"      [t| Container Disk      |]
756
  ]
Petr Pudlak's avatar
Petr Pudlak committed
757
  ++ timeStampFields
758
  ++ serialFields)
759
760
761

instance SerialNoObject ConfigData where
  serialOf = configSerial
Petr Pudlak's avatar
Petr Pudlak committed
762
763
764
765

instance TimeStampObject ConfigData where
  cTimeOf = configCtime
  mTimeOf = configMtime