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