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