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