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