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   , NodeEvacMode(..)
  86   , nodeEvacModeToRaw
  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 $(THH.declareLADT ''String "NodeEvacMode"
 516   [ ("NEvacPrimary",   "primary-only")
 517   , ("NEvacSecondary", "secondary-only")
 518   , ("NEvacAll",       "all")
 519   ])
 520 $(THH.makeJSONInstance ''NodeEvacMode)
 521
 522 -- | The file driver type.
 523 $(THH.declareLADT ''String "FileDriver"
 524   [ ("FileLoop",   "loop")
 525   , ("FileBlktap", "blktap")
 526   ])
 527 $(THH.makeJSONInstance ''FileDriver)
 528
 529 -- | The instance create mode.
 530 $(THH.declareLADT ''String "InstCreateMode"
 531   [ ("InstCreate",       "create")
 532   , ("InstImport",       "import")
 533   , ("InstRemoteImport", "remote-import")
 534   ])
 535 $(THH.makeJSONInstance ''InstCreateMode)
 536
 537 -- | Reboot type.
 538 $(THH.declareLADT ''String "RebootType"
 539   [ ("RebootSoft", "soft")
 540   , ("RebootHard", "hard")
 541   , ("RebootFull", "full")
 542   ])
 543 $(THH.makeJSONInstance ''RebootType)
 544
 545 -- | Export modes.
 546 $(THH.declareLADT ''String "ExportMode"
 547   [ ("ExportModeLocal",  "local")
 548   , ("ExportModeRemote", "remote")
 549   ])
 550 $(THH.makeJSONInstance ''ExportMode)
 551
 552 -- | IAllocator run types (OpTestIAllocator).
 553 $(THH.declareLADT ''String "IAllocatorTestDir"
 554   [ ("IAllocatorDirIn",  "in")
 555   , ("IAllocatorDirOut", "out")
 556   ])
 557 $(THH.makeJSONInstance ''IAllocatorTestDir)
 558
 559 -- | IAllocator mode. FIXME: use this in "HTools.Backend.IAlloc".
 560 $(THH.declareLADT ''String "IAllocatorMode"
 561   [ ("IAllocatorAlloc",       "allocate")
 562   , ("IAllocatorMultiAlloc",  "multi-allocate")
 563   , ("IAllocatorReloc",       "relocate")
 564   , ("IAllocatorNodeEvac",    "node-evacuate")
 565   , ("IAllocatorChangeGroup", "change-group")
 566   ])
 567 $(THH.makeJSONInstance ''IAllocatorMode)
 568
 569 -- | Network mode.
 570 $(THH.declareLADT ''String "NICMode"
 571   [ ("NMBridged", "bridged")
 572   , ("NMRouted",  "routed")
 573   , ("NMOvs",     "openvswitch")
 574   , ("NMPool",    "pool")
 575   ])
 576 $(THH.makeJSONInstance ''NICMode)
 577
 578 -- | The JobStatus data type. Note that this is ordered especially
 579 -- such that greater\/lesser comparison on values of this type makes
 580 -- sense.
 581 $(THH.declareLADT ''String "JobStatus"
 582   [ ("JOB_STATUS_QUEUED",    "queued")
 583   , ("JOB_STATUS_WAITING",   "waiting")
 584   , ("JOB_STATUS_CANCELING", "canceling")
 585   , ("JOB_STATUS_RUNNING",   "running")
 586   , ("JOB_STATUS_CANCELED",  "canceled")
 587   , ("JOB_STATUS_SUCCESS",   "success")
 588   , ("JOB_STATUS_ERROR",     "error")
 589   ])
 590 $(THH.makeJSONInstance ''JobStatus)
 591
 592 -- | Finalized job status.
 593 $(THH.declareLADT ''String "FinalizedJobStatus"
 594   [ ("JobStatusCanceled",   "canceled")
 595   , ("JobStatusSuccessful", "success")
 596   , ("JobStatusFailed",     "error")
 597   ])
 598 $(THH.makeJSONInstance ''FinalizedJobStatus)
 599
 600 -- | The Ganeti job type.
 601 newtype JobId = JobId { fromJobId :: Int }
 602   deriving (Show, Eq)
 603
 604 -- | Builds a job ID.
 605 makeJobId :: (Monad m) => Int -> m JobId
 606 makeJobId i | i >= 0 = return $ JobId i
 607             | otherwise = fail $ "Invalid value for job ID ' " ++ show i ++ "'"
 608
 609 -- | Builds a job ID from a string.
 610 makeJobIdS :: (Monad m) => String -> m JobId
 611 makeJobIdS s = tryRead "parsing job id" s >>= makeJobId
 612
 613 -- | Parses a job ID.
 614 parseJobId :: (Monad m) => JSON.JSValue -> m JobId
 615 parseJobId (JSON.JSString x) = makeJobIdS $ JSON.fromJSString x
 616 parseJobId (JSON.JSRational _ x) =
 617   if denominator x /= 1
 618     then fail $ "Got fractional job ID from master daemon?! Value:" ++ show x
 619     -- FIXME: potential integer overflow here on 32-bit platforms
 620     else makeJobId . fromIntegral . numerator $ x
 621 parseJobId x = fail $ "Wrong type/value for job id: " ++ show x
 622
 623 instance JSON.JSON JobId where
 624   showJSON = JSON.showJSON . fromJobId
 625   readJSON = parseJobId
 626
 627 -- | Relative job ID type alias.
 628 type RelativeJobId = Negative Int
 629
 630 -- | Job ID dependency.
 631 data JobIdDep = JobDepRelative RelativeJobId
 632               | JobDepAbsolute JobId
 633                 deriving (Show, Eq)
 634
 635 instance JSON.JSON JobIdDep where
 636   showJSON (JobDepRelative i) = showJSON i
 637   showJSON (JobDepAbsolute i) = showJSON i
 638   readJSON v =
 639     case JSON.readJSON v::JSON.Result (Negative Int) of
 640       -- first try relative dependency, usually most common
 641       JSON.Ok r -> return $ JobDepRelative r
 642       JSON.Error _ -> liftM JobDepAbsolute (parseJobId v)
 643
 644 -- | Job Dependency type.
 645 data JobDependency = JobDependency JobIdDep [FinalizedJobStatus]
 646                      deriving (Show, Eq)
 647
 648 instance JSON JobDependency where
 649   showJSON (JobDependency dep status) = showJSON (dep, status)
 650   readJSON = liftM (uncurry JobDependency) . readJSON
 651
 652 -- | Valid opcode priorities for submit.
 653 $(THH.declareIADT "OpSubmitPriority"
 654   [ ("OpPrioLow",    'ConstantUtils.priorityLow)
 655   , ("OpPrioNormal", 'ConstantUtils.priorityNormal)
 656   , ("OpPrioHigh",   'ConstantUtils.priorityHigh)
 657   ])
 658 $(THH.makeJSONInstance ''OpSubmitPriority)
 659
 660 -- | Parse submit priorities from a string.
 661 parseSubmitPriority :: (Monad m) => String -> m OpSubmitPriority
 662 parseSubmitPriority "low"    = return OpPrioLow
 663 parseSubmitPriority "normal" = return OpPrioNormal
 664 parseSubmitPriority "high"   = return OpPrioHigh
 665 parseSubmitPriority str      = fail $ "Unknown priority '" ++ str ++ "'"
 666
 667 -- | Format a submit priority as string.
 668 fmtSubmitPriority :: OpSubmitPriority -> String
 669 fmtSubmitPriority OpPrioLow    = "low"
 670 fmtSubmitPriority OpPrioNormal = "normal"
 671 fmtSubmitPriority OpPrioHigh   = "high"
 672
 673 -- | Our ADT for the OpCode status at runtime (while in a job).
 674 $(THH.declareLADT ''String "OpStatus"
 675   [ ("OP_STATUS_QUEUED",    "queued")
 676   , ("OP_STATUS_WAITING",   "waiting")
 677   , ("OP_STATUS_CANCELING", "canceling")
 678   , ("OP_STATUS_RUNNING",   "running")
 679   , ("OP_STATUS_CANCELED",  "canceled")
 680   , ("OP_STATUS_SUCCESS",   "success")
 681   , ("OP_STATUS_ERROR",     "error")
 682   ])
 683 $(THH.makeJSONInstance ''OpStatus)
 684
 685 -- | Type for the job message type.
 686 $(THH.declareLADT ''String "ELogType"
 687   [ ("ELogMessage",      "message")
 688   , ("ELogRemoteImport", "remote-import")
 689   , ("ELogJqueueTest",   "jqueue-test")
 690   ])
 691 $(THH.makeJSONInstance ''ELogType)
 692
 693 -- | Type of one element of a reason trail.
 694 type ReasonElem = (String, String, Integer)
 695
 696 -- | Type representing a reason trail.
 697 type ReasonTrail = [ReasonElem]
 698
 699 -- | The VTYPES, a mini-type system in Python.
 700 $(THH.declareLADT ''String "VType"
 701   [ ("VTypeString",      "string")
 702   , ("VTypeMaybeString", "maybe-string")
 703   , ("VTypeBool",        "bool")
 704   , ("VTypeSize",        "size")
 705   , ("VTypeInt",         "int")
 706   ])
 707 $(THH.makeJSONInstance ''VType)
 708
 709 -- * Node role type
 710
 711 $(THH.declareLADT ''String "NodeRole"
 712   [ ("NROffline",   "O")
 713   , ("NRDrained",   "D")
 714   , ("NRRegular",   "R")
 715   , ("NRCandidate", "C")
 716   , ("NRMaster",    "M")
 717   ])
 718 $(THH.makeJSONInstance ''NodeRole)
 719
 720 -- | The description of the node role.
 721 roleDescription :: NodeRole -> String
 722 roleDescription NROffline   = "offline"
 723 roleDescription NRDrained   = "drained"
 724 roleDescription NRRegular   = "regular"
 725 roleDescription NRCandidate = "master candidate"
 726 roleDescription NRMaster    = "master"
 727
 728 -- * Disk types
 729
 730 $(THH.declareLADT ''String "DiskMode"
 731   [ ("DiskRdOnly", "ro")
 732   , ("DiskRdWr",   "rw")
 733   ])
 734 $(THH.makeJSONInstance ''DiskMode)
 735
 736 -- | The persistent block driver type. Currently only one type is allowed.
 737 $(THH.declareLADT ''String "BlockDriver"
 738   [ ("BlockDrvManual", "manual")
 739   ])
 740 $(THH.makeJSONInstance ''BlockDriver)
 741
 742 -- * Instance types
 743
 744 $(THH.declareLADT ''String "AdminState"
 745   [ ("AdminOffline", "offline")
 746   , ("AdminDown",    "down")
 747   , ("AdminUp",      "up")
 748   ])
 749 $(THH.makeJSONInstance ''AdminState)
 750
 751 -- * Storage field type
 752
 753 $(THH.declareLADT ''String "StorageField"
 754   [ ( "SFUsed",        "used")
 755   , ( "SFName",        "name")
 756   , ( "SFAllocatable", "allocatable")
 757   , ( "SFFree",        "free")
 758   , ( "SFSize",        "size")
 759   ])
 760 $(THH.makeJSONInstance ''StorageField)