code.grnet.gr Git - ganeti-local/blob - src/Ganeti/Objects.hs

   1 {-# LANGUAGE TemplateHaskell #-}
   2
   3 {-| Implementation of the Ganeti config objects.
   4
   5 Some object fields are not implemented yet, and as such they are
   6 commented out below.
   7
   8 -}
   9
  10 {-
  11
  12 Copyright (C) 2011, 2012, 2013 Google Inc.
  13
  14 This program is free software; you can redistribute it and/or modify
  15 it under the terms of the GNU General Public License as published by
  16 the Free Software Foundation; either version 2 of the License, or
  17 (at your option) any later version.
  18
  19 This program is distributed in the hope that it will be useful, but
  20 WITHOUT ANY WARRANTY; without even the implied warranty of
  21 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22 General Public License for more details.
  23
  24 You should have received a copy of the GNU General Public License
  25 along with this program; if not, write to the Free Software
  26 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  27 02110-1301, USA.
  28
  29 -}
  30
  31 module Ganeti.Objects
  32   ( VType(..)
  33   , vTypeFromRaw
  34   , HvParams
  35   , OsParams
  36   , PartialNicParams(..)
  37   , FilledNicParams(..)
  38   , fillNicParams
  39   , allNicParamFields
  40   , PartialNic(..)
  41   , FileDriver(..)
  42   , BlockDriver(..)
  43   , DiskMode(..)
  44   , DiskType(..)
  45   , DiskLogicalId(..)
  46   , Disk(..)
  47   , includesLogicalId
  48   , DiskTemplate(..)
  49   , PartialBeParams(..)
  50   , FilledBeParams(..)
  51   , fillBeParams
  52   , allBeParamFields
  53   , AdminState(..)
  54   , adminStateFromRaw
  55   , Instance(..)
  56   , toDictInstance
  57   , PartialNDParams(..)
  58   , FilledNDParams(..)
  59   , fillNDParams
  60   , allNDParamFields
  61   , Node(..)
  62   , NodeRole(..)
  63   , nodeRoleToRaw
  64   , roleDescription
  65   , AllocPolicy(..)
  66   , FilledISpecParams(..)
  67   , PartialISpecParams(..)
  68   , fillISpecParams
  69   , allISpecParamFields
  70   , MinMaxISpecs(..)
  71   , FilledIPolicy(..)
  72   , PartialIPolicy(..)
  73   , fillIPolicy
  74   , DiskParams
  75   , NodeGroup(..)
  76   , IpFamily(..)
  77   , ipFamilyToVersion
  78   , fillDict
  79   , ClusterHvParams
  80   , OsHvParams
  81   , ClusterBeParams
  82   , ClusterOsParams
  83   , ClusterNicParams
  84   , Cluster(..)
  85   , ConfigData(..)
  86   , TimeStampObject(..)
  87   , UuidObject(..)
  88   , SerialNoObject(..)
  89   , TagsObject(..)
  90   , DictObject(..) -- re-exported from THH
  91   , TagSet -- re-exported from THH
  92   , Network(..)
  93   , Ip4Address(..)
  94   , Ip4Network(..)
  95   , readIp4Address
  96   , nextIp4Address
  97   ) where
  98
  99 import Control.Applicative
 100 import Data.List (foldl')
 101 import Data.Maybe
 102 import qualified Data.Map as Map
 103 import qualified Data.Set as Set
 104 import Data.Word
 105 import Text.JSON (showJSON, readJSON, JSON, JSValue(..), fromJSString)
 106 import qualified Text.JSON as J
 107
 108 import qualified Ganeti.Constants as C
 109 import Ganeti.JSON
 110 import Ganeti.Types
 111 import Ganeti.THH
 112 import Ganeti.Utils (sepSplit, tryRead)
 113
 114 -- * Generic definitions
 115
 116 -- | Fills one map with keys from the other map, if not already
 117 -- existing. Mirrors objects.py:FillDict.
 118 fillDict :: (Ord k) => Map.Map k v -> Map.Map k v -> [k] -> Map.Map k v
 119 fillDict defaults custom skip_keys =
 120   let updated = Map.union custom defaults
 121   in foldl' (flip Map.delete) updated skip_keys
 122
 123 -- | The VTYPES, a mini-type system in Python.
 124 $(declareSADT "VType"
 125   [ ("VTypeString",      'C.vtypeString)
 126   , ("VTypeMaybeString", 'C.vtypeMaybeString)
 127   , ("VTypeBool",        'C.vtypeBool)
 128   , ("VTypeSize",        'C.vtypeSize)
 129   , ("VTypeInt",         'C.vtypeInt)
 130   ])
 131 $(makeJSONInstance ''VType)
 132
 133 -- | The hypervisor parameter type. This is currently a simple map,
 134 -- without type checking on key/value pairs.
 135 type HvParams = Container JSValue
 136
 137 -- | The OS parameters type. This is, and will remain, a string
 138 -- container, since the keys are dynamically declared by the OSes, and
 139 -- the values are always strings.
 140 type OsParams = Container String
 141
 142 -- | Class of objects that have timestamps.
 143 class TimeStampObject a where
 144   cTimeOf :: a -> Double
 145   mTimeOf :: a -> Double
 146
 147 -- | Class of objects that have an UUID.
 148 class UuidObject a where
 149   uuidOf :: a -> String
 150
 151 -- | Class of object that have a serial number.
 152 class SerialNoObject a where
 153   serialOf :: a -> Int
 154
 155 -- | Class of objects that have tags.
 156 class TagsObject a where
 157   tagsOf :: a -> Set.Set String
 158
 159 -- * Node role object
 160
 161 $(declareSADT "NodeRole"
 162   [ ("NROffline",   'C.nrOffline)
 163   , ("NRDrained",   'C.nrDrained)
 164   , ("NRRegular",   'C.nrRegular)
 165   , ("NRCandidate", 'C.nrMcandidate)
 166   , ("NRMaster",    'C.nrMaster)
 167   ])
 168 $(makeJSONInstance ''NodeRole)
 169
 170 -- | The description of the node role.
 171 roleDescription :: NodeRole -> String
 172 roleDescription NROffline   = "offline"
 173 roleDescription NRDrained   = "drained"
 174 roleDescription NRRegular   = "regular"
 175 roleDescription NRCandidate = "master candidate"
 176 roleDescription NRMaster    = "master"
 177
 178 -- * Network definitions
 179
 180 -- ** Ipv4 types
 181
 182 -- | Custom type for a simple IPv4 address.
 183 data Ip4Address = Ip4Address Word8 Word8 Word8 Word8
 184                   deriving Eq
 185
 186 instance Show Ip4Address where
 187   show (Ip4Address a b c d) = show a ++ "." ++ show b ++ "." ++
 188                               show c ++ "." ++ show d
 189
 190 -- | Parses an IPv4 address from a string.
 191 readIp4Address :: (Applicative m, Monad m) => String -> m Ip4Address
 192 readIp4Address s =
 193   case sepSplit '.' s of
 194     [a, b, c, d] -> Ip4Address <$>
 195                       tryRead "first octect" a <*>
 196                       tryRead "second octet" b <*>
 197                       tryRead "third octet"  c <*>
 198                       tryRead "fourth octet" d
 199     _ -> fail $ "Can't parse IPv4 address from string " ++ s
 200
 201 -- | JSON instance for 'Ip4Address'.
 202 instance JSON Ip4Address where
 203   showJSON = showJSON . show
 204   readJSON (JSString s) = readIp4Address (fromJSString s)
 205   readJSON v = fail $ "Invalid JSON value " ++ show v ++ " for an IPv4 address"
 206
 207 -- | \"Next\" address implementation for IPv4 addresses.
 208 --
 209 -- Note that this loops! Note also that this is a very dumb
 210 -- implementation.
 211 nextIp4Address :: Ip4Address -> Ip4Address
 212 nextIp4Address (Ip4Address a b c d) =
 213   let inc xs y = if all (==0) xs then y + 1 else y
 214       d' = d + 1
 215       c' = inc [d'] c
 216       b' = inc [c', d'] b
 217       a' = inc [b', c', d'] a
 218   in Ip4Address a' b' c' d'
 219
 220 -- | Custom type for an IPv4 network.
 221 data Ip4Network = Ip4Network Ip4Address Word8
 222                   deriving Eq
 223
 224 instance Show Ip4Network where
 225   show (Ip4Network ip netmask) = show ip ++ "/" ++ show netmask
 226
 227 -- | JSON instance for 'Ip4Network'.
 228 instance JSON Ip4Network where
 229   showJSON = showJSON . show
 230   readJSON (JSString s) =
 231     case sepSplit '/' (fromJSString s) of
 232       [ip, nm] -> do
 233         ip' <- readIp4Address ip
 234         nm' <- tryRead "parsing netmask" nm
 235         if nm' >= 0 && nm' <= 32
 236           then return $ Ip4Network ip' nm'
 237           else fail $ "Invalid netmask " ++ show nm' ++ " from string " ++
 238                       fromJSString s
 239       _ -> fail $ "Can't parse IPv4 network from string " ++ fromJSString s
 240   readJSON v = fail $ "Invalid JSON value " ++ show v ++ " for an IPv4 network"
 241
 242 -- ** Ganeti \"network\" config object.
 243
 244 -- FIXME: Not all types might be correct here, since they
 245 -- haven't been exhaustively deduced from the python code yet.
 246 $(buildObject "Network" "network" $
 247   [ simpleField "name"             [t| NonEmptyString |]
 248   , optionalField $
 249     simpleField "mac_prefix"       [t| String |]
 250   , simpleField "network"          [t| Ip4Network |]
 251   , optionalField $
 252     simpleField "network6"         [t| String |]
 253   , optionalField $
 254     simpleField "gateway"          [t| Ip4Address |]
 255   , optionalField $
 256     simpleField "gateway6"         [t| String |]
 257   , optionalField $
 258     simpleField "reservations"     [t| String |]
 259   , optionalField $
 260     simpleField "ext_reservations" [t| String |]
 261   ]
 262   ++ uuidFields
 263   ++ timeStampFields
 264   ++ serialFields
 265   ++ tagsFields)
 266
 267 instance SerialNoObject Network where
 268   serialOf = networkSerial
 269
 270 instance TagsObject Network where
 271   tagsOf = networkTags
 272
 273 instance UuidObject Network where
 274   uuidOf = networkUuid
 275
 276 instance TimeStampObject Network where
 277   cTimeOf = networkCtime
 278   mTimeOf = networkMtime
 279
 280 -- * NIC definitions
 281
 282 $(buildParam "Nic" "nicp"
 283   [ simpleField "mode" [t| NICMode |]
 284   , simpleField "link" [t| String  |]
 285   ])
 286
 287 $(buildObject "PartialNic" "nic" $
 288   [ simpleField "mac" [t| String |]
 289   , optionalField $ simpleField "ip" [t| String |]
 290   , simpleField "nicparams" [t| PartialNicParams |]
 291   , optionalField $ simpleField "network" [t| String |]
 292   , optionalField $ simpleField "name" [t| String |]
 293   ] ++ uuidFields)
 294
 295 instance UuidObject PartialNic where
 296   uuidOf = nicUuid
 297
 298 -- * Disk definitions
 299
 300 $(declareSADT "DiskMode"
 301   [ ("DiskRdOnly", 'C.diskRdonly)
 302   , ("DiskRdWr",   'C.diskRdwr)
 303   ])
 304 $(makeJSONInstance ''DiskMode)
 305
 306 $(declareSADT "DiskType"
 307   [ ("LD_LV",       'C.ldLv)
 308   , ("LD_DRBD8",    'C.ldDrbd8)
 309   , ("LD_FILE",     'C.ldFile)
 310   , ("LD_BLOCKDEV", 'C.ldBlockdev)
 311   , ("LD_RADOS",    'C.ldRbd)
 312   , ("LD_EXT",      'C.ldExt)
 313   ])
 314 $(makeJSONInstance ''DiskType)
 315
 316 -- | The persistent block driver type. Currently only one type is allowed.
 317 $(declareSADT "BlockDriver"
 318   [ ("BlockDrvManual", 'C.blockdevDriverManual)
 319   ])
 320 $(makeJSONInstance ''BlockDriver)
 321
 322 -- | Constant for the dev_type key entry in the disk config.
 323 devType :: String
 324 devType = "dev_type"
 325
 326 -- | The disk configuration type. This includes the disk type itself,
 327 -- for a more complete consistency. Note that since in the Python
 328 -- code-base there's no authoritative place where we document the
 329 -- logical id, this is probably a good reference point.
 330 data DiskLogicalId
 331   = LIDPlain String String  -- ^ Volume group, logical volume
 332   | LIDDrbd8 String String Int Int Int String
 333   -- ^ NodeA, NodeB, Port, MinorA, MinorB, Secret
 334   | LIDFile FileDriver String -- ^ Driver, path
 335   | LIDBlockDev BlockDriver String -- ^ Driver, path (must be under /dev)
 336   | LIDRados String String -- ^ Unused, path
 337   | LIDExt String String -- ^ ExtProvider, unique name
 338     deriving (Show, Eq)
 339
 340 -- | Mapping from a logical id to a disk type.
 341 lidDiskType :: DiskLogicalId -> DiskType
 342 lidDiskType (LIDPlain {}) = LD_LV
 343 lidDiskType (LIDDrbd8 {}) = LD_DRBD8
 344 lidDiskType (LIDFile  {}) = LD_FILE
 345 lidDiskType (LIDBlockDev {}) = LD_BLOCKDEV
 346 lidDiskType (LIDRados {}) = LD_RADOS
 347 lidDiskType (LIDExt {}) = LD_EXT
 348
 349 -- | Builds the extra disk_type field for a given logical id.
 350 lidEncodeType :: DiskLogicalId -> [(String, JSValue)]
 351 lidEncodeType v = [(devType, showJSON . lidDiskType $ v)]
 352
 353 -- | Custom encoder for DiskLogicalId (logical id only).
 354 encodeDLId :: DiskLogicalId -> JSValue
 355 encodeDLId (LIDPlain vg lv) = JSArray [showJSON vg, showJSON lv]
 356 encodeDLId (LIDDrbd8 nodeA nodeB port minorA minorB key) =
 357   JSArray [ showJSON nodeA, showJSON nodeB, showJSON port
 358           , showJSON minorA, showJSON minorB, showJSON key ]
 359 encodeDLId (LIDRados pool name) = JSArray [showJSON pool, showJSON name]
 360 encodeDLId (LIDFile driver name) = JSArray [showJSON driver, showJSON name]
 361 encodeDLId (LIDBlockDev driver name) = JSArray [showJSON driver, showJSON name]
 362 encodeDLId (LIDExt extprovider name) =
 363   JSArray [showJSON extprovider, showJSON name]
 364
 365 -- | Custom encoder for DiskLogicalId, composing both the logical id
 366 -- and the extra disk_type field.
 367 encodeFullDLId :: DiskLogicalId -> (JSValue, [(String, JSValue)])
 368 encodeFullDLId v = (encodeDLId v, lidEncodeType v)
 369
 370 -- | Custom decoder for DiskLogicalId. This is manual for now, since
 371 -- we don't have yet automation for separate-key style fields.
 372 decodeDLId :: [(String, JSValue)] -> JSValue -> J.Result DiskLogicalId
 373 decodeDLId obj lid = do
 374   dtype <- fromObj obj devType
 375   case dtype of
 376     LD_DRBD8 ->
 377       case lid of
 378         JSArray [nA, nB, p, mA, mB, k] -> do
 379           nA' <- readJSON nA
 380           nB' <- readJSON nB
 381           p'  <- readJSON p
 382           mA' <- readJSON mA
 383           mB' <- readJSON mB
 384           k'  <- readJSON k
 385           return $ LIDDrbd8 nA' nB' p' mA' mB' k'
 386         _ -> fail "Can't read logical_id for DRBD8 type"
 387     LD_LV ->
 388       case lid of
 389         JSArray [vg, lv] -> do
 390           vg' <- readJSON vg
 391           lv' <- readJSON lv
 392           return $ LIDPlain vg' lv'
 393         _ -> fail "Can't read logical_id for plain type"
 394     LD_FILE ->
 395       case lid of
 396         JSArray [driver, path] -> do
 397           driver' <- readJSON driver
 398           path'   <- readJSON path
 399           return $ LIDFile driver' path'
 400         _ -> fail "Can't read logical_id for file type"
 401     LD_BLOCKDEV ->
 402       case lid of
 403         JSArray [driver, path] -> do
 404           driver' <- readJSON driver
 405           path'   <- readJSON path
 406           return $ LIDBlockDev driver' path'
 407         _ -> fail "Can't read logical_id for blockdev type"
 408     LD_RADOS ->
 409       case lid of
 410         JSArray [driver, path] -> do
 411           driver' <- readJSON driver
 412           path'   <- readJSON path
 413           return $ LIDRados driver' path'
 414         _ -> fail "Can't read logical_id for rdb type"
 415     LD_EXT ->
 416       case lid of
 417         JSArray [extprovider, name] -> do
 418           extprovider' <- readJSON extprovider
 419           name'   <- readJSON name
 420           return $ LIDExt extprovider' name'
 421         _ -> fail "Can't read logical_id for extstorage type"
 422
 423 -- | Disk data structure.
 424 --
 425 -- This is declared manually as it's a recursive structure, and our TH
 426 -- code currently can't build it.
 427 data Disk = Disk
 428   { diskLogicalId  :: DiskLogicalId
 429 --  , diskPhysicalId :: String
 430   , diskChildren   :: [Disk]
 431   , diskIvName     :: String
 432   , diskSize       :: Int
 433   , diskMode       :: DiskMode
 434   , diskName       :: Maybe String
 435   , diskSpindles   :: Maybe Int
 436   , diskUuid       :: String
 437   } deriving (Show, Eq)
 438
 439 $(buildObjectSerialisation "Disk" $
 440   [ customField 'decodeDLId 'encodeFullDLId ["dev_type"] $
 441       simpleField "logical_id"    [t| DiskLogicalId   |]
 442 --  , simpleField "physical_id" [t| String   |]
 443   , defaultField  [| [] |] $ simpleField "children" [t| [Disk] |]
 444   , defaultField [| "" |] $ simpleField "iv_name" [t| String |]
 445   , simpleField "size" [t| Int |]
 446   , defaultField [| DiskRdWr |] $ simpleField "mode" [t| DiskMode |]
 447   , optionalField $ simpleField "name" [t| String |]
 448   , optionalField $ simpleField "spindles" [t| Int |]
 449   ]
 450   ++ uuidFields)
 451
 452 instance UuidObject Disk where
 453   uuidOf = diskUuid
 454
 455 -- | Determines whether a disk or one of his children has the given logical id
 456 -- (determined by the volume group name and by the logical volume name).
 457 -- This can be true only for DRBD or LVM disks.
 458 includesLogicalId :: String -> String -> Disk -> Bool
 459 includesLogicalId vg_name lv_name disk =
 460   case diskLogicalId disk of
 461     LIDPlain vg lv -> vg_name == vg && lv_name == lv
 462     LIDDrbd8 {} ->
 463       any (includesLogicalId vg_name lv_name) $ diskChildren disk
 464     _ -> False
 465
 466
 467 -- * Instance definitions
 468
 469 $(declareSADT "AdminState"
 470   [ ("AdminOffline", 'C.adminstOffline)
 471   , ("AdminDown",    'C.adminstDown)
 472   , ("AdminUp",      'C.adminstUp)
 473   ])
 474 $(makeJSONInstance ''AdminState)
 475
 476 $(buildParam "Be" "bep"
 477   [ simpleField "minmem"       [t| Int  |]
 478   , simpleField "maxmem"       [t| Int  |]
 479   , simpleField "vcpus"        [t| Int  |]
 480   , simpleField "auto_balance" [t| Bool |]
 481   ])
 482
 483 $(buildObject "Instance" "inst" $
 484   [ simpleField "name"           [t| String             |]
 485   , simpleField "primary_node"   [t| String             |]
 486   , simpleField "os"             [t| String             |]
 487   , simpleField "hypervisor"     [t| Hypervisor         |]
 488   , simpleField "hvparams"       [t| HvParams           |]
 489   , simpleField "beparams"       [t| PartialBeParams    |]
 490   , simpleField "osparams"       [t| OsParams           |]
 491   , simpleField "admin_state"    [t| AdminState         |]
 492   , simpleField "nics"           [t| [PartialNic]       |]
 493   , simpleField "disks"          [t| [Disk]             |]
 494   , simpleField "disk_template"  [t| DiskTemplate       |]
 495   , simpleField "disks_active"   [t| Bool               |]
 496   , optionalField $ simpleField "network_port" [t| Int  |]
 497   ]
 498   ++ timeStampFields
 499   ++ uuidFields
 500   ++ serialFields
 501   ++ tagsFields)
 502
 503 instance TimeStampObject Instance where
 504   cTimeOf = instCtime
 505   mTimeOf = instMtime
 506
 507 instance UuidObject Instance where
 508   uuidOf = instUuid
 509
 510 instance SerialNoObject Instance where
 511   serialOf = instSerial
 512
 513 instance TagsObject Instance where
 514   tagsOf = instTags
 515
 516 -- * IPolicy definitions
 517
 518 $(buildParam "ISpec" "ispec"
 519   [ simpleField C.ispecMemSize     [t| Int |]
 520   , simpleField C.ispecDiskSize    [t| Int |]
 521   , simpleField C.ispecDiskCount   [t| Int |]
 522   , simpleField C.ispecCpuCount    [t| Int |]
 523   , simpleField C.ispecNicCount    [t| Int |]
 524   , simpleField C.ispecSpindleUse  [t| Int |]
 525   ])
 526
 527 $(buildObject "MinMaxISpecs" "mmis"
 528   [ renameField "MinSpec" $ simpleField "min" [t| FilledISpecParams |]
 529   , renameField "MaxSpec" $ simpleField "max" [t| FilledISpecParams |]
 530   ])
 531
 532 -- | Custom partial ipolicy. This is not built via buildParam since it
 533 -- has a special 2-level inheritance mode.
 534 $(buildObject "PartialIPolicy" "ipolicy"
 535   [ optionalField . renameField "MinMaxISpecsP"
 536                     $ simpleField C.ispecsMinmax   [t| [MinMaxISpecs] |]
 537   , optionalField . renameField "StdSpecP"
 538                     $ simpleField "std"            [t| PartialISpecParams |]
 539   , optionalField . renameField "SpindleRatioP"
 540                     $ simpleField "spindle-ratio"  [t| Double |]
 541   , optionalField . renameField "VcpuRatioP"
 542                     $ simpleField "vcpu-ratio"     [t| Double |]
 543   , optionalField . renameField "DiskTemplatesP"
 544                     $ simpleField "disk-templates" [t| [DiskTemplate] |]
 545   ])
 546
 547 -- | Custom filled ipolicy. This is not built via buildParam since it
 548 -- has a special 2-level inheritance mode.
 549 $(buildObject "FilledIPolicy" "ipolicy"
 550   [ renameField "MinMaxISpecs"
 551     $ simpleField C.ispecsMinmax [t| [MinMaxISpecs] |]
 552   , renameField "StdSpec" $ simpleField "std" [t| FilledISpecParams |]
 553   , simpleField "spindle-ratio"  [t| Double |]
 554   , simpleField "vcpu-ratio"     [t| Double |]
 555   , simpleField "disk-templates" [t| [DiskTemplate] |]
 556   ])
 557
 558 -- | Custom filler for the ipolicy types.
 559 fillIPolicy :: FilledIPolicy -> PartialIPolicy -> FilledIPolicy
 560 fillIPolicy (FilledIPolicy { ipolicyMinMaxISpecs  = fminmax
 561                            , ipolicyStdSpec       = fstd
 562                            , ipolicySpindleRatio  = fspindleRatio
 563                            , ipolicyVcpuRatio     = fvcpuRatio
 564                            , ipolicyDiskTemplates = fdiskTemplates})
 565             (PartialIPolicy { ipolicyMinMaxISpecsP  = pminmax
 566                             , ipolicyStdSpecP       = pstd
 567                             , ipolicySpindleRatioP  = pspindleRatio
 568                             , ipolicyVcpuRatioP     = pvcpuRatio
 569                             , ipolicyDiskTemplatesP = pdiskTemplates}) =
 570   FilledIPolicy { ipolicyMinMaxISpecs  = fromMaybe fminmax pminmax
 571                 , ipolicyStdSpec       = case pstd of
 572                                          Nothing -> fstd
 573                                          Just p -> fillISpecParams fstd p
 574                 , ipolicySpindleRatio  = fromMaybe fspindleRatio pspindleRatio
 575                 , ipolicyVcpuRatio     = fromMaybe fvcpuRatio pvcpuRatio
 576                 , ipolicyDiskTemplates = fromMaybe fdiskTemplates
 577                                          pdiskTemplates
 578                 }
 579 -- * Node definitions
 580
 581 $(buildParam "ND" "ndp"
 582   [ simpleField "oob_program"   [t| String |]
 583   , simpleField "spindle_count" [t| Int    |]
 584   , simpleField "exclusive_storage" [t| Bool |]
 585   ])
 586
 587 $(buildObject "Node" "node" $
 588   [ simpleField "name"             [t| String |]
 589   , simpleField "primary_ip"       [t| String |]
 590   , simpleField "secondary_ip"     [t| String |]
 591   , simpleField "master_candidate" [t| Bool   |]
 592   , simpleField "offline"          [t| Bool   |]
 593   , simpleField "drained"          [t| Bool   |]
 594   , simpleField "group"            [t| String |]
 595   , simpleField "master_capable"   [t| Bool   |]
 596   , simpleField "vm_capable"       [t| Bool   |]
 597   , simpleField "ndparams"         [t| PartialNDParams |]
 598   , simpleField "powered"          [t| Bool   |]
 599   ]
 600   ++ timeStampFields
 601   ++ uuidFields
 602   ++ serialFields
 603   ++ tagsFields)
 604
 605 instance TimeStampObject Node where
 606   cTimeOf = nodeCtime
 607   mTimeOf = nodeMtime
 608
 609 instance UuidObject Node where
 610   uuidOf = nodeUuid
 611
 612 instance SerialNoObject Node where
 613   serialOf = nodeSerial
 614
 615 instance TagsObject Node where
 616   tagsOf = nodeTags
 617
 618 -- * NodeGroup definitions
 619
 620 -- | The disk parameters type.
 621 type DiskParams = Container (Container JSValue)
 622
 623 -- | A mapping from network UUIDs to nic params of the networks.
 624 type Networks = Container PartialNicParams
 625
 626 $(buildObject "NodeGroup" "group" $
 627   [ simpleField "name"         [t| String |]
 628   , defaultField [| [] |] $ simpleField "members" [t| [String] |]
 629   , simpleField "ndparams"     [t| PartialNDParams |]
 630   , simpleField "alloc_policy" [t| AllocPolicy     |]
 631   , simpleField "ipolicy"      [t| PartialIPolicy  |]
 632   , simpleField "diskparams"   [t| DiskParams      |]
 633   , simpleField "networks"     [t| Networks        |]
 634   ]
 635   ++ timeStampFields
 636   ++ uuidFields
 637   ++ serialFields
 638   ++ tagsFields)
 639
 640 instance TimeStampObject NodeGroup where
 641   cTimeOf = groupCtime
 642   mTimeOf = groupMtime
 643
 644 instance UuidObject NodeGroup where
 645   uuidOf = groupUuid
 646
 647 instance SerialNoObject NodeGroup where
 648   serialOf = groupSerial
 649
 650 instance TagsObject NodeGroup where
 651   tagsOf = groupTags
 652
 653 -- | IP family type
 654 $(declareIADT "IpFamily"
 655   [ ("IpFamilyV4", 'C.ip4Family)
 656   , ("IpFamilyV6", 'C.ip6Family)
 657   ])
 658 $(makeJSONInstance ''IpFamily)
 659
 660 -- | Conversion from IP family to IP version. This is needed because
 661 -- Python uses both, depending on context.
 662 ipFamilyToVersion :: IpFamily -> Int
 663 ipFamilyToVersion IpFamilyV4 = C.ip4Version
 664 ipFamilyToVersion IpFamilyV6 = C.ip6Version
 665
 666 -- | Cluster HvParams (hvtype to hvparams mapping).
 667 type ClusterHvParams = Container HvParams
 668
 669 -- | Cluster Os-HvParams (os to hvparams mapping).
 670 type OsHvParams = Container ClusterHvParams
 671
 672 -- | Cluser BeParams.
 673 type ClusterBeParams = Container FilledBeParams
 674
 675 -- | Cluster OsParams.
 676 type ClusterOsParams = Container OsParams
 677
 678 -- | Cluster NicParams.
 679 type ClusterNicParams = Container FilledNicParams
 680
 681 -- | Cluster UID Pool, list (low, high) UID ranges.
 682 type UidPool = [(Int, Int)]
 683
 684 -- * Cluster definitions
 685 $(buildObject "Cluster" "cluster" $
 686   [ simpleField "rsahostkeypub"           [t| String           |]
 687   , simpleField "dsahostkeypub"           [t| String           |]
 688   , simpleField "highest_used_port"       [t| Int              |]
 689   , simpleField "tcpudp_port_pool"        [t| [Int]            |]
 690   , simpleField "mac_prefix"              [t| String           |]
 691   , optionalField $
 692     simpleField "volume_group_name"       [t| String           |]
 693   , simpleField "reserved_lvs"            [t| [String]         |]
 694   , optionalField $
 695     simpleField "drbd_usermode_helper"    [t| String           |]
 696   , simpleField "master_node"             [t| String           |]
 697   , simpleField "master_ip"               [t| String           |]
 698   , simpleField "master_netdev"           [t| String           |]
 699   , simpleField "master_netmask"          [t| Int              |]
 700   , simpleField "use_external_mip_script" [t| Bool             |]
 701   , simpleField "cluster_name"            [t| String           |]
 702   , simpleField "file_storage_dir"        [t| String           |]
 703   , simpleField "shared_file_storage_dir" [t| String           |]
 704   , simpleField "enabled_hypervisors"     [t| [Hypervisor]     |]
 705   , simpleField "hvparams"                [t| ClusterHvParams  |]
 706   , simpleField "os_hvp"                  [t| OsHvParams       |]
 707   , simpleField "beparams"                [t| ClusterBeParams  |]
 708   , simpleField "osparams"                [t| ClusterOsParams  |]
 709   , simpleField "nicparams"               [t| ClusterNicParams |]
 710   , simpleField "ndparams"                [t| FilledNDParams   |]
 711   , simpleField "diskparams"              [t| DiskParams       |]
 712   , simpleField "candidate_pool_size"     [t| Int              |]
 713   , simpleField "modify_etc_hosts"        [t| Bool             |]
 714   , simpleField "modify_ssh_setup"        [t| Bool             |]
 715   , simpleField "maintain_node_health"    [t| Bool             |]
 716   , simpleField "uid_pool"                [t| UidPool          |]
 717   , simpleField "default_iallocator"      [t| String           |]
 718   , simpleField "hidden_os"               [t| [String]         |]
 719   , simpleField "blacklisted_os"          [t| [String]         |]
 720   , simpleField "primary_ip_family"       [t| IpFamily         |]
 721   , simpleField "prealloc_wipe_disks"     [t| Bool             |]
 722   , simpleField "ipolicy"                 [t| FilledIPolicy    |]
 723   , simpleField "enabled_disk_templates"  [t| [DiskTemplate]   |]
 724  ]
 725  ++ timeStampFields
 726  ++ uuidFields
 727  ++ serialFields
 728  ++ tagsFields)
 729
 730 instance TimeStampObject Cluster where
 731   cTimeOf = clusterCtime
 732   mTimeOf = clusterMtime
 733
 734 instance UuidObject Cluster where
 735   uuidOf = clusterUuid
 736
 737 instance SerialNoObject Cluster where
 738   serialOf = clusterSerial
 739
 740 instance TagsObject Cluster where
 741   tagsOf = clusterTags
 742
 743 -- * ConfigData definitions
 744
 745 $(buildObject "ConfigData" "config" $
 746 --  timeStampFields ++
 747   [ simpleField "version"    [t| Int                 |]
 748   , simpleField "cluster"    [t| Cluster             |]
 749   , simpleField "nodes"      [t| Container Node      |]
 750   , simpleField "nodegroups" [t| Container NodeGroup |]
 751   , simpleField "instances"  [t| Container Instance  |]
 752   , simpleField "networks"   [t| Container Network   |]
 753   ]
 754   ++ serialFields)
 755
 756 instance SerialNoObject ConfigData where
 757   serialOf = configSerial