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