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