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