code.grnet.gr Git - ganeti-local/blob - src/Ganeti/Types.hs

   1 {-# LANGUAGE TemplateHaskell #-}
   2
   3 {-| Some common Ganeti types.
   4
   5 This holds types common to both core work, and to htools. Types that
   6 are very core specific (e.g. configuration objects) should go in
   7 'Ganeti.Objects', while types that are specific to htools in-memory
   8 representation should go into 'Ganeti.HTools.Types'.
   9
  10 -}
  11
  12 {-
  13
  14 Copyright (C) 2012, 2013 Google Inc.
  15
  16 This program is free software; you can redistribute it and/or modify
  17 it under the terms of the GNU General Public License as published by
  18 the Free Software Foundation; either version 2 of the License, or
  19 (at your option) any later version.
  20
  21 This program is distributed in the hope that it will be useful, but
  22 WITHOUT ANY WARRANTY; without even the implied warranty of
  23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  24 General Public License for more details.
  25
  26 You should have received a copy of the GNU General Public License
  27 along with this program; if not, write to the Free Software
  28 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  29 02110-1301, USA.
  30
  31 -}
  32
  33 module Ganeti.Types
  34   ( AllocPolicy(..)
  35   , allocPolicyFromRaw
  36   , allocPolicyToRaw
  37   , InstanceStatus(..)
  38   , instanceStatusFromRaw
  39   , instanceStatusToRaw
  40   , DiskTemplate(..)
  41   , diskTemplateToRaw
  42   , diskTemplateFromRaw
  43   , TagKind(..)
  44   , tagKindToRaw
  45   , tagKindFromRaw
  46   , NonNegative
  47   , fromNonNegative
  48   , mkNonNegative
  49   , Positive
  50   , fromPositive
  51   , mkPositive
  52   , Negative
  53   , fromNegative
  54   , mkNegative
  55   , NonEmpty
  56   , fromNonEmpty
  57   , mkNonEmpty
  58   , NonEmptyString
  59   , QueryResultCode
  60   , IPv4Address
  61   , mkIPv4Address
  62   , IPv4Network
  63   , mkIPv4Network
  64   , IPv6Address
  65   , mkIPv6Address
  66   , IPv6Network
  67   , mkIPv6Network
  68   , MigrationMode(..)
  69   , migrationModeToRaw
  70   , VerifyOptionalChecks(..)
  71   , verifyOptionalChecksToRaw
  72   , DdmSimple(..)
  73   , DdmFull(..)
  74   , ddmFullToRaw
  75   , CVErrorCode(..)
  76   , cVErrorCodeToRaw
  77   , Hypervisor(..)
  78   , hypervisorToRaw
  79   , OobCommand(..)
  80   , oobCommandToRaw
  81   , OobStatus(..)
  82   , oobStatusToRaw
  83   , StorageType(..)
  84   , storageTypeToRaw
  85   , EvacMode(..)
  86   , evacModeToRaw
  87   , FileDriver(..)
  88   , fileDriverToRaw
  89   , InstCreateMode(..)
  90   , instCreateModeToRaw
  91   , RebootType(..)
  92   , rebootTypeToRaw
  93   , ExportMode(..)
  94   , exportModeToRaw
  95   , IAllocatorTestDir(..)
  96   , iAllocatorTestDirToRaw
  97   , IAllocatorMode(..)
  98   , iAllocatorModeToRaw
  99   , NICMode(..)
 100   , nICModeToRaw
 101   , JobStatus(..)
 102   , jobStatusToRaw
 103   , jobStatusFromRaw
 104   , FinalizedJobStatus(..)
 105   , finalizedJobStatusToRaw
 106   , JobId
 107   , fromJobId
 108   , makeJobId
 109   , makeJobIdS
 110   , RelativeJobId
 111   , JobIdDep(..)
 112   , JobDependency(..)
 113   , OpSubmitPriority(..)
 114   , opSubmitPriorityToRaw
 115   , parseSubmitPriority
 116   , fmtSubmitPriority
 117   , OpStatus(..)
 118   , opStatusToRaw
 119   , opStatusFromRaw
 120   , ELogType(..)
 121   , eLogTypeToRaw
 122   , ReasonElem
 123   , ReasonTrail
 124   , StorageUnit(..)
 125   , StorageUnitRaw(..)
 126   , StorageKey
 127   , addParamsToStorageUnit
 128   , diskTemplateToStorageType
 129   , VType(..)
 130   , vTypeFromRaw
 131   , vTypeToRaw
 132   , NodeRole(..)
 133   , nodeRoleToRaw
 134   , roleDescription
 135   , DiskMode(..)
 136   , diskModeToRaw
 137   , BlockDriver(..)
 138   , blockDriverToRaw
 139   , AdminState(..)
 140   , adminStateFromRaw
 141   , adminStateToRaw
 142   , StorageField(..)
 143   , storageFieldToRaw
 144   , DiskAccessMode(..)
 145   , diskAccessModeToRaw
 146   , ReplaceDisksMode(..)
 147   , replaceDisksModeToRaw
 148   ) where
 149
 150 import Control.Monad (liftM)
 151 import qualified Text.JSON as JSON
 152 import Text.JSON (JSON, readJSON, showJSON)
 153 import Data.Ratio (numerator, denominator)
 154
 155 import qualified Ganeti.ConstantUtils as ConstantUtils
 156 import Ganeti.JSON
 157 import qualified Ganeti.THH as THH
 158 import Ganeti.Utils
 159
 160 -- * Generic types
 161
 162 -- | Type that holds a non-negative value.
 163 newtype NonNegative a = NonNegative { fromNonNegative :: a }
 164   deriving (Show, Eq)
 165
 166 -- | Smart constructor for 'NonNegative'.
 167 mkNonNegative :: (Monad m, Num a, Ord a, Show a) => a -> m (NonNegative a)
 168 mkNonNegative i | i >= 0 = return (NonNegative i)
 169                 | otherwise = fail $ "Invalid value for non-negative type '" ++
 170                               show i ++ "'"
 171
 172 instance (JSON.JSON a, Num a, Ord a, Show a) => JSON.JSON (NonNegative a) where
 173   showJSON = JSON.showJSON . fromNonNegative
 174   readJSON v = JSON.readJSON v >>= mkNonNegative
 175
 176 -- | Type that holds a positive value.
 177 newtype Positive a = Positive { fromPositive :: a }
 178   deriving (Show, Eq)
 179
 180 -- | Smart constructor for 'Positive'.
 181 mkPositive :: (Monad m, Num a, Ord a, Show a) => a -> m (Positive a)
 182 mkPositive i | i > 0 = return (Positive i)
 183              | otherwise = fail $ "Invalid value for positive type '" ++
 184                            show i ++ "'"
 185
 186 instance (JSON.JSON a, Num a, Ord a, Show a) => JSON.JSON (Positive a) where
 187   showJSON = JSON.showJSON . fromPositive
 188   readJSON v = JSON.readJSON v >>= mkPositive
 189
 190 -- | Type that holds a negative value.
 191 newtype Negative a = Negative { fromNegative :: a }
 192   deriving (Show, Eq)
 193
 194 -- | Smart constructor for 'Negative'.
 195 mkNegative :: (Monad m, Num a, Ord a, Show a) => a -> m (Negative a)
 196 mkNegative i | i < 0 = return (Negative i)
 197              | otherwise = fail $ "Invalid value for negative type '" ++
 198                            show i ++ "'"
 199
 200 instance (JSON.JSON a, Num a, Ord a, Show a) => JSON.JSON (Negative a) where
 201   showJSON = JSON.showJSON . fromNegative
 202   readJSON v = JSON.readJSON v >>= mkNegative
 203
 204 -- | Type that holds a non-null list.
 205 newtype NonEmpty a = NonEmpty { fromNonEmpty :: [a] }
 206   deriving (Show, Eq)
 207
 208 -- | Smart constructor for 'NonEmpty'.
 209 mkNonEmpty :: (Monad m) => [a] -> m (NonEmpty a)
 210 mkNonEmpty [] = fail "Received empty value for non-empty list"
 211 mkNonEmpty xs = return (NonEmpty xs)
 212
 213 instance (Eq a, Ord a) => Ord (NonEmpty a) where
 214   NonEmpty { fromNonEmpty = x1 } `compare` NonEmpty { fromNonEmpty = x2 } =
 215     x1 `compare` x2
 216
 217 instance (JSON.JSON a) => JSON.JSON (NonEmpty a) where
 218   showJSON = JSON.showJSON . fromNonEmpty
 219   readJSON v = JSON.readJSON v >>= mkNonEmpty
 220
 221 -- | A simple type alias for non-empty strings.
 222 type NonEmptyString = NonEmpty Char
 223
 224 type QueryResultCode = Int
 225
 226 newtype IPv4Address = IPv4Address { fromIPv4Address :: String }
 227   deriving (Show, Eq)
 228
 229 -- FIXME: this should check that 'address' is a valid ip
 230 mkIPv4Address :: Monad m => String -> m IPv4Address
 231 mkIPv4Address address =
 232   return IPv4Address { fromIPv4Address = address }
 233
 234 instance JSON.JSON IPv4Address where
 235   showJSON = JSON.showJSON . fromIPv4Address
 236   readJSON v = JSON.readJSON v >>= mkIPv4Address
 237
 238 newtype IPv4Network = IPv4Network { fromIPv4Network :: String }
 239   deriving (Show, Eq)
 240
 241 -- FIXME: this should check that 'address' is a valid ip
 242 mkIPv4Network :: Monad m => String -> m IPv4Network
 243 mkIPv4Network address =
 244   return IPv4Network { fromIPv4Network = address }
 245
 246 instance JSON.JSON IPv4Network where
 247   showJSON = JSON.showJSON . fromIPv4Network
 248   readJSON v = JSON.readJSON v >>= mkIPv4Network
 249
 250 newtype IPv6Address = IPv6Address { fromIPv6Address :: String }
 251   deriving (Show, Eq)
 252
 253 -- FIXME: this should check that 'address' is a valid ip
 254 mkIPv6Address :: Monad m => String -> m IPv6Address
 255 mkIPv6Address address =
 256   return IPv6Address { fromIPv6Address = address }
 257
 258 instance JSON.JSON IPv6Address where
 259   showJSON = JSON.showJSON . fromIPv6Address
 260   readJSON v = JSON.readJSON v >>= mkIPv6Address
 261
 262 newtype IPv6Network = IPv6Network { fromIPv6Network :: String }
 263   deriving (Show, Eq)
 264
 265 -- FIXME: this should check that 'address' is a valid ip
 266 mkIPv6Network :: Monad m => String -> m IPv6Network
 267 mkIPv6Network address =
 268   return IPv6Network { fromIPv6Network = address }
 269
 270 instance JSON.JSON IPv6Network where
 271   showJSON = JSON.showJSON . fromIPv6Network
 272   readJSON v = JSON.readJSON v >>= mkIPv6Network
 273
 274 -- * Ganeti types
 275
 276 -- | Instance disk template type.
 277 $(THH.declareLADT ''String "DiskTemplate"
 278        [ ("DTDiskless",   "diskless")
 279        , ("DTFile",       "file")
 280        , ("DTSharedFile", "sharedfile")
 281        , ("DTPlain",      "plain")
 282        , ("DTBlock",      "blockdev")
 283        , ("DTDrbd8",      "drbd")
 284        , ("DTRbd",        "rbd")
 285        , ("DTExt",        "ext")
 286        ])
 287 $(THH.makeJSONInstance ''DiskTemplate)
 288
 289 instance THH.PyValue DiskTemplate where
 290   showValue = show . diskTemplateToRaw
 291
 292 instance HasStringRepr DiskTemplate where
 293   fromStringRepr = diskTemplateFromRaw
 294   toStringRepr = diskTemplateToRaw
 295
 296 -- | Data type representing what items the tag operations apply to.
 297 $(THH.declareLADT ''String "TagKind"
 298   [ ("TagKindInstance", "instance")
 299   , ("TagKindNode",     "node")
 300   , ("TagKindGroup",    "nodegroup")
 301   , ("TagKindCluster",  "cluster")
 302   , ("TagKindNetwork",  "network")
 303   ])
 304 $(THH.makeJSONInstance ''TagKind)
 305
 306 -- | The Group allocation policy type.
 307 --
 308 -- Note that the order of constructors is important as the automatic
 309 -- Ord instance will order them in the order they are defined, so when
 310 -- changing this data type be careful about the interaction with the
 311 -- desired sorting order.
 312 $(THH.declareLADT ''String "AllocPolicy"
 313        [ ("AllocPreferred",   "preferred")
 314        , ("AllocLastResort",  "last_resort")
 315        , ("AllocUnallocable", "unallocable")
 316        ])
 317 $(THH.makeJSONInstance ''AllocPolicy)
 318
 319 -- | The Instance real state type. FIXME: this could be improved to
 320 -- just wrap a /NormalState AdminStatus | ErrorState ErrorCondition/.
 321 $(THH.declareLADT ''String "InstanceStatus"
 322        [ ("StatusDown",    "ADMIN_down")
 323        , ("StatusOffline", "ADMIN_offline")
 324        , ("ErrorDown",     "ERROR_down")
 325        , ("ErrorUp",       "ERROR_up")
 326        , ("NodeDown",      "ERROR_nodedown")
 327        , ("NodeOffline",   "ERROR_nodeoffline")
 328        , ("Running",       "running")
 329        , ("WrongNode",     "ERROR_wrongnode")
 330        ])
 331 $(THH.makeJSONInstance ''InstanceStatus)
 332
 333 -- | Migration mode.
 334 $(THH.declareLADT ''String "MigrationMode"
 335      [ ("MigrationLive",    "live")
 336      , ("MigrationNonLive", "non-live")
 337      ])
 338 $(THH.makeJSONInstance ''MigrationMode)
 339
 340 -- | Verify optional checks.
 341 $(THH.declareLADT ''String "VerifyOptionalChecks"
 342      [ ("VerifyNPlusOneMem", "nplusone_mem")
 343      ])
 344 $(THH.makeJSONInstance ''VerifyOptionalChecks)
 345
 346 -- | Cluster verify error codes.
 347 $(THH.declareLADT ''String "CVErrorCode"
 348   [ ("CvECLUSTERCFG",                  "ECLUSTERCFG")
 349   , ("CvECLUSTERCERT",                 "ECLUSTERCERT")
 350   , ("CvECLUSTERFILECHECK",            "ECLUSTERFILECHECK")
 351   , ("CvECLUSTERDANGLINGNODES",        "ECLUSTERDANGLINGNODES")
 352   , ("CvECLUSTERDANGLINGINST",         "ECLUSTERDANGLINGINST")
 353   , ("CvEINSTANCEBADNODE",             "EINSTANCEBADNODE")
 354   , ("CvEINSTANCEDOWN",                "EINSTANCEDOWN")
 355   , ("CvEINSTANCELAYOUT",              "EINSTANCELAYOUT")
 356   , ("CvEINSTANCEMISSINGDISK",         "EINSTANCEMISSINGDISK")
 357   , ("CvEINSTANCEFAULTYDISK",          "EINSTANCEFAULTYDISK")
 358   , ("CvEINSTANCEWRONGNODE",           "EINSTANCEWRONGNODE")
 359   , ("CvEINSTANCESPLITGROUPS",         "EINSTANCESPLITGROUPS")
 360   , ("CvEINSTANCEPOLICY",              "EINSTANCEPOLICY")
 361   , ("CvEINSTANCEUNSUITABLENODE",      "EINSTANCEUNSUITABLENODE")
 362   , ("CvEINSTANCEMISSINGCFGPARAMETER", "EINSTANCEMISSINGCFGPARAMETER")
 363   , ("CvENODEDRBD",                    "ENODEDRBD")
 364   , ("CvENODEDRBDVERSION",             "ENODEDRBDVERSION")
 365   , ("CvENODEDRBDHELPER",              "ENODEDRBDHELPER")
 366   , ("CvENODEFILECHECK",               "ENODEFILECHECK")
 367   , ("CvENODEHOOKS",                   "ENODEHOOKS")
 368   , ("CvENODEHV",                      "ENODEHV")
 369   , ("CvENODELVM",                     "ENODELVM")
 370   , ("CvENODEN1",                      "ENODEN1")
 371   , ("CvENODENET",                     "ENODENET")
 372   , ("CvENODEOS",                      "ENODEOS")
 373   , ("CvENODEORPHANINSTANCE",          "ENODEORPHANINSTANCE")
 374   , ("CvENODEORPHANLV",                "ENODEORPHANLV")
 375   , ("CvENODERPC",                     "ENODERPC")
 376   , ("CvENODESSH",                     "ENODESSH")
 377   , ("CvENODEVERSION",                 "ENODEVERSION")
 378   , ("CvENODESETUP",                   "ENODESETUP")
 379   , ("CvENODETIME",                    "ENODETIME")
 380   , ("CvENODEOOBPATH",                 "ENODEOOBPATH")
 381   , ("CvENODEUSERSCRIPTS",             "ENODEUSERSCRIPTS")
 382   , ("CvENODEFILESTORAGEPATHS",        "ENODEFILESTORAGEPATHS")
 383   , ("CvENODEFILESTORAGEPATHUNUSABLE", "ENODEFILESTORAGEPATHUNUSABLE")
 384   , ("CvENODESHAREDFILESTORAGEPATHUNUSABLE",
 385      "ENODESHAREDFILESTORAGEPATHUNUSABLE")
 386   , ("CvEGROUPDIFFERENTPVSIZE",        "EGROUPDIFFERENTPVSIZE")
 387   ])
 388 $(THH.makeJSONInstance ''CVErrorCode)
 389
 390 -- | Dynamic device modification, just add\/remove version.
 391 $(THH.declareLADT ''String "DdmSimple"
 392      [ ("DdmSimpleAdd",    "add")
 393      , ("DdmSimpleRemove", "remove")
 394      ])
 395 $(THH.makeJSONInstance ''DdmSimple)
 396
 397 -- | Dynamic device modification, all operations version.
 398 $(THH.declareLADT ''String "DdmFull"
 399      [ ("DdmFullAdd",    "add")
 400      , ("DdmFullRemove", "remove")
 401      , ("DdmFullModify", "modify")
 402      ])
 403 $(THH.makeJSONInstance ''DdmFull)
 404
 405 -- | Hypervisor type definitions.
 406 $(THH.declareLADT ''String "Hypervisor"
 407   [ ("Kvm",    "kvm")
 408   , ("XenPvm", "xen-pvm")
 409   , ("Chroot", "chroot")
 410   , ("XenHvm", "xen-hvm")
 411   , ("Lxc",    "lxc")
 412   , ("Fake",   "fake")
 413   ])
 414 $(THH.makeJSONInstance ''Hypervisor)
 415
 416 instance THH.PyValue Hypervisor where
 417   showValue = show . hypervisorToRaw
 418
 419 -- | Oob command type.
 420 $(THH.declareLADT ''String "OobCommand"
 421   [ ("OobHealth",      "health")
 422   , ("OobPowerCycle",  "power-cycle")
 423   , ("OobPowerOff",    "power-off")
 424   , ("OobPowerOn",     "power-on")
 425   , ("OobPowerStatus", "power-status")
 426   ])
 427 $(THH.makeJSONInstance ''OobCommand)
 428
 429 -- | Oob command status
 430 $(THH.declareLADT ''String "OobStatus"
 431   [ ("OobStatusCritical", "CRITICAL")
 432   , ("OobStatusOk",       "OK")
 433   , ("OobStatusUnknown",  "UNKNOWN")
 434   , ("OobStatusWarning",  "WARNING")
 435   ])
 436 $(THH.makeJSONInstance ''OobStatus)
 437
 438 -- | Storage type.
 439 $(THH.declareLADT ''String "StorageType"
 440   [ ("StorageFile", "file")
 441   , ("StorageLvmPv", "lvm-pv")
 442   , ("StorageLvmVg", "lvm-vg")
 443   , ("StorageDiskless", "diskless")
 444   , ("StorageBlock", "blockdev")
 445   , ("StorageRados", "rados")
 446   , ("StorageExt", "ext")
 447   ])
 448 $(THH.makeJSONInstance ''StorageType)
 449
 450 -- | Storage keys are identifiers for storage units. Their content varies
 451 -- depending on the storage type, for example a storage key for LVM storage
 452 -- is the volume group name.
 453 type StorageKey = String
 454
 455 -- | Storage parameters
 456 type SPExclusiveStorage = Bool
 457
 458 -- | Storage units without storage-type-specific parameters
 459 data StorageUnitRaw = SURaw StorageType StorageKey
 460
 461 -- | Full storage unit with storage-type-specific parameters
 462 data StorageUnit = SUFile StorageKey
 463                  | SULvmPv StorageKey SPExclusiveStorage
 464                  | SULvmVg StorageKey SPExclusiveStorage
 465                  | SUDiskless StorageKey
 466                  | SUBlock StorageKey
 467                  | SURados StorageKey
 468                  | SUExt StorageKey
 469                  deriving (Eq)
 470
 471 instance Show StorageUnit where
 472   show (SUFile key) = showSUSimple StorageFile key
 473   show (SULvmPv key es) = showSULvm StorageLvmPv key es
 474   show (SULvmVg key es) = showSULvm StorageLvmVg key es
 475   show (SUDiskless key) = showSUSimple StorageDiskless key
 476   show (SUBlock key) = showSUSimple StorageBlock key
 477   show (SURados key) = showSUSimple StorageRados key
 478   show (SUExt key) = showSUSimple StorageExt key
 479
 480 instance JSON StorageUnit where
 481   showJSON (SUFile key) = showJSON (StorageFile, key, []::[String])
 482   showJSON (SULvmPv key es) = showJSON (StorageLvmPv, key, [es])
 483   showJSON (SULvmVg key es) = showJSON (StorageLvmVg, key, [es])
 484   showJSON (SUDiskless key) = showJSON (StorageDiskless, key, []::[String])
 485   showJSON (SUBlock key) = showJSON (StorageBlock, key, []::[String])
 486   showJSON (SURados key) = showJSON (StorageRados, key, []::[String])
 487   showJSON (SUExt key) = showJSON (StorageExt, key, []::[String])
 488 -- FIXME: add readJSON implementation
 489   readJSON = fail "Not implemented"
 490
 491 -- | Composes a string representation of storage types without
 492 -- storage parameters
 493 showSUSimple :: StorageType -> StorageKey -> String
 494 showSUSimple st sk = show (storageTypeToRaw st, sk, []::[String])
 495
 496 -- | Composes a string representation of the LVM storage types
 497 showSULvm :: StorageType -> StorageKey -> SPExclusiveStorage -> String
 498 showSULvm st sk es = show (storageTypeToRaw st, sk, [es])
 499
 500 -- | Mapping from disk templates to storage types
 501 -- FIXME: This is semantically the same as the constant
 502 -- C.diskTemplatesStorageType, remove this when python constants
 503 -- are generated from haskell constants
 504 diskTemplateToStorageType :: DiskTemplate -> StorageType
 505 diskTemplateToStorageType DTExt = StorageExt
 506 diskTemplateToStorageType DTFile = StorageFile
 507 diskTemplateToStorageType DTSharedFile = StorageFile
 508 diskTemplateToStorageType DTDrbd8 = StorageLvmVg
 509 diskTemplateToStorageType DTPlain = StorageLvmVg
 510 diskTemplateToStorageType DTRbd = StorageRados
 511 diskTemplateToStorageType DTDiskless = StorageDiskless
 512 diskTemplateToStorageType DTBlock = StorageBlock
 513
 514 -- | Equips a raw storage unit with its parameters
 515 addParamsToStorageUnit :: SPExclusiveStorage -> StorageUnitRaw -> StorageUnit
 516 addParamsToStorageUnit _ (SURaw StorageBlock key) = SUBlock key
 517 addParamsToStorageUnit _ (SURaw StorageDiskless key) = SUDiskless key
 518 addParamsToStorageUnit _ (SURaw StorageExt key) = SUExt key
 519 addParamsToStorageUnit _ (SURaw StorageFile key) = SUFile key
 520 addParamsToStorageUnit es (SURaw StorageLvmPv key) = SULvmPv key es
 521 addParamsToStorageUnit es (SURaw StorageLvmVg key) = SULvmVg key es
 522 addParamsToStorageUnit _ (SURaw StorageRados key) = SURados key
 523
 524 -- | Node evac modes.
 525 --
 526 -- This is part of the 'IAllocator' interface and it is used, for
 527 -- example, in 'Ganeti.HTools.Loader.RqType'.  However, it must reside
 528 -- in this module, and not in 'Ganeti.HTools.Types', because it is
 529 -- also used by 'Ganeti.HsConstants'.
 530 $(THH.declareLADT ''String "EvacMode"
 531   [ ("ChangePrimary",   "primary-only")
 532   , ("ChangeSecondary", "secondary-only")
 533   , ("ChangeAll",       "all")
 534   ])
 535 $(THH.makeJSONInstance ''EvacMode)
 536
 537 -- | The file driver type.
 538 $(THH.declareLADT ''String "FileDriver"
 539   [ ("FileLoop",   "loop")
 540   , ("FileBlktap", "blktap")
 541   ])
 542 $(THH.makeJSONInstance ''FileDriver)
 543
 544 -- | The instance create mode.
 545 $(THH.declareLADT ''String "InstCreateMode"
 546   [ ("InstCreate",       "create")
 547   , ("InstImport",       "import")
 548   , ("InstRemoteImport", "remote-import")
 549   ])
 550 $(THH.makeJSONInstance ''InstCreateMode)
 551
 552 -- | Reboot type.
 553 $(THH.declareLADT ''String "RebootType"
 554   [ ("RebootSoft", "soft")
 555   , ("RebootHard", "hard")
 556   , ("RebootFull", "full")
 557   ])
 558 $(THH.makeJSONInstance ''RebootType)
 559
 560 -- | Export modes.
 561 $(THH.declareLADT ''String "ExportMode"
 562   [ ("ExportModeLocal",  "local")
 563   , ("ExportModeRemote", "remote")
 564   ])
 565 $(THH.makeJSONInstance ''ExportMode)
 566
 567 -- | IAllocator run types (OpTestIAllocator).
 568 $(THH.declareLADT ''String "IAllocatorTestDir"
 569   [ ("IAllocatorDirIn",  "in")
 570   , ("IAllocatorDirOut", "out")
 571   ])
 572 $(THH.makeJSONInstance ''IAllocatorTestDir)
 573
 574 -- | IAllocator mode. FIXME: use this in "HTools.Backend.IAlloc".
 575 $(THH.declareLADT ''String "IAllocatorMode"
 576   [ ("IAllocatorAlloc",       "allocate")
 577   , ("IAllocatorMultiAlloc",  "multi-allocate")
 578   , ("IAllocatorReloc",       "relocate")
 579   , ("IAllocatorNodeEvac",    "node-evacuate")
 580   , ("IAllocatorChangeGroup", "change-group")
 581   ])
 582 $(THH.makeJSONInstance ''IAllocatorMode)
 583
 584 -- | Network mode.
 585 $(THH.declareLADT ''String "NICMode"
 586   [ ("NMBridged", "bridged")
 587   , ("NMRouted",  "routed")
 588   , ("NMOvs",     "openvswitch")
 589   , ("NMPool",    "pool")
 590   ])
 591 $(THH.makeJSONInstance ''NICMode)
 592
 593 -- | The JobStatus data type. Note that this is ordered especially
 594 -- such that greater\/lesser comparison on values of this type makes
 595 -- sense.
 596 $(THH.declareLADT ''String "JobStatus"
 597   [ ("JOB_STATUS_QUEUED",    "queued")
 598   , ("JOB_STATUS_WAITING",   "waiting")
 599   , ("JOB_STATUS_CANCELING", "canceling")
 600   , ("JOB_STATUS_RUNNING",   "running")
 601   , ("JOB_STATUS_CANCELED",  "canceled")
 602   , ("JOB_STATUS_SUCCESS",   "success")
 603   , ("JOB_STATUS_ERROR",     "error")
 604   ])
 605 $(THH.makeJSONInstance ''JobStatus)
 606
 607 -- | Finalized job status.
 608 $(THH.declareLADT ''String "FinalizedJobStatus"
 609   [ ("JobStatusCanceled",   "canceled")
 610   , ("JobStatusSuccessful", "success")
 611   , ("JobStatusFailed",     "error")
 612   ])
 613 $(THH.makeJSONInstance ''FinalizedJobStatus)
 614
 615 -- | The Ganeti job type.
 616 newtype JobId = JobId { fromJobId :: Int }
 617   deriving (Show, Eq)
 618
 619 -- | Builds a job ID.
 620 makeJobId :: (Monad m) => Int -> m JobId
 621 makeJobId i | i >= 0 = return $ JobId i
 622             | otherwise = fail $ "Invalid value for job ID ' " ++ show i ++ "'"
 623
 624 -- | Builds a job ID from a string.
 625 makeJobIdS :: (Monad m) => String -> m JobId
 626 makeJobIdS s = tryRead "parsing job id" s >>= makeJobId
 627
 628 -- | Parses a job ID.
 629 parseJobId :: (Monad m) => JSON.JSValue -> m JobId
 630 parseJobId (JSON.JSString x) = makeJobIdS $ JSON.fromJSString x
 631 parseJobId (JSON.JSRational _ x) =
 632   if denominator x /= 1
 633     then fail $ "Got fractional job ID from master daemon?! Value:" ++ show x
 634     -- FIXME: potential integer overflow here on 32-bit platforms
 635     else makeJobId . fromIntegral . numerator $ x
 636 parseJobId x = fail $ "Wrong type/value for job id: " ++ show x
 637
 638 instance JSON.JSON JobId where
 639   showJSON = JSON.showJSON . fromJobId
 640   readJSON = parseJobId
 641
 642 -- | Relative job ID type alias.
 643 type RelativeJobId = Negative Int
 644
 645 -- | Job ID dependency.
 646 data JobIdDep = JobDepRelative RelativeJobId
 647               | JobDepAbsolute JobId
 648                 deriving (Show, Eq)
 649
 650 instance JSON.JSON JobIdDep where
 651   showJSON (JobDepRelative i) = showJSON i
 652   showJSON (JobDepAbsolute i) = showJSON i
 653   readJSON v =
 654     case JSON.readJSON v::JSON.Result (Negative Int) of
 655       -- first try relative dependency, usually most common
 656       JSON.Ok r -> return $ JobDepRelative r
 657       JSON.Error _ -> liftM JobDepAbsolute (parseJobId v)
 658
 659 -- | Job Dependency type.
 660 data JobDependency = JobDependency JobIdDep [FinalizedJobStatus]
 661                      deriving (Show, Eq)
 662
 663 instance JSON JobDependency where
 664   showJSON (JobDependency dep status) = showJSON (dep, status)
 665   readJSON = liftM (uncurry JobDependency) . readJSON
 666
 667 -- | Valid opcode priorities for submit.
 668 $(THH.declareIADT "OpSubmitPriority"
 669   [ ("OpPrioLow",    'ConstantUtils.priorityLow)
 670   , ("OpPrioNormal", 'ConstantUtils.priorityNormal)
 671   , ("OpPrioHigh",   'ConstantUtils.priorityHigh)
 672   ])
 673 $(THH.makeJSONInstance ''OpSubmitPriority)
 674
 675 -- | Parse submit priorities from a string.
 676 parseSubmitPriority :: (Monad m) => String -> m OpSubmitPriority
 677 parseSubmitPriority "low"    = return OpPrioLow
 678 parseSubmitPriority "normal" = return OpPrioNormal
 679 parseSubmitPriority "high"   = return OpPrioHigh
 680 parseSubmitPriority str      = fail $ "Unknown priority '" ++ str ++ "'"
 681
 682 -- | Format a submit priority as string.
 683 fmtSubmitPriority :: OpSubmitPriority -> String
 684 fmtSubmitPriority OpPrioLow    = "low"
 685 fmtSubmitPriority OpPrioNormal = "normal"
 686 fmtSubmitPriority OpPrioHigh   = "high"
 687
 688 -- | Our ADT for the OpCode status at runtime (while in a job).
 689 $(THH.declareLADT ''String "OpStatus"
 690   [ ("OP_STATUS_QUEUED",    "queued")
 691   , ("OP_STATUS_WAITING",   "waiting")
 692   , ("OP_STATUS_CANCELING", "canceling")
 693   , ("OP_STATUS_RUNNING",   "running")
 694   , ("OP_STATUS_CANCELED",  "canceled")
 695   , ("OP_STATUS_SUCCESS",   "success")
 696   , ("OP_STATUS_ERROR",     "error")
 697   ])
 698 $(THH.makeJSONInstance ''OpStatus)
 699
 700 -- | Type for the job message type.
 701 $(THH.declareLADT ''String "ELogType"
 702   [ ("ELogMessage",      "message")
 703   , ("ELogRemoteImport", "remote-import")
 704   , ("ELogJqueueTest",   "jqueue-test")
 705   ])
 706 $(THH.makeJSONInstance ''ELogType)
 707
 708 -- | Type of one element of a reason trail.
 709 type ReasonElem = (String, String, Integer)
 710
 711 -- | Type representing a reason trail.
 712 type ReasonTrail = [ReasonElem]
 713
 714 -- | The VTYPES, a mini-type system in Python.
 715 $(THH.declareLADT ''String "VType"
 716   [ ("VTypeString",      "string")
 717   , ("VTypeMaybeString", "maybe-string")
 718   , ("VTypeBool",        "bool")
 719   , ("VTypeSize",        "size")
 720   , ("VTypeInt",         "int")
 721   ])
 722 $(THH.makeJSONInstance ''VType)
 723
 724 -- * Node role type
 725
 726 $(THH.declareLADT ''String "NodeRole"
 727   [ ("NROffline",   "O")
 728   , ("NRDrained",   "D")
 729   , ("NRRegular",   "R")
 730   , ("NRCandidate", "C")
 731   , ("NRMaster",    "M")
 732   ])
 733 $(THH.makeJSONInstance ''NodeRole)
 734
 735 -- | The description of the node role.
 736 roleDescription :: NodeRole -> String
 737 roleDescription NROffline   = "offline"
 738 roleDescription NRDrained   = "drained"
 739 roleDescription NRRegular   = "regular"
 740 roleDescription NRCandidate = "master candidate"
 741 roleDescription NRMaster    = "master"
 742
 743 -- * Disk types
 744
 745 $(THH.declareLADT ''String "DiskMode"
 746   [ ("DiskRdOnly", "ro")
 747   , ("DiskRdWr",   "rw")
 748   ])
 749 $(THH.makeJSONInstance ''DiskMode)
 750
 751 -- | The persistent block driver type. Currently only one type is allowed.
 752 $(THH.declareLADT ''String "BlockDriver"
 753   [ ("BlockDrvManual", "manual")
 754   ])
 755 $(THH.makeJSONInstance ''BlockDriver)
 756
 757 -- * Instance types
 758
 759 $(THH.declareLADT ''String "AdminState"
 760   [ ("AdminOffline", "offline")
 761   , ("AdminDown",    "down")
 762   , ("AdminUp",      "up")
 763   ])
 764 $(THH.makeJSONInstance ''AdminState)
 765
 766 -- * Storage field type
 767
 768 $(THH.declareLADT ''String "StorageField"
 769   [ ( "SFUsed",        "used")
 770   , ( "SFName",        "name")
 771   , ( "SFAllocatable", "allocatable")
 772   , ( "SFFree",        "free")
 773   , ( "SFSize",        "size")
 774   ])
 775 $(THH.makeJSONInstance ''StorageField)
 776
 777 -- * Disk access protocol
 778
 779 $(THH.declareLADT ''String "DiskAccessMode"
 780   [ ( "DiskUserspace",   "userspace")
 781   , ( "DiskKernelspace", "kernelspace")
 782   ])
 783 $(THH.makeJSONInstance ''DiskAccessMode)
 784
 785 -- | Replace disks type.
 786 $(THH.declareLADT ''String "ReplaceDisksMode"
 787   [ -- Replace disks on primary
 788     ("ReplaceOnPrimary",    "replace_on_primary")
 789     -- Replace disks on secondary
 790   , ("ReplaceOnSecondary",  "replace_on_secondary")
 791     -- Change secondary node
 792   , ("ReplaceNewSecondary", "replace_new_secondary")
 793   , ("ReplaceAuto",         "replace_auto")
 794   ])
 795 $(THH.makeJSONInstance ''ReplaceDisksMode)