code.grnet.gr Git - ganeti-local/blob - htools/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 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   ( NICMode(..)
  33   , PartialNICParams(..)
  34   , FilledNICParams(..)
  35   , fillNICParams
  36   , PartialNIC(..)
  37   , DiskMode(..)
  38   , DiskType(..)
  39   , DiskLogicalId(..)
  40   , Disk(..)
  41   , DiskTemplate(..)
  42   , PartialBEParams(..)
  43   , FilledBEParams(..)
  44   , fillBEParams
  45   , Hypervisor(..)
  46   , AdminState(..)
  47   , adminStateFromRaw
  48   , Instance(..)
  49   , toDictInstance
  50   , PartialNDParams(..)
  51   , FilledNDParams(..)
  52   , fillNDParams
  53   , Node(..)
  54   , AllocPolicy(..)
  55   , FilledISpecParams(..)
  56   , PartialISpecParams(..)
  57   , fillISpecParams
  58   , FilledIPolicy(..)
  59   , PartialIPolicy(..)
  60   , fillIPolicy
  61   , NodeGroup(..)
  62   , IpFamily(..)
  63   , ipFamilyToVersion
  64   , Cluster(..)
  65   , ConfigData(..)
  66   ) where
  67
  68 import Data.Maybe
  69 import Text.JSON (makeObj, showJSON, readJSON, JSON, JSValue(..))
  70 import qualified Text.JSON as J
  71
  72 import qualified Ganeti.Constants as C
  73 import Ganeti.HTools.JSON
  74
  75 import Ganeti.THH
  76
  77 -- * NIC definitions
  78
  79 $(declareSADT "NICMode"
  80   [ ("NMBridged", 'C.nicModeBridged)
  81   , ("NMRouted",  'C.nicModeRouted)
  82   ])
  83 $(makeJSONInstance ''NICMode)
  84
  85 $(buildParam "NIC" "nicp"
  86   [ simpleField "mode" [t| NICMode |]
  87   , simpleField "link" [t| String  |]
  88   ])
  89
  90 $(buildObject "PartialNIC" "nic"
  91   [ simpleField "mac" [t| String |]
  92   , optionalField $ simpleField "ip" [t| String |]
  93   , simpleField "nicparams" [t| PartialNICParams |]
  94   ])
  95
  96 -- * Disk definitions
  97
  98 $(declareSADT "DiskMode"
  99   [ ("DiskRdOnly", 'C.diskRdonly)
 100   , ("DiskRdWr",   'C.diskRdwr)
 101   ])
 102 $(makeJSONInstance ''DiskMode)
 103
 104 $(declareSADT "DiskType"
 105   [ ("LD_LV",       'C.ldLv)
 106   , ("LD_DRBD8",    'C.ldDrbd8)
 107   , ("LD_FILE",     'C.ldFile)
 108   , ("LD_BLOCKDEV", 'C.ldBlockdev)
 109   , ("LD_RADOS",    'C.ldRbd)
 110   ])
 111 $(makeJSONInstance ''DiskType)
 112
 113 -- | The file driver type.
 114 $(declareSADT "FileDriver"
 115   [ ("FileLoop",   'C.fdLoop)
 116   , ("FileBlktap", 'C.fdBlktap)
 117   ])
 118 $(makeJSONInstance ''FileDriver)
 119
 120 -- | The persistent block driver type. Currently only one type is allowed.
 121 $(declareSADT "BlockDriver"
 122   [ ("BlockDrvManual", 'C.blockdevDriverManual)
 123   ])
 124 $(makeJSONInstance ''BlockDriver)
 125
 126 -- | Constant for the dev_type key entry in the disk config.
 127 devType :: String
 128 devType = "dev_type"
 129
 130 -- | The disk configuration type. This includes the disk type itself,
 131 -- for a more complete consistency. Note that since in the Python
 132 -- code-base there's no authoritative place where we document the
 133 -- logical id, this is probably a good reference point.
 134 data DiskLogicalId
 135   = LIDPlain String String  -- ^ Volume group, logical volume
 136   | LIDDrbd8 String String Int Int Int String
 137   -- ^ NodeA, NodeB, Port, MinorA, MinorB, Secret
 138   | LIDFile FileDriver String -- ^ Driver, path
 139   | LIDBlockDev BlockDriver String -- ^ Driver, path (must be under /dev)
 140   | LIDRados String String -- ^ Unused, path
 141     deriving (Read, Show, Eq)
 142
 143 -- | Mapping from a logical id to a disk type.
 144 lidDiskType :: DiskLogicalId -> DiskType
 145 lidDiskType (LIDPlain {}) = LD_LV
 146 lidDiskType (LIDDrbd8 {}) = LD_DRBD8
 147 lidDiskType (LIDFile  {}) = LD_FILE
 148 lidDiskType (LIDBlockDev {}) = LD_BLOCKDEV
 149 lidDiskType (LIDRados {}) = LD_RADOS
 150
 151 -- | Builds the extra disk_type field for a given logical id.
 152 lidEncodeType :: DiskLogicalId -> [(String, JSValue)]
 153 lidEncodeType v = [(devType, showJSON . lidDiskType $ v)]
 154
 155 -- | Custom encoder for DiskLogicalId (logical id only).
 156 encodeDLId :: DiskLogicalId -> JSValue
 157 encodeDLId (LIDPlain vg lv) = JSArray [showJSON vg, showJSON lv]
 158 encodeDLId (LIDDrbd8 nodeA nodeB port minorA minorB key) =
 159   JSArray [ showJSON nodeA, showJSON nodeB, showJSON port
 160           , showJSON minorA, showJSON minorB, showJSON key ]
 161 encodeDLId (LIDRados pool name) = JSArray [showJSON pool, showJSON name]
 162 encodeDLId (LIDFile driver name) = JSArray [showJSON driver, showJSON name]
 163 encodeDLId (LIDBlockDev driver name) = JSArray [showJSON driver, showJSON name]
 164
 165 -- | Custom encoder for DiskLogicalId, composing both the logical id
 166 -- and the extra disk_type field.
 167 encodeFullDLId :: DiskLogicalId -> (JSValue, [(String, JSValue)])
 168 encodeFullDLId v = (encodeDLId v, lidEncodeType v)
 169
 170 -- | Custom decoder for DiskLogicalId. This is manual for now, since
 171 -- we don't have yet automation for separate-key style fields.
 172 decodeDLId :: [(String, JSValue)] -> JSValue -> J.Result DiskLogicalId
 173 decodeDLId obj lid = do
 174   dtype <- fromObj obj devType
 175   case dtype of
 176     LD_DRBD8 ->
 177       case lid of
 178         JSArray [nA, nB, p, mA, mB, k] -> do
 179           nA' <- readJSON nA
 180           nB' <- readJSON nB
 181           p'  <- readJSON p
 182           mA' <- readJSON mA
 183           mB' <- readJSON mB
 184           k'  <- readJSON k
 185           return $ LIDDrbd8 nA' nB' p' mA' mB' k'
 186         _ -> fail $ "Can't read logical_id for DRBD8 type"
 187     LD_LV ->
 188       case lid of
 189         JSArray [vg, lv] -> do
 190           vg' <- readJSON vg
 191           lv' <- readJSON lv
 192           return $ LIDPlain vg' lv'
 193         _ -> fail $ "Can't read logical_id for plain type"
 194     LD_FILE ->
 195       case lid of
 196         JSArray [driver, path] -> do
 197           driver' <- readJSON driver
 198           path'   <- readJSON path
 199           return $ LIDFile driver' path'
 200         _ -> fail $ "Can't read logical_id for file type"
 201     LD_BLOCKDEV ->
 202       case lid of
 203         JSArray [driver, path] -> do
 204           driver' <- readJSON driver
 205           path'   <- readJSON path
 206           return $ LIDBlockDev driver' path'
 207         _ -> fail $ "Can't read logical_id for blockdev type"
 208     LD_RADOS ->
 209       case lid of
 210         JSArray [driver, path] -> do
 211           driver' <- readJSON driver
 212           path'   <- readJSON path
 213           return $ LIDRados driver' path'
 214         _ -> fail $ "Can't read logical_id for rdb type"
 215
 216 -- | Disk data structure.
 217 --
 218 -- This is declared manually as it's a recursive structure, and our TH
 219 -- code currently can't build it.
 220 data Disk = Disk
 221   { diskLogicalId  :: DiskLogicalId
 222 --  , diskPhysicalId :: String
 223   , diskChildren   :: [Disk]
 224   , diskIvName     :: String
 225   , diskSize       :: Int
 226   , diskMode       :: DiskMode
 227   } deriving (Read, Show, Eq)
 228
 229 $(buildObjectSerialisation "Disk"
 230   [ customField 'decodeDLId 'encodeFullDLId $
 231       simpleField "logical_id"    [t| DiskLogicalId   |]
 232 --  , simpleField "physical_id" [t| String   |]
 233   , defaultField  [| [] |] $ simpleField "children" [t| [Disk] |]
 234   , defaultField [| "" |] $ simpleField "iv_name" [t| String |]
 235   , simpleField "size" [t| Int |]
 236   , defaultField [| DiskRdWr |] $ simpleField "mode" [t| DiskMode |]
 237   ])
 238
 239 -- * Hypervisor definitions
 240
 241 -- | This may be due to change when we add hypervisor parameters.
 242 $(declareSADT "Hypervisor"
 243   [ ( "Kvm",    'C.htKvm )
 244   , ( "XenPvm", 'C.htXenPvm )
 245   , ( "Chroot", 'C.htChroot )
 246   , ( "XenHvm", 'C.htXenHvm )
 247   , ( "Lxc",    'C.htLxc )
 248   , ( "Fake",   'C.htFake )
 249   ])
 250 $(makeJSONInstance ''Hypervisor)
 251
 252 -- * Instance definitions
 253
 254 -- | Instance disk template type. **Copied from HTools/Types.hs**
 255 $(declareSADT "DiskTemplate"
 256   [ ("DTDiskless",   'C.dtDiskless)
 257   , ("DTFile",       'C.dtFile)
 258   , ("DTSharedFile", 'C.dtSharedFile)
 259   , ("DTPlain",      'C.dtPlain)
 260   , ("DTBlock",      'C.dtBlock)
 261   , ("DTDrbd8",      'C.dtDrbd8)
 262   , ("DTRados",      'C.dtRbd)
 263   ])
 264 $(makeJSONInstance ''DiskTemplate)
 265
 266 $(declareSADT "AdminState"
 267   [ ("AdminOffline", 'C.adminstOffline)
 268   , ("AdminDown",    'C.adminstDown)
 269   , ("AdminUp",      'C.adminstUp)
 270   ])
 271 $(makeJSONInstance ''AdminState)
 272
 273 $(buildParam "BE" "bep" $
 274   [ simpleField "minmem"       [t| Int  |]
 275   , simpleField "maxmem"       [t| Int  |]
 276   , simpleField "vcpus"        [t| Int  |]
 277   , simpleField "auto_balance" [t| Bool |]
 278   ])
 279
 280 $(buildObject "Instance" "inst" $
 281   [ simpleField "name"           [t| String             |]
 282   , simpleField "primary_node"   [t| String             |]
 283   , simpleField "os"             [t| String             |]
 284   , simpleField "hypervisor"     [t| String             |]
 285 --  , simpleField "hvparams"     [t| [(String, String)] |]
 286   , simpleField "beparams"       [t| PartialBEParams |]
 287 --  , simpleField "osparams"     [t| [(String, String)] |]
 288   , simpleField "admin_state"    [t| AdminState         |]
 289   , simpleField "nics"           [t| [PartialNIC]              |]
 290   , simpleField "disks"          [t| [Disk]             |]
 291   , simpleField "disk_template"  [t| DiskTemplate       |]
 292   , optionalField $ simpleField "network_port" [t| Int |]
 293   ]
 294   ++ timeStampFields
 295   ++ uuidFields
 296   ++ serialFields
 297   ++ tagsFields)
 298
 299 -- * IPolicy definitions
 300
 301 $(buildParam "ISpec" "ispec" $
 302   [ simpleField C.ispecMemSize     [t| Int |]
 303   , simpleField C.ispecDiskSize    [t| Int |]
 304   , simpleField C.ispecDiskCount   [t| Int |]
 305   , simpleField C.ispecCpuCount    [t| Int |]
 306   , simpleField C.ispecSpindleUse  [t| Int |]
 307   ])
 308
 309 -- | Custom partial ipolicy. This is not built via buildParam since it
 310 -- has a special 2-level inheritance mode.
 311 $(buildObject "PartialIPolicy" "ipolicy" $
 312   [ renameField "MinSpecP" $ simpleField "min" [t| PartialISpecParams |]
 313   , renameField "MaxSpecP" $ simpleField "max" [t| PartialISpecParams |]
 314   , renameField "StdSpecP" $ simpleField "std" [t| PartialISpecParams |]
 315   , optionalField . renameField "SpindleRatioP"
 316                     $ simpleField "spindle-ratio"  [t| Double |]
 317   , optionalField . renameField "VcpuRatioP"
 318                     $ simpleField "vcpu-ratio"     [t| Double |]
 319   , optionalField . renameField "DiskTemplatesP"
 320                     $ simpleField "disk-templates" [t| [DiskTemplate] |]
 321   ])
 322
 323 -- | Custom filled ipolicy. This is not built via buildParam since it
 324 -- has a special 2-level inheritance mode.
 325 $(buildObject "FilledIPolicy" "ipolicy" $
 326   [ renameField "MinSpec" $ simpleField "min" [t| FilledISpecParams |]
 327   , renameField "MaxSpec" $ simpleField "max" [t| FilledISpecParams |]
 328   , renameField "StdSpec" $ simpleField "std" [t| FilledISpecParams |]
 329   , simpleField "spindle-ratio"  [t| Double |]
 330   , simpleField "vcpu-ratio"     [t| Double |]
 331   , simpleField "disk-templates" [t| [DiskTemplate] |]
 332   ])
 333
 334 -- | Custom filler for the ipolicy types.
 335 fillIPolicy :: FilledIPolicy -> PartialIPolicy -> FilledIPolicy
 336 fillIPolicy (FilledIPolicy { ipolicyMinSpec       = fmin
 337                            , ipolicyMaxSpec       = fmax
 338                            , ipolicyStdSpec       = fstd
 339                            , ipolicySpindleRatio  = fspindleRatio
 340                            , ipolicyVcpuRatio     = fvcpuRatio
 341                            , ipolicyDiskTemplates = fdiskTemplates})
 342             (PartialIPolicy { ipolicyMinSpecP       = pmin
 343                             , ipolicyMaxSpecP       = pmax
 344                             , ipolicyStdSpecP       = pstd
 345                             , ipolicySpindleRatioP  = pspindleRatio
 346                             , ipolicyVcpuRatioP     = pvcpuRatio
 347                             , ipolicyDiskTemplatesP = pdiskTemplates}) =
 348   FilledIPolicy { ipolicyMinSpec       = fillISpecParams fmin pmin
 349                 , ipolicyMaxSpec       = fillISpecParams fmax pmax
 350                 , ipolicyStdSpec       = fillISpecParams fstd pstd
 351                 , ipolicySpindleRatio  = fromMaybe fspindleRatio pspindleRatio
 352                 , ipolicyVcpuRatio     = fromMaybe fvcpuRatio pvcpuRatio
 353                 , ipolicyDiskTemplates = fromMaybe fdiskTemplates
 354                                          pdiskTemplates
 355                 }
 356 -- * Node definitions
 357
 358 $(buildParam "ND" "ndp" $
 359   [ simpleField "oob_program"   [t| String |]
 360   , simpleField "spindle_count" [t| Int    |]
 361   ])
 362
 363 $(buildObject "Node" "node" $
 364   [ simpleField "name"             [t| String |]
 365   , simpleField "primary_ip"       [t| String |]
 366   , simpleField "secondary_ip"     [t| String |]
 367   , simpleField "master_candidate" [t| Bool   |]
 368   , simpleField "offline"          [t| Bool   |]
 369   , simpleField "drained"          [t| Bool   |]
 370   , simpleField "group"            [t| String |]
 371   , simpleField "master_capable"   [t| Bool   |]
 372   , simpleField "vm_capable"       [t| Bool   |]
 373   , simpleField "ndparams"         [t| PartialNDParams |]
 374   , simpleField "powered"          [t| Bool   |]
 375   ]
 376   ++ timeStampFields
 377   ++ uuidFields
 378   ++ serialFields
 379   ++ tagsFields)
 380
 381 -- * NodeGroup definitions
 382
 383 -- | The Group allocation policy type.
 384 --
 385 -- Note that the order of constructors is important as the automatic
 386 -- Ord instance will order them in the order they are defined, so when
 387 -- changing this data type be careful about the interaction with the
 388 -- desired sorting order.
 389 --
 390 -- FIXME: COPIED from Types.hs; we need to eliminate this duplication later
 391 $(declareSADT "AllocPolicy"
 392   [ ("AllocPreferred",   'C.allocPolicyPreferred)
 393   , ("AllocLastResort",  'C.allocPolicyLastResort)
 394   , ("AllocUnallocable", 'C.allocPolicyUnallocable)
 395   ])
 396 $(makeJSONInstance ''AllocPolicy)
 397
 398 $(buildObject "NodeGroup" "group" $
 399   [ simpleField "name"         [t| String |]
 400   , defaultField  [| [] |] $ simpleField "members" [t| [String] |]
 401   , simpleField "ndparams"     [t| PartialNDParams |]
 402   , simpleField "alloc_policy" [t| AllocPolicy     |]
 403   , simpleField "ipolicy"      [t| PartialIPolicy  |]
 404   ]
 405   ++ timeStampFields
 406   ++ uuidFields
 407   ++ serialFields
 408   ++ tagsFields)
 409
 410 -- | IP family type
 411 $(declareIADT "IpFamily"
 412   [ ("IpFamilyV4", 'C.ip4Family)
 413   , ("IpFamilyV6", 'C.ip6Family)
 414   ])
 415 $(makeJSONInstance ''IpFamily)
 416
 417 -- | Conversion from IP family to IP version. This is needed because
 418 -- Python uses both, depending on context.
 419 ipFamilyToVersion :: IpFamily -> Int
 420 ipFamilyToVersion IpFamilyV4 = C.ip4Version
 421 ipFamilyToVersion IpFamilyV6 = C.ip6Version
 422
 423 -- * Cluster definitions
 424 $(buildObject "Cluster" "cluster" $
 425   [ simpleField "rsahostkeypub"             [t| String   |]
 426   , simpleField "highest_used_port"         [t| Int      |]
 427   , simpleField "tcpudp_port_pool"          [t| [Int]    |]
 428   , simpleField "mac_prefix"                [t| String   |]
 429   , simpleField "volume_group_name"         [t| String   |]
 430   , simpleField "reserved_lvs"              [t| [String] |]
 431   , optionalField $ simpleField "drbd_usermode_helper" [t| String |]
 432 -- , simpleField "default_bridge"          [t| String   |]
 433 -- , simpleField "default_hypervisor"      [t| String   |]
 434   , simpleField "master_node"               [t| String   |]
 435   , simpleField "master_ip"                 [t| String   |]
 436   , simpleField "master_netdev"             [t| String   |]
 437   , simpleField "master_netmask"            [t| Int   |]
 438   , simpleField "use_external_mip_script"   [t| Bool |]
 439   , simpleField "cluster_name"              [t| String   |]
 440   , simpleField "file_storage_dir"          [t| String   |]
 441   , simpleField "shared_file_storage_dir"   [t| String   |]
 442   , simpleField "enabled_hypervisors"       [t| [String] |]
 443 -- , simpleField "hvparams"                [t| [(String, [(String, String)])] |]
 444 -- , simpleField "os_hvp"                  [t| [(String, String)] |]
 445   , simpleField "beparams" [t| Container FilledBEParams |]
 446   , simpleField "osparams"                  [t| Container (Container String) |]
 447   , simpleField "nicparams" [t| Container FilledNICParams    |]
 448   , simpleField "ndparams"                  [t| FilledNDParams |]
 449   , simpleField "candidate_pool_size"       [t| Int                |]
 450   , simpleField "modify_etc_hosts"          [t| Bool               |]
 451   , simpleField "modify_ssh_setup"          [t| Bool               |]
 452   , simpleField "maintain_node_health"      [t| Bool               |]
 453   , simpleField "uid_pool"                  [t| [(Int, Int)]       |]
 454   , simpleField "default_iallocator"        [t| String             |]
 455   , simpleField "hidden_os"                 [t| [String]           |]
 456   , simpleField "blacklisted_os"            [t| [String]           |]
 457   , simpleField "primary_ip_family"         [t| IpFamily           |]
 458   , simpleField "prealloc_wipe_disks"       [t| Bool               |]
 459   , simpleField "ipolicy"                   [t| FilledIPolicy      |]
 460  ]
 461  ++ serialFields
 462  ++ timeStampFields
 463  ++ uuidFields
 464  ++ tagsFields)
 465
 466 -- * ConfigData definitions
 467
 468 $(buildObject "ConfigData" "config" $
 469 --  timeStampFields ++
 470   [ simpleField "version"    [t| Int                 |]
 471   , simpleField "cluster"    [t| Cluster             |]
 472   , simpleField "nodes"      [t| Container Node      |]
 473   , simpleField "nodegroups" [t| Container NodeGroup |]
 474   , simpleField "instances"  [t| Container Instance  |]
 475   ]
 476   ++ serialFields)