Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Types.hs @ 9c1c3c19

History | View | Annotate | Download (19.8 kB)

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
  ])
271
$(THH.makeJSONInstance ''CVErrorCode)
272

    
273
-- | Dynamic device modification, just add\/remove version.
274
$(THH.declareSADT "DdmSimple"
275
     [ ("DdmSimpleAdd",    'C.ddmAdd)
276
     , ("DdmSimpleRemove", 'C.ddmRemove)
277
     ])
278
$(THH.makeJSONInstance ''DdmSimple)
279

    
280
-- | Dynamic device modification, all operations version.
281
$(THH.declareSADT "DdmFull"
282
     [ ("DdmFullAdd",    'C.ddmAdd)
283
     , ("DdmFullRemove", 'C.ddmRemove)
284
     , ("DdmFullModify", 'C.ddmModify)
285
     ])
286
$(THH.makeJSONInstance ''DdmFull)
287

    
288
-- | Hypervisor type definitions.
289
$(THH.declareSADT "Hypervisor"
290
  [ ( "Kvm",    'C.htKvm )
291
  , ( "XenPvm", 'C.htXenPvm )
292
  , ( "Chroot", 'C.htChroot )
293
  , ( "XenHvm", 'C.htXenHvm )
294
  , ( "Lxc",    'C.htLxc )
295
  , ( "Fake",   'C.htFake )
296
  ])
297
$(THH.makeJSONInstance ''Hypervisor)
298

    
299
-- | Oob command type.
300
$(THH.declareSADT "OobCommand"
301
  [ ("OobHealth",      'C.oobHealth)
302
  , ("OobPowerCycle",  'C.oobPowerCycle)
303
  , ("OobPowerOff",    'C.oobPowerOff)
304
  , ("OobPowerOn",     'C.oobPowerOn)
305
  , ("OobPowerStatus", 'C.oobPowerStatus)
306
  ])
307
$(THH.makeJSONInstance ''OobCommand)
308

    
309
-- | Storage type.
310
$(THH.declareSADT "StorageType"
311
  [ ("StorageFile", 'C.stFile)
312
  , ("StorageLvmPv", 'C.stLvmPv)
313
  , ("StorageLvmVg", 'C.stLvmVg)
314
  , ("StorageDiskless", 'C.stDiskless)
315
  , ("StorageBlock", 'C.stBlock)
316
  , ("StorageRados", 'C.stRados)
317
  , ("StorageExt", 'C.stExt)
318
  ])
319
$(THH.makeJSONInstance ''StorageType)
320

    
321
-- | Storage keys are identifiers for storage units. Their content varies
322
-- depending on the storage type, for example a storage key for LVM storage
323
-- is the volume group name.
324
type StorageKey = String
325

    
326
-- | Storage parameters
327
type SPExclusiveStorage = Bool
328

    
329
-- | Storage units without storage-type-specific parameters
330
data StorageUnitRaw = SURaw StorageType StorageKey
331

    
332
-- | Full storage unit with storage-type-specific parameters
333
data StorageUnit = SUFile StorageKey
334
                 | SULvmPv StorageKey SPExclusiveStorage
335
                 | SULvmVg StorageKey SPExclusiveStorage
336
                 | SUDiskless StorageKey
337
                 | SUBlock StorageKey
338
                 | SURados StorageKey
339
                 | SUExt StorageKey
340
                 deriving (Eq)
341

    
342
instance Show StorageUnit where
343
  show (SUFile key) = showSUSimple StorageFile key
344
  show (SULvmPv key es) = showSULvm StorageLvmPv key es
345
  show (SULvmVg key es) = showSULvm StorageLvmVg key es
346
  show (SUDiskless key) = showSUSimple StorageDiskless key
347
  show (SUBlock key) = showSUSimple StorageBlock key
348
  show (SURados key) = showSUSimple StorageRados key
349
  show (SUExt key) = showSUSimple StorageExt key
350

    
351
instance JSON StorageUnit where
352
  showJSON (SUFile key) = showJSON (StorageFile, key, []::[String])
353
  showJSON (SULvmPv key es) = showJSON (StorageLvmPv, key, [es])
354
  showJSON (SULvmVg key es) = showJSON (StorageLvmVg, key, [es])
355
  showJSON (SUDiskless key) = showJSON (StorageDiskless, key, []::[String])
356
  showJSON (SUBlock key) = showJSON (StorageBlock, key, []::[String])
357
  showJSON (SURados key) = showJSON (StorageRados, key, []::[String])
358
  showJSON (SUExt key) = showJSON (StorageExt, key, []::[String])
359
-- FIXME: add readJSON implementation
360
  readJSON = fail "Not implemented"
361

    
362
-- | Composes a string representation of storage types without
363
-- storage parameters
364
showSUSimple :: StorageType -> StorageKey -> String
365
showSUSimple st sk = show (storageTypeToRaw st, sk, []::[String])
366

    
367
-- | Composes a string representation of the LVM storage types
368
showSULvm :: StorageType -> StorageKey -> SPExclusiveStorage -> String
369
showSULvm st sk es = show (storageTypeToRaw st, sk, [es])
370

    
371
-- | Mapping fo disk templates to storage type
372
-- FIXME: This is semantically the same as the constant
373
-- C.diskTemplatesStorageType, remove this when python constants
374
-- are generated from haskell constants
375
diskTemplateToStorageType :: DiskTemplate -> StorageType
376
diskTemplateToStorageType DTExt = StorageExt
377
diskTemplateToStorageType DTFile = StorageFile
378
diskTemplateToStorageType DTSharedFile = StorageFile
379
diskTemplateToStorageType DTDrbd8 = StorageLvmVg
380
diskTemplateToStorageType DTPlain = StorageLvmVg
381
diskTemplateToStorageType DTRbd = StorageRados
382
diskTemplateToStorageType DTDiskless = StorageDiskless
383
diskTemplateToStorageType DTBlock = StorageBlock
384

    
385
-- | Equips a raw storage unit with its parameters
386
addParamsToStorageUnit :: SPExclusiveStorage -> StorageUnitRaw -> StorageUnit
387
addParamsToStorageUnit _ (SURaw StorageBlock key) = SUBlock key
388
addParamsToStorageUnit _ (SURaw StorageDiskless key) = SUDiskless key
389
addParamsToStorageUnit _ (SURaw StorageExt key) = SUExt key
390
addParamsToStorageUnit _ (SURaw StorageFile key) = SUFile key
391
addParamsToStorageUnit es (SURaw StorageLvmPv key) = SULvmPv key es
392
addParamsToStorageUnit es (SURaw StorageLvmVg key) = SULvmVg key es
393
addParamsToStorageUnit _ (SURaw StorageRados key) = SURados key
394

    
395
-- | Node evac modes.
396
$(THH.declareSADT "NodeEvacMode"
397
  [ ("NEvacPrimary",   'C.iallocatorNevacPri)
398
  , ("NEvacSecondary", 'C.iallocatorNevacSec)
399
  , ("NEvacAll",       'C.iallocatorNevacAll)
400
  ])
401
$(THH.makeJSONInstance ''NodeEvacMode)
402

    
403
-- | The file driver type.
404
$(THH.declareSADT "FileDriver"
405
  [ ("FileLoop",   'C.fdLoop)
406
  , ("FileBlktap", 'C.fdBlktap)
407
  ])
408
$(THH.makeJSONInstance ''FileDriver)
409

    
410
-- | The instance create mode.
411
$(THH.declareSADT "InstCreateMode"
412
  [ ("InstCreate",       'C.instanceCreate)
413
  , ("InstImport",       'C.instanceImport)
414
  , ("InstRemoteImport", 'C.instanceRemoteImport)
415
  ])
416
$(THH.makeJSONInstance ''InstCreateMode)
417

    
418
-- | Reboot type.
419
$(THH.declareSADT "RebootType"
420
  [ ("RebootSoft", 'C.instanceRebootSoft)
421
  , ("RebootHard", 'C.instanceRebootHard)
422
  , ("RebootFull", 'C.instanceRebootFull)
423
  ])
424
$(THH.makeJSONInstance ''RebootType)
425

    
426
-- | Export modes.
427
$(THH.declareSADT "ExportMode"
428
  [ ("ExportModeLocal",  'C.exportModeLocal)
429
  , ("ExportModeRemove", 'C.exportModeRemote)
430
  ])
431
$(THH.makeJSONInstance ''ExportMode)
432

    
433
-- | IAllocator run types (OpTestIAllocator).
434
$(THH.declareSADT "IAllocatorTestDir"
435
  [ ("IAllocatorDirIn",  'C.iallocatorDirIn)
436
  , ("IAllocatorDirOut", 'C.iallocatorDirOut)
437
  ])
438
$(THH.makeJSONInstance ''IAllocatorTestDir)
439

    
440
-- | IAllocator mode. FIXME: use this in "HTools.Backend.IAlloc".
441
$(THH.declareSADT "IAllocatorMode"
442
  [ ("IAllocatorAlloc",       'C.iallocatorModeAlloc)
443
  , ("IAllocatorMultiAlloc",  'C.iallocatorModeMultiAlloc)
444
  , ("IAllocatorReloc",       'C.iallocatorModeReloc)
445
  , ("IAllocatorNodeEvac",    'C.iallocatorModeNodeEvac)
446
  , ("IAllocatorChangeGroup", 'C.iallocatorModeChgGroup)
447
  ])
448
$(THH.makeJSONInstance ''IAllocatorMode)
449

    
450
-- | Network mode.
451
$(THH.declareSADT "NICMode"
452
  [ ("NMBridged", 'C.nicModeBridged)
453
  , ("NMRouted",  'C.nicModeRouted)
454
  , ("NMOvs",     'C.nicModeOvs)
455
  ])
456
$(THH.makeJSONInstance ''NICMode)
457

    
458
-- | The JobStatus data type. Note that this is ordered especially
459
-- such that greater\/lesser comparison on values of this type makes
460
-- sense.
461
$(THH.declareSADT "JobStatus"
462
       [ ("JOB_STATUS_QUEUED",    'C.jobStatusQueued)
463
       , ("JOB_STATUS_WAITING",   'C.jobStatusWaiting)
464
       , ("JOB_STATUS_CANCELING", 'C.jobStatusCanceling)
465
       , ("JOB_STATUS_RUNNING",   'C.jobStatusRunning)
466
       , ("JOB_STATUS_CANCELED",  'C.jobStatusCanceled)
467
       , ("JOB_STATUS_SUCCESS",   'C.jobStatusSuccess)
468
       , ("JOB_STATUS_ERROR",     'C.jobStatusError)
469
       ])
470
$(THH.makeJSONInstance ''JobStatus)
471

    
472
-- | Finalized job status.
473
$(THH.declareSADT "FinalizedJobStatus"
474
  [ ("JobStatusCanceled",   'C.jobStatusCanceled)
475
  , ("JobStatusSuccessful", 'C.jobStatusSuccess)
476
  , ("JobStatusFailed",     'C.jobStatusError)
477
  ])
478
$(THH.makeJSONInstance ''FinalizedJobStatus)
479

    
480
-- | The Ganeti job type.
481
newtype JobId = JobId { fromJobId :: Int }
482
  deriving (Show, Eq)
483

    
484
-- | Builds a job ID.
485
makeJobId :: (Monad m) => Int -> m JobId
486
makeJobId i | i >= 0 = return $ JobId i
487
            | otherwise = fail $ "Invalid value for job ID ' " ++ show i ++ "'"
488

    
489
-- | Builds a job ID from a string.
490
makeJobIdS :: (Monad m) => String -> m JobId
491
makeJobIdS s = tryRead "parsing job id" s >>= makeJobId
492

    
493
-- | Parses a job ID.
494
parseJobId :: (Monad m) => JSON.JSValue -> m JobId
495
parseJobId (JSON.JSString x) = makeJobIdS $ JSON.fromJSString x
496
parseJobId (JSON.JSRational _ x) =
497
  if denominator x /= 1
498
    then fail $ "Got fractional job ID from master daemon?! Value:" ++ show x
499
    -- FIXME: potential integer overflow here on 32-bit platforms
500
    else makeJobId . fromIntegral . numerator $ x
501
parseJobId x = fail $ "Wrong type/value for job id: " ++ show x
502

    
503
instance JSON.JSON JobId where
504
  showJSON = JSON.showJSON . fromJobId
505
  readJSON = parseJobId
506

    
507
-- | Relative job ID type alias.
508
type RelativeJobId = Negative Int
509

    
510
-- | Job ID dependency.
511
data JobIdDep = JobDepRelative RelativeJobId
512
              | JobDepAbsolute JobId
513
                deriving (Show, Eq)
514

    
515
instance JSON.JSON JobIdDep where
516
  showJSON (JobDepRelative i) = showJSON i
517
  showJSON (JobDepAbsolute i) = showJSON i
518
  readJSON v =
519
    case JSON.readJSON v::JSON.Result (Negative Int) of
520
      -- first try relative dependency, usually most common
521
      JSON.Ok r -> return $ JobDepRelative r
522
      JSON.Error _ -> liftM JobDepAbsolute (parseJobId v)
523

    
524
-- | Job Dependency type.
525
data JobDependency = JobDependency JobIdDep [FinalizedJobStatus]
526
                     deriving (Show, Eq)
527

    
528
instance JSON JobDependency where
529
  showJSON (JobDependency dep status) = showJSON (dep, status)
530
  readJSON = liftM (uncurry JobDependency) . readJSON
531

    
532
-- | Valid opcode priorities for submit.
533
$(THH.declareIADT "OpSubmitPriority"
534
  [ ("OpPrioLow",    'C.opPrioLow)
535
  , ("OpPrioNormal", 'C.opPrioNormal)
536
  , ("OpPrioHigh",   'C.opPrioHigh)
537
  ])
538
$(THH.makeJSONInstance ''OpSubmitPriority)
539

    
540
-- | Parse submit priorities from a string.
541
parseSubmitPriority :: (Monad m) => String -> m OpSubmitPriority
542
parseSubmitPriority "low"    = return OpPrioLow
543
parseSubmitPriority "normal" = return OpPrioNormal
544
parseSubmitPriority "high"   = return OpPrioHigh
545
parseSubmitPriority str      = fail $ "Unknown priority '" ++ str ++ "'"
546

    
547
-- | Format a submit priority as string.
548
fmtSubmitPriority :: OpSubmitPriority -> String
549
fmtSubmitPriority OpPrioLow    = "low"
550
fmtSubmitPriority OpPrioNormal = "normal"
551
fmtSubmitPriority OpPrioHigh   = "high"
552

    
553
-- | Our ADT for the OpCode status at runtime (while in a job).
554
$(THH.declareSADT "OpStatus"
555
  [ ("OP_STATUS_QUEUED",    'C.opStatusQueued)
556
  , ("OP_STATUS_WAITING",   'C.opStatusWaiting)
557
  , ("OP_STATUS_CANCELING", 'C.opStatusCanceling)
558
  , ("OP_STATUS_RUNNING",   'C.opStatusRunning)
559
  , ("OP_STATUS_CANCELED",  'C.opStatusCanceled)
560
  , ("OP_STATUS_SUCCESS",   'C.opStatusSuccess)
561
  , ("OP_STATUS_ERROR",     'C.opStatusError)
562
  ])
563
$(THH.makeJSONInstance ''OpStatus)
564

    
565
-- | Type for the job message type.
566
$(THH.declareSADT "ELogType"
567
  [ ("ELogMessage",      'C.elogMessage)
568
  , ("ELogRemoteImport", 'C.elogRemoteImport)
569
  , ("ELogJqueueTest",   'C.elogJqueueTest)
570
  ])
571
$(THH.makeJSONInstance ''ELogType)
572

    
573
-- | Type of one element of a reason trail.
574
type ReasonElem = (String, String, Integer)
575

    
576
-- | Type representing a reason trail.
577
type ReasonTrail = [ReasonElem]