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