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