Types.hs 29.6 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
{-# LANGUAGE TemplateHaskell #-}

{-| Some common Ganeti types.

This holds types common to both core work, and to htools. Types that
are very core specific (e.g. configuration objects) should go in
'Ganeti.Objects', while types that are specific to htools in-memory
representation should go into 'Ganeti.HTools.Types'.

-}

{-

14
Copyright (C) 2012, 2013, 2014 Google Inc.
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.

-}

module Ganeti.Types
  ( AllocPolicy(..)
  , allocPolicyFromRaw
  , allocPolicyToRaw
  , InstanceStatus(..)
  , instanceStatusFromRaw
  , instanceStatusToRaw
  , DiskTemplate(..)
  , diskTemplateToRaw
  , diskTemplateFromRaw
43
44
45
  , TagKind(..)
  , tagKindToRaw
  , tagKindFromRaw
Iustin Pop's avatar
Iustin Pop committed
46
47
48
49
50
51
  , NonNegative
  , fromNonNegative
  , mkNonNegative
  , Positive
  , fromPositive
  , mkPositive
Iustin Pop's avatar
Iustin Pop committed
52
53
54
  , Negative
  , fromNegative
  , mkNegative
Iustin Pop's avatar
Iustin Pop committed
55
56
57
  , NonEmpty
  , fromNonEmpty
  , mkNonEmpty
Iustin Pop's avatar
Iustin Pop committed
58
  , NonEmptyString
59
60
61
62
63
64
65
66
67
  , QueryResultCode
  , IPv4Address
  , mkIPv4Address
  , IPv4Network
  , mkIPv4Network
  , IPv6Address
  , mkIPv6Address
  , IPv6Network
  , mkIPv6Network
Iustin Pop's avatar
Iustin Pop committed
68
  , MigrationMode(..)
69
  , migrationModeToRaw
Iustin Pop's avatar
Iustin Pop committed
70
  , VerifyOptionalChecks(..)
71
  , verifyOptionalChecksToRaw
Iustin Pop's avatar
Iustin Pop committed
72
  , DdmSimple(..)
73
  , DdmFull(..)
74
  , ddmFullToRaw
Iustin Pop's avatar
Iustin Pop committed
75
76
  , CVErrorCode(..)
  , cVErrorCodeToRaw
77
  , Hypervisor(..)
78
  , hypervisorToRaw
Iustin Pop's avatar
Iustin Pop committed
79
  , OobCommand(..)
80
  , oobCommandToRaw
81
82
  , OobStatus(..)
  , oobStatusToRaw
83
  , StorageType(..)
84
  , storageTypeToRaw
85
86
  , EvacMode(..)
  , evacModeToRaw
87
  , FileDriver(..)
88
  , fileDriverToRaw
89
  , InstCreateMode(..)
90
  , instCreateModeToRaw
91
  , RebootType(..)
92
  , rebootTypeToRaw
Iustin Pop's avatar
Iustin Pop committed
93
  , ExportMode(..)
94
  , exportModeToRaw
Iustin Pop's avatar
Iustin Pop committed
95
  , IAllocatorTestDir(..)
96
  , iAllocatorTestDirToRaw
Iustin Pop's avatar
Iustin Pop committed
97
98
  , IAllocatorMode(..)
  , iAllocatorModeToRaw
99
100
  , NICMode(..)
  , nICModeToRaw
101
102
103
  , JobStatus(..)
  , jobStatusToRaw
  , jobStatusFromRaw
104
105
  , FinalizedJobStatus(..)
  , finalizedJobStatusToRaw
Iustin Pop's avatar
Iustin Pop committed
106
107
108
  , JobId
  , fromJobId
  , makeJobId
109
  , makeJobIdS
110
111
112
  , RelativeJobId
  , JobIdDep(..)
  , JobDependency(..)
113
  , absoluteJobDependency
114
  , getJobIdFromDependency
115
  , OpSubmitPriority(..)
116
  , opSubmitPriorityToRaw
117
118
  , parseSubmitPriority
  , fmtSubmitPriority
119
120
121
  , OpStatus(..)
  , opStatusToRaw
  , opStatusFromRaw
122
  , ELogType(..)
123
  , eLogTypeToRaw
124
125
  , ReasonElem
  , ReasonTrail
126
127
128
129
130
  , StorageUnit(..)
  , StorageUnitRaw(..)
  , StorageKey
  , addParamsToStorageUnit
  , diskTemplateToStorageType
131
132
133
134
135
136
137
138
139
140
141
142
143
  , VType(..)
  , vTypeFromRaw
  , vTypeToRaw
  , NodeRole(..)
  , nodeRoleToRaw
  , roleDescription
  , DiskMode(..)
  , diskModeToRaw
  , BlockDriver(..)
  , blockDriverToRaw
  , AdminState(..)
  , adminStateFromRaw
  , adminStateToRaw
144
145
  , StorageField(..)
  , storageFieldToRaw
146
147
  , DiskAccessMode(..)
  , diskAccessModeToRaw
148
149
150
151
  , LocalDiskStatus(..)
  , localDiskStatusFromRaw
  , localDiskStatusToRaw
  , localDiskStatusName
152
153
  , ReplaceDisksMode(..)
  , replaceDisksModeToRaw
154
155
156
  , RpcTimeout(..)
  , rpcTimeoutFromRaw -- FIXME: no used anywhere
  , rpcTimeoutToRaw
157
158
  , ImportExportCompression(..)
  , importExportCompressionToRaw
159
160
161
162
  , HotplugTarget(..)
  , hotplugTargetToRaw
  , HotplugAction(..)
  , hotplugActionToRaw
163
164
  , Private(..)
  , showPrivateJSObject
165
166
  ) where

167
import Control.Monad (liftM)
Iustin Pop's avatar
Iustin Pop committed
168
import qualified Text.JSON as JSON
169
import Text.JSON (JSON, readJSON, showJSON)
Iustin Pop's avatar
Iustin Pop committed
170
import Data.Ratio (numerator, denominator)
Iustin Pop's avatar
Iustin Pop committed
171

172
import qualified Ganeti.ConstantUtils as ConstantUtils
173
import Ganeti.JSON
174
import qualified Ganeti.THH as THH
Iustin Pop's avatar
Iustin Pop committed
175
import Ganeti.Utils
176

Iustin Pop's avatar
Iustin Pop committed
177
178
179
180
-- * Generic types

-- | Type that holds a non-negative value.
newtype NonNegative a = NonNegative { fromNonNegative :: a }
181
  deriving (Show, Eq)
Iustin Pop's avatar
Iustin Pop committed
182
183
184
185
186
187
188
189
190
191
192
193
194

-- | Smart constructor for 'NonNegative'.
mkNonNegative :: (Monad m, Num a, Ord a, Show a) => a -> m (NonNegative a)
mkNonNegative i | i >= 0 = return (NonNegative i)
                | otherwise = fail $ "Invalid value for non-negative type '" ++
                              show i ++ "'"

instance (JSON.JSON a, Num a, Ord a, Show a) => JSON.JSON (NonNegative a) where
  showJSON = JSON.showJSON . fromNonNegative
  readJSON v = JSON.readJSON v >>= mkNonNegative

-- | Type that holds a positive value.
newtype Positive a = Positive { fromPositive :: a }
195
  deriving (Show, Eq)
Iustin Pop's avatar
Iustin Pop committed
196
197
198
199
200
201
202
203
204
205
206

-- | Smart constructor for 'Positive'.
mkPositive :: (Monad m, Num a, Ord a, Show a) => a -> m (Positive a)
mkPositive i | i > 0 = return (Positive i)
             | otherwise = fail $ "Invalid value for positive type '" ++
                           show i ++ "'"

instance (JSON.JSON a, Num a, Ord a, Show a) => JSON.JSON (Positive a) where
  showJSON = JSON.showJSON . fromPositive
  readJSON v = JSON.readJSON v >>= mkPositive

Iustin Pop's avatar
Iustin Pop committed
207
208
209
210
211
212
213
214
215
216
217
218
219
220
-- | Type that holds a negative value.
newtype Negative a = Negative { fromNegative :: a }
  deriving (Show, Eq)

-- | Smart constructor for 'Negative'.
mkNegative :: (Monad m, Num a, Ord a, Show a) => a -> m (Negative a)
mkNegative i | i < 0 = return (Negative i)
             | otherwise = fail $ "Invalid value for negative type '" ++
                           show i ++ "'"

instance (JSON.JSON a, Num a, Ord a, Show a) => JSON.JSON (Negative a) where
  showJSON = JSON.showJSON . fromNegative
  readJSON v = JSON.readJSON v >>= mkNegative

Iustin Pop's avatar
Iustin Pop committed
221
222
-- | Type that holds a non-null list.
newtype NonEmpty a = NonEmpty { fromNonEmpty :: [a] }
223
  deriving (Show, Eq)
Iustin Pop's avatar
Iustin Pop committed
224
225
226
227
228
229

-- | Smart constructor for 'NonEmpty'.
mkNonEmpty :: (Monad m) => [a] -> m (NonEmpty a)
mkNonEmpty [] = fail "Received empty value for non-empty list"
mkNonEmpty xs = return (NonEmpty xs)

230
231
232
233
instance (Eq a, Ord a) => Ord (NonEmpty a) where
  NonEmpty { fromNonEmpty = x1 } `compare` NonEmpty { fromNonEmpty = x2 } =
    x1 `compare` x2

Iustin Pop's avatar
Iustin Pop committed
234
235
236
237
instance (JSON.JSON a) => JSON.JSON (NonEmpty a) where
  showJSON = JSON.showJSON . fromNonEmpty
  readJSON v = JSON.readJSON v >>= mkNonEmpty

Iustin Pop's avatar
Iustin Pop committed
238
239
240
-- | A simple type alias for non-empty strings.
type NonEmptyString = NonEmpty Char

241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
type QueryResultCode = Int

newtype IPv4Address = IPv4Address { fromIPv4Address :: String }
  deriving (Show, Eq)

-- FIXME: this should check that 'address' is a valid ip
mkIPv4Address :: Monad m => String -> m IPv4Address
mkIPv4Address address =
  return IPv4Address { fromIPv4Address = address }

instance JSON.JSON IPv4Address where
  showJSON = JSON.showJSON . fromIPv4Address
  readJSON v = JSON.readJSON v >>= mkIPv4Address

newtype IPv4Network = IPv4Network { fromIPv4Network :: String }
  deriving (Show, Eq)

-- FIXME: this should check that 'address' is a valid ip
mkIPv4Network :: Monad m => String -> m IPv4Network
mkIPv4Network address =
  return IPv4Network { fromIPv4Network = address }

instance JSON.JSON IPv4Network where
  showJSON = JSON.showJSON . fromIPv4Network
  readJSON v = JSON.readJSON v >>= mkIPv4Network

newtype IPv6Address = IPv6Address { fromIPv6Address :: String }
  deriving (Show, Eq)

-- FIXME: this should check that 'address' is a valid ip
mkIPv6Address :: Monad m => String -> m IPv6Address
mkIPv6Address address =
  return IPv6Address { fromIPv6Address = address }

instance JSON.JSON IPv6Address where
  showJSON = JSON.showJSON . fromIPv6Address
  readJSON v = JSON.readJSON v >>= mkIPv6Address

newtype IPv6Network = IPv6Network { fromIPv6Network :: String }
  deriving (Show, Eq)

-- FIXME: this should check that 'address' is a valid ip
mkIPv6Network :: Monad m => String -> m IPv6Network
mkIPv6Network address =
  return IPv6Network { fromIPv6Network = address }

instance JSON.JSON IPv6Network where
  showJSON = JSON.showJSON . fromIPv6Network
  readJSON v = JSON.readJSON v >>= mkIPv6Network

Iustin Pop's avatar
Iustin Pop committed
291
292
-- * Ganeti types

293
-- | Instance disk template type.
294
295
296
297
298
299
300
301
302
$(THH.declareLADT ''String "DiskTemplate"
       [ ("DTDiskless",   "diskless")
       , ("DTFile",       "file")
       , ("DTSharedFile", "sharedfile")
       , ("DTPlain",      "plain")
       , ("DTBlock",      "blockdev")
       , ("DTDrbd8",      "drbd")
       , ("DTRbd",        "rbd")
       , ("DTExt",        "ext")
Santi Raffa's avatar
Santi Raffa committed
303
       , ("DTGluster",    "gluster")
304
305
306
       ])
$(THH.makeJSONInstance ''DiskTemplate)

307
308
309
instance THH.PyValue DiskTemplate where
  showValue = show . diskTemplateToRaw

310
311
312
313
instance HasStringRepr DiskTemplate where
  fromStringRepr = diskTemplateFromRaw
  toStringRepr = diskTemplateToRaw

314
-- | Data type representing what items the tag operations apply to.
315
316
317
318
319
$(THH.declareLADT ''String "TagKind"
  [ ("TagKindInstance", "instance")
  , ("TagKindNode",     "node")
  , ("TagKindGroup",    "nodegroup")
  , ("TagKindCluster",  "cluster")
320
  , ("TagKindNetwork",  "network")
321
322
323
  ])
$(THH.makeJSONInstance ''TagKind)

324
325
326
327
328
329
-- | The Group allocation policy type.
--
-- Note that the order of constructors is important as the automatic
-- Ord instance will order them in the order they are defined, so when
-- changing this data type be careful about the interaction with the
-- desired sorting order.
330
331
332
333
$(THH.declareLADT ''String "AllocPolicy"
       [ ("AllocPreferred",   "preferred")
       , ("AllocLastResort",  "last_resort")
       , ("AllocUnallocable", "unallocable")
334
335
336
       ])
$(THH.makeJSONInstance ''AllocPolicy)

Jose A. Lopes's avatar
Jose A. Lopes committed
337
-- | The Instance real state type.
338
339
340
341
342
343
344
345
$(THH.declareLADT ''String "InstanceStatus"
       [ ("StatusDown",    "ADMIN_down")
       , ("StatusOffline", "ADMIN_offline")
       , ("ErrorDown",     "ERROR_down")
       , ("ErrorUp",       "ERROR_up")
       , ("NodeDown",      "ERROR_nodedown")
       , ("NodeOffline",   "ERROR_nodeoffline")
       , ("Running",       "running")
Jose A. Lopes's avatar
Jose A. Lopes committed
346
       , ("UserDown",      "USER_down")
347
       , ("WrongNode",     "ERROR_wrongnode")
348
349
       ])
$(THH.makeJSONInstance ''InstanceStatus)
Iustin Pop's avatar
Iustin Pop committed
350
351

-- | Migration mode.
352
353
354
$(THH.declareLADT ''String "MigrationMode"
     [ ("MigrationLive",    "live")
     , ("MigrationNonLive", "non-live")
Iustin Pop's avatar
Iustin Pop committed
355
356
357
358
     ])
$(THH.makeJSONInstance ''MigrationMode)

-- | Verify optional checks.
359
360
$(THH.declareLADT ''String "VerifyOptionalChecks"
     [ ("VerifyNPlusOneMem", "nplusone_mem")
Iustin Pop's avatar
Iustin Pop committed
361
362
363
364
     ])
$(THH.makeJSONInstance ''VerifyOptionalChecks)

-- | Cluster verify error codes.
365
366
367
$(THH.declareLADT ''String "CVErrorCode"
  [ ("CvECLUSTERCFG",                  "ECLUSTERCFG")
  , ("CvECLUSTERCERT",                 "ECLUSTERCERT")
Helga Velroyen's avatar
Helga Velroyen committed
368
  , ("CvECLUSTERCLIENTCERT",           "ECLUSTERCLIENTCERT")
369
370
371
372
373
374
375
376
377
378
379
  , ("CvECLUSTERFILECHECK",            "ECLUSTERFILECHECK")
  , ("CvECLUSTERDANGLINGNODES",        "ECLUSTERDANGLINGNODES")
  , ("CvECLUSTERDANGLINGINST",         "ECLUSTERDANGLINGINST")
  , ("CvEINSTANCEBADNODE",             "EINSTANCEBADNODE")
  , ("CvEINSTANCEDOWN",                "EINSTANCEDOWN")
  , ("CvEINSTANCELAYOUT",              "EINSTANCELAYOUT")
  , ("CvEINSTANCEMISSINGDISK",         "EINSTANCEMISSINGDISK")
  , ("CvEINSTANCEFAULTYDISK",          "EINSTANCEFAULTYDISK")
  , ("CvEINSTANCEWRONGNODE",           "EINSTANCEWRONGNODE")
  , ("CvEINSTANCESPLITGROUPS",         "EINSTANCESPLITGROUPS")
  , ("CvEINSTANCEPOLICY",              "EINSTANCEPOLICY")
380
381
  , ("CvEINSTANCEUNSUITABLENODE",      "EINSTANCEUNSUITABLENODE")
  , ("CvEINSTANCEMISSINGCFGPARAMETER", "EINSTANCEMISSINGCFGPARAMETER")
382
  , ("CvENODEDRBD",                    "ENODEDRBD")
383
  , ("CvENODEDRBDVERSION",             "ENODEDRBDVERSION")
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
  , ("CvENODEDRBDHELPER",              "ENODEDRBDHELPER")
  , ("CvENODEFILECHECK",               "ENODEFILECHECK")
  , ("CvENODEHOOKS",                   "ENODEHOOKS")
  , ("CvENODEHV",                      "ENODEHV")
  , ("CvENODELVM",                     "ENODELVM")
  , ("CvENODEN1",                      "ENODEN1")
  , ("CvENODENET",                     "ENODENET")
  , ("CvENODEOS",                      "ENODEOS")
  , ("CvENODEORPHANINSTANCE",          "ENODEORPHANINSTANCE")
  , ("CvENODEORPHANLV",                "ENODEORPHANLV")
  , ("CvENODERPC",                     "ENODERPC")
  , ("CvENODESSH",                     "ENODESSH")
  , ("CvENODEVERSION",                 "ENODEVERSION")
  , ("CvENODESETUP",                   "ENODESETUP")
  , ("CvENODETIME",                    "ENODETIME")
  , ("CvENODEOOBPATH",                 "ENODEOOBPATH")
  , ("CvENODEUSERSCRIPTS",             "ENODEUSERSCRIPTS")
  , ("CvENODEFILESTORAGEPATHS",        "ENODEFILESTORAGEPATHS")
  , ("CvENODEFILESTORAGEPATHUNUSABLE", "ENODEFILESTORAGEPATHUNUSABLE")
403
  , ("CvENODESHAREDFILESTORAGEPATHUNUSABLE",
404
     "ENODESHAREDFILESTORAGEPATHUNUSABLE")
405
  , ("CvEGROUPDIFFERENTPVSIZE",        "EGROUPDIFFERENTPVSIZE")
Iustin Pop's avatar
Iustin Pop committed
406
407
408
  ])
$(THH.makeJSONInstance ''CVErrorCode)

409
-- | Dynamic device modification, just add/remove version.
410
411
412
$(THH.declareLADT ''String "DdmSimple"
     [ ("DdmSimpleAdd",    "add")
     , ("DdmSimpleRemove", "remove")
Iustin Pop's avatar
Iustin Pop committed
413
414
     ])
$(THH.makeJSONInstance ''DdmSimple)
415

416
-- | Dynamic device modification, all operations version.
417
418
--
-- TODO: DDM_SWAP, DDM_MOVE?
419
420
421
422
$(THH.declareLADT ''String "DdmFull"
     [ ("DdmFullAdd",    "add")
     , ("DdmFullRemove", "remove")
     , ("DdmFullModify", "modify")
423
424
425
     ])
$(THH.makeJSONInstance ''DdmFull)

426
-- | Hypervisor type definitions.
427
428
429
430
431
432
433
$(THH.declareLADT ''String "Hypervisor"
  [ ("Kvm",    "kvm")
  , ("XenPvm", "xen-pvm")
  , ("Chroot", "chroot")
  , ("XenHvm", "xen-hvm")
  , ("Lxc",    "lxc")
  , ("Fake",   "fake")
434
435
  ])
$(THH.makeJSONInstance ''Hypervisor)
436

437
438
439
instance THH.PyValue Hypervisor where
  showValue = show . hypervisorToRaw

440
441
442
443
instance HasStringRepr Hypervisor where
  fromStringRepr = hypervisorFromRaw
  toStringRepr = hypervisorToRaw

Iustin Pop's avatar
Iustin Pop committed
444
-- | Oob command type.
445
446
447
448
449
450
$(THH.declareLADT ''String "OobCommand"
  [ ("OobHealth",      "health")
  , ("OobPowerCycle",  "power-cycle")
  , ("OobPowerOff",    "power-off")
  , ("OobPowerOn",     "power-on")
  , ("OobPowerStatus", "power-status")
Iustin Pop's avatar
Iustin Pop committed
451
452
453
  ])
$(THH.makeJSONInstance ''OobCommand)

454
455
456
457
458
459
460
461
462
-- | Oob command status
$(THH.declareLADT ''String "OobStatus"
  [ ("OobStatusCritical", "CRITICAL")
  , ("OobStatusOk",       "OK")
  , ("OobStatusUnknown",  "UNKNOWN")
  , ("OobStatusWarning",  "WARNING")
  ])
$(THH.makeJSONInstance ''OobStatus)

463
-- | Storage type.
464
465
$(THH.declareLADT ''String "StorageType"
  [ ("StorageFile", "file")
466
  , ("StorageSharedFile", "sharedfile")
467
468
469
470
471
472
  , ("StorageLvmPv", "lvm-pv")
  , ("StorageLvmVg", "lvm-vg")
  , ("StorageDiskless", "diskless")
  , ("StorageBlock", "blockdev")
  , ("StorageRados", "rados")
  , ("StorageExt", "ext")
473
474
  ])
$(THH.makeJSONInstance ''StorageType)
Iustin Pop's avatar
Iustin Pop committed
475

476
477
478
479
480
481
482
483
484
485
486
487
488
-- | Storage keys are identifiers for storage units. Their content varies
-- depending on the storage type, for example a storage key for LVM storage
-- is the volume group name.
type StorageKey = String

-- | Storage parameters
type SPExclusiveStorage = Bool

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

-- | Full storage unit with storage-type-specific parameters
data StorageUnit = SUFile StorageKey
489
                 | SUSharedFile StorageKey
490
491
492
493
494
495
496
497
498
499
                 | SULvmPv StorageKey SPExclusiveStorage
                 | SULvmVg StorageKey SPExclusiveStorage
                 | SUDiskless StorageKey
                 | SUBlock StorageKey
                 | SURados StorageKey
                 | SUExt StorageKey
                 deriving (Eq)

instance Show StorageUnit where
  show (SUFile key) = showSUSimple StorageFile key
500
  show (SUSharedFile key) = showSUSimple StorageSharedFile key
501
502
503
504
505
506
507
508
509
  show (SULvmPv key es) = showSULvm StorageLvmPv key es
  show (SULvmVg key es) = showSULvm StorageLvmVg key es
  show (SUDiskless key) = showSUSimple StorageDiskless key
  show (SUBlock key) = showSUSimple StorageBlock key
  show (SURados key) = showSUSimple StorageRados key
  show (SUExt key) = showSUSimple StorageExt key

instance JSON StorageUnit where
  showJSON (SUFile key) = showJSON (StorageFile, key, []::[String])
510
  showJSON (SUSharedFile key) = showJSON (StorageSharedFile, key, []::[String])
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
  showJSON (SULvmPv key es) = showJSON (StorageLvmPv, key, [es])
  showJSON (SULvmVg key es) = showJSON (StorageLvmVg, key, [es])
  showJSON (SUDiskless key) = showJSON (StorageDiskless, key, []::[String])
  showJSON (SUBlock key) = showJSON (StorageBlock, key, []::[String])
  showJSON (SURados key) = showJSON (StorageRados, key, []::[String])
  showJSON (SUExt key) = showJSON (StorageExt, key, []::[String])
-- FIXME: add readJSON implementation
  readJSON = fail "Not implemented"

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

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

529
-- | Mapping from disk templates to storage types
530
531
532
533
534
535
-- FIXME: This is semantically the same as the constant
-- C.diskTemplatesStorageType, remove this when python constants
-- are generated from haskell constants
diskTemplateToStorageType :: DiskTemplate -> StorageType
diskTemplateToStorageType DTExt = StorageExt
diskTemplateToStorageType DTFile = StorageFile
536
diskTemplateToStorageType DTSharedFile = StorageSharedFile
537
538
539
540
541
diskTemplateToStorageType DTDrbd8 = StorageLvmVg
diskTemplateToStorageType DTPlain = StorageLvmVg
diskTemplateToStorageType DTRbd = StorageRados
diskTemplateToStorageType DTDiskless = StorageDiskless
diskTemplateToStorageType DTBlock = StorageBlock
542
diskTemplateToStorageType DTGluster = StorageSharedFile
543
544
545
546
547
548
549

-- | Equips a raw storage unit with its parameters
addParamsToStorageUnit :: SPExclusiveStorage -> StorageUnitRaw -> StorageUnit
addParamsToStorageUnit _ (SURaw StorageBlock key) = SUBlock key
addParamsToStorageUnit _ (SURaw StorageDiskless key) = SUDiskless key
addParamsToStorageUnit _ (SURaw StorageExt key) = SUExt key
addParamsToStorageUnit _ (SURaw StorageFile key) = SUFile key
550
addParamsToStorageUnit _ (SURaw StorageSharedFile key) = SUSharedFile key
551
552
553
554
addParamsToStorageUnit es (SURaw StorageLvmPv key) = SULvmPv key es
addParamsToStorageUnit es (SURaw StorageLvmVg key) = SULvmVg key es
addParamsToStorageUnit _ (SURaw StorageRados key) = SURados key

Iustin Pop's avatar
Iustin Pop committed
555
-- | Node evac modes.
556
557
558
559
--
-- This is part of the 'IAllocator' interface and it is used, for
-- example, in 'Ganeti.HTools.Loader.RqType'.  However, it must reside
-- in this module, and not in 'Ganeti.HTools.Types', because it is
560
-- also used by 'Ganeti.Constants'.
561
562
563
564
$(THH.declareLADT ''String "EvacMode"
  [ ("ChangePrimary",   "primary-only")
  , ("ChangeSecondary", "secondary-only")
  , ("ChangeAll",       "all")
Iustin Pop's avatar
Iustin Pop committed
565
  ])
566
$(THH.makeJSONInstance ''EvacMode)
567
568

-- | The file driver type.
569
570
571
$(THH.declareLADT ''String "FileDriver"
  [ ("FileLoop",   "loop")
  , ("FileBlktap", "blktap")
572
  , ("FileBlktap2", "blktap2")
573
574
  ])
$(THH.makeJSONInstance ''FileDriver)
575
576

-- | The instance create mode.
577
578
579
580
$(THH.declareLADT ''String "InstCreateMode"
  [ ("InstCreate",       "create")
  , ("InstImport",       "import")
  , ("InstRemoteImport", "remote-import")
581
582
  ])
$(THH.makeJSONInstance ''InstCreateMode)
583
584

-- | Reboot type.
585
586
587
588
$(THH.declareLADT ''String "RebootType"
  [ ("RebootSoft", "soft")
  , ("RebootHard", "hard")
  , ("RebootFull", "full")
589
590
  ])
$(THH.makeJSONInstance ''RebootType)
Iustin Pop's avatar
Iustin Pop committed
591
592

-- | Export modes.
593
594
$(THH.declareLADT ''String "ExportMode"
  [ ("ExportModeLocal",  "local")
595
  , ("ExportModeRemote", "remote")
Iustin Pop's avatar
Iustin Pop committed
596
597
  ])
$(THH.makeJSONInstance ''ExportMode)
Iustin Pop's avatar
Iustin Pop committed
598
599

-- | IAllocator run types (OpTestIAllocator).
600
601
602
$(THH.declareLADT ''String "IAllocatorTestDir"
  [ ("IAllocatorDirIn",  "in")
  , ("IAllocatorDirOut", "out")
Iustin Pop's avatar
Iustin Pop committed
603
604
605
606
  ])
$(THH.makeJSONInstance ''IAllocatorTestDir)

-- | IAllocator mode. FIXME: use this in "HTools.Backend.IAlloc".
607
608
609
610
611
612
$(THH.declareLADT ''String "IAllocatorMode"
  [ ("IAllocatorAlloc",       "allocate")
  , ("IAllocatorMultiAlloc",  "multi-allocate")
  , ("IAllocatorReloc",       "relocate")
  , ("IAllocatorNodeEvac",    "node-evacuate")
  , ("IAllocatorChangeGroup", "change-group")
Iustin Pop's avatar
Iustin Pop committed
613
614
  ])
$(THH.makeJSONInstance ''IAllocatorMode)
615

616
-- | Network mode.
617
618
619
620
$(THH.declareLADT ''String "NICMode"
  [ ("NMBridged", "bridged")
  , ("NMRouted",  "routed")
  , ("NMOvs",     "openvswitch")
621
  , ("NMPool",    "pool")
622
623
  ])
$(THH.makeJSONInstance ''NICMode)
624

625
626
627
-- | The JobStatus data type. Note that this is ordered especially
-- such that greater\/lesser comparison on values of this type makes
-- sense.
628
$(THH.declareLADT ''String "JobStatus"
Jose A. Lopes's avatar
Jose A. Lopes committed
629
630
631
632
633
634
635
636
  [ ("JOB_STATUS_QUEUED",    "queued")
  , ("JOB_STATUS_WAITING",   "waiting")
  , ("JOB_STATUS_CANCELING", "canceling")
  , ("JOB_STATUS_RUNNING",   "running")
  , ("JOB_STATUS_CANCELED",  "canceled")
  , ("JOB_STATUS_SUCCESS",   "success")
  , ("JOB_STATUS_ERROR",     "error")
  ])
637
638
$(THH.makeJSONInstance ''JobStatus)

639
-- | Finalized job status.
640
641
642
643
$(THH.declareLADT ''String "FinalizedJobStatus"
  [ ("JobStatusCanceled",   "canceled")
  , ("JobStatusSuccessful", "success")
  , ("JobStatusFailed",     "error")
644
645
  ])
$(THH.makeJSONInstance ''FinalizedJobStatus)
Iustin Pop's avatar
Iustin Pop committed
646
647
648

-- | The Ganeti job type.
newtype JobId = JobId { fromJobId :: Int }
Klaus Aehlig's avatar
Klaus Aehlig committed
649
  deriving (Show, Eq, Ord)
Iustin Pop's avatar
Iustin Pop committed
650
651
652
653
654
655

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

656
657
658
659
-- | Builds a job ID from a string.
makeJobIdS :: (Monad m) => String -> m JobId
makeJobIdS s = tryRead "parsing job id" s >>= makeJobId

Iustin Pop's avatar
Iustin Pop committed
660
661
-- | Parses a job ID.
parseJobId :: (Monad m) => JSON.JSValue -> m JobId
662
parseJobId (JSON.JSString x) = makeJobIdS $ JSON.fromJSString x
Iustin Pop's avatar
Iustin Pop committed
663
664
665
666
667
668
669
670
671
672
parseJobId (JSON.JSRational _ x) =
  if denominator x /= 1
    then fail $ "Got fractional job ID from master daemon?! Value:" ++ show x
    -- FIXME: potential integer overflow here on 32-bit platforms
    else makeJobId . fromIntegral . numerator $ x
parseJobId x = fail $ "Wrong type/value for job id: " ++ show x

instance JSON.JSON JobId where
  showJSON = JSON.showJSON . fromJobId
  readJSON = parseJobId
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688

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

-- | Job ID dependency.
data JobIdDep = JobDepRelative RelativeJobId
              | JobDepAbsolute JobId
                deriving (Show, Eq)

instance JSON.JSON JobIdDep where
  showJSON (JobDepRelative i) = showJSON i
  showJSON (JobDepAbsolute i) = showJSON i
  readJSON v =
    case JSON.readJSON v::JSON.Result (Negative Int) of
      -- first try relative dependency, usually most common
      JSON.Ok r -> return $ JobDepRelative r
689
      JSON.Error _ -> liftM JobDepAbsolute (parseJobId v)
690

691
692
693
694
-- | From job ID dependency and job ID, compute the absolute dependency.
absoluteJobIdDep :: (Monad m) => JobIdDep -> JobId -> m JobIdDep
absoluteJobIdDep (JobDepAbsolute jid) _ = return $ JobDepAbsolute jid
absoluteJobIdDep (JobDepRelative rjid) jid =
695
  liftM JobDepAbsolute . makeJobId $ fromJobId jid + fromNegative rjid
696

697
698
699
700
701
702
703
704
-- | Job Dependency type.
data JobDependency = JobDependency JobIdDep [FinalizedJobStatus]
                     deriving (Show, Eq)

instance JSON JobDependency where
  showJSON (JobDependency dep status) = showJSON (dep, status)
  readJSON = liftM (uncurry JobDependency) . readJSON

705
706
707
-- | From job dependency and job id compute an absolute job dependency.
absoluteJobDependency :: (Monad m) => JobDependency -> JobId -> m JobDependency
absoluteJobDependency (JobDependency jdep fstats) jid =
708
  liftM (flip JobDependency fstats) $ absoluteJobIdDep jdep jid
709

710
711
712
713
714
715
-- | From a job dependency get the absolute job id it depends on,
-- if given absolutely.
getJobIdFromDependency :: JobDependency -> [JobId]
getJobIdFromDependency (JobDependency (JobDepAbsolute jid) _) = [jid]
getJobIdFromDependency _ = []

716
717
-- | Valid opcode priorities for submit.
$(THH.declareIADT "OpSubmitPriority"
718
719
720
  [ ("OpPrioLow",    'ConstantUtils.priorityLow)
  , ("OpPrioNormal", 'ConstantUtils.priorityNormal)
  , ("OpPrioHigh",   'ConstantUtils.priorityHigh)
721
722
  ])
$(THH.makeJSONInstance ''OpSubmitPriority)
723

724
725
726
727
728
729
730
731
732
733
734
735
736
-- | Parse submit priorities from a string.
parseSubmitPriority :: (Monad m) => String -> m OpSubmitPriority
parseSubmitPriority "low"    = return OpPrioLow
parseSubmitPriority "normal" = return OpPrioNormal
parseSubmitPriority "high"   = return OpPrioHigh
parseSubmitPriority str      = fail $ "Unknown priority '" ++ str ++ "'"

-- | Format a submit priority as string.
fmtSubmitPriority :: OpSubmitPriority -> String
fmtSubmitPriority OpPrioLow    = "low"
fmtSubmitPriority OpPrioNormal = "normal"
fmtSubmitPriority OpPrioHigh   = "high"

737
-- | Our ADT for the OpCode status at runtime (while in a job).
738
739
740
741
742
743
744
745
$(THH.declareLADT ''String "OpStatus"
  [ ("OP_STATUS_QUEUED",    "queued")
  , ("OP_STATUS_WAITING",   "waiting")
  , ("OP_STATUS_CANCELING", "canceling")
  , ("OP_STATUS_RUNNING",   "running")
  , ("OP_STATUS_CANCELED",  "canceled")
  , ("OP_STATUS_SUCCESS",   "success")
  , ("OP_STATUS_ERROR",     "error")
746
  ])
747
$(THH.makeJSONInstance ''OpStatus)
748
749

-- | Type for the job message type.
750
751
752
753
$(THH.declareLADT ''String "ELogType"
  [ ("ELogMessage",      "message")
  , ("ELogRemoteImport", "remote-import")
  , ("ELogJqueueTest",   "jqueue-test")
Hrvoje Ribicic's avatar
Hrvoje Ribicic committed
754
  , ("ELogDelayTest",    "delay-test")
755
756
  ])
$(THH.makeJSONInstance ''ELogType)
757
758
759
760
761
762

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

-- | Type representing a reason trail.
type ReasonTrail = [ReasonElem]
763
764
765
766
767
768
769
770

-- | The VTYPES, a mini-type system in Python.
$(THH.declareLADT ''String "VType"
  [ ("VTypeString",      "string")
  , ("VTypeMaybeString", "maybe-string")
  , ("VTypeBool",        "bool")
  , ("VTypeSize",        "size")
  , ("VTypeInt",         "int")
Klaus Aehlig's avatar
Klaus Aehlig committed
771
  , ("VTypeFloat",       "float")
772
773
774
  ])
$(THH.makeJSONInstance ''VType)

775
776
777
instance THH.PyValue VType where
  showValue = THH.showValue . vTypeToRaw

778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
-- * Node role type

$(THH.declareLADT ''String "NodeRole"
  [ ("NROffline",   "O")
  , ("NRDrained",   "D")
  , ("NRRegular",   "R")
  , ("NRCandidate", "C")
  , ("NRMaster",    "M")
  ])
$(THH.makeJSONInstance ''NodeRole)

-- | The description of the node role.
roleDescription :: NodeRole -> String
roleDescription NROffline   = "offline"
roleDescription NRDrained   = "drained"
roleDescription NRRegular   = "regular"
roleDescription NRCandidate = "master candidate"
roleDescription NRMaster    = "master"

-- * Disk types

$(THH.declareLADT ''String "DiskMode"
  [ ("DiskRdOnly", "ro")
  , ("DiskRdWr",   "rw")
  ])
$(THH.makeJSONInstance ''DiskMode)

-- | The persistent block driver type. Currently only one type is allowed.
$(THH.declareLADT ''String "BlockDriver"
  [ ("BlockDrvManual", "manual")
  ])
$(THH.makeJSONInstance ''BlockDriver)

-- * Instance types

$(THH.declareLADT ''String "AdminState"
  [ ("AdminOffline", "offline")
  , ("AdminDown",    "down")
  , ("AdminUp",      "up")
  ])
$(THH.makeJSONInstance ''AdminState)
819
820
821
822
823
824
825
826
827
828
829

-- * Storage field type

$(THH.declareLADT ''String "StorageField"
  [ ( "SFUsed",        "used")
  , ( "SFName",        "name")
  , ( "SFAllocatable", "allocatable")
  , ( "SFFree",        "free")
  , ( "SFSize",        "size")
  ])
$(THH.makeJSONInstance ''StorageField)
830
831
832
833
834
835
836
837

-- * Disk access protocol

$(THH.declareLADT ''String "DiskAccessMode"
  [ ( "DiskUserspace",   "userspace")
  , ( "DiskKernelspace", "kernelspace")
  ])
$(THH.makeJSONInstance ''DiskAccessMode)
838

839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
-- | Local disk status
--
-- Python code depends on:
--   DiskStatusOk < DiskStatusUnknown < DiskStatusFaulty
$(THH.declareILADT "LocalDiskStatus"
  [ ("DiskStatusFaulty",  3)
  , ("DiskStatusOk",      1)
  , ("DiskStatusUnknown", 2)
  ])

localDiskStatusName :: LocalDiskStatus -> String
localDiskStatusName DiskStatusFaulty = "faulty"
localDiskStatusName DiskStatusOk = "ok"
localDiskStatusName DiskStatusUnknown = "unknown"

854
855
856
857
858
859
860
861
862
863
864
-- | Replace disks type.
$(THH.declareLADT ''String "ReplaceDisksMode"
  [ -- Replace disks on primary
    ("ReplaceOnPrimary",    "replace_on_primary")
    -- Replace disks on secondary
  , ("ReplaceOnSecondary",  "replace_on_secondary")
    -- Change secondary node
  , ("ReplaceNewSecondary", "replace_new_secondary")
  , ("ReplaceAuto",         "replace_auto")
  ])
$(THH.makeJSONInstance ''ReplaceDisksMode)
865
866
867
868
869
870
871
872
873
874

-- | Basic timeouts for RPC calls.
$(THH.declareILADT "RpcTimeout"
  [ ("Urgent",    60)       -- 1 minute
  , ("Fast",      5 * 60)   -- 5 minutes
  , ("Normal",    15 * 60)  -- 15 minutes
  , ("Slow",      3600)     -- 1 hour
  , ("FourHours", 4 * 3600) -- 4 hours
  , ("OneDay",    86400)    -- 1 day
  ])
875
876
877
878
879
880
881
882
883
884
885

$(THH.declareLADT ''String "ImportExportCompression"
  [ -- No compression
    ("None", "none")
    -- gzip compression
  , ("GZip", "gzip")
  ])
$(THH.makeJSONInstance ''ImportExportCompression)

instance THH.PyValue ImportExportCompression where
  showValue = THH.showValue . importExportCompressionToRaw
886

887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
-- | Hotplug action.

$(THH.declareLADT ''String "HotplugAction"
  [ ("HAAdd", "hotadd")
  , ("HARemove",  "hotremove")
  , ("HAMod",     "hotmod")
  ])
$(THH.makeJSONInstance ''HotplugAction)

-- | Hotplug Device Target.

$(THH.declareLADT ''String "HotplugTarget"
  [ ("HTDisk", "hotdisk")
  , ("HTNic",  "hotnic")
  ])
$(THH.makeJSONInstance ''HotplugTarget)
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935

-- * Private type and instances

-- | A container for values that should be happy to be manipulated yet
-- refuses to be shown unless explicitly requested.
newtype Private a = Private { getPrivate :: a }
  deriving Eq

instance (Show a, JSON.JSON a) => JSON.JSON (Private a) where
  readJSON = liftM Private . JSON.readJSON
  showJSON (Private x) = JSON.showJSON x

-- | "Show" the value of the field.
--
-- It would be better not to implement this at all.
-- Alas, Show OpCode requires Show Private.
instance Show a => Show (Private a) where
  show _ = "<redacted>"

instance THH.PyValue a => THH.PyValue (Private a) where
  showValue (Private x) = "Private(" ++ THH.showValue x ++ ")"

instance Functor Private where
  fmap f (Private x) = Private $ f x

instance Monad Private where
  (Private x) >>= f = f x
  return = Private

showPrivateJSObject :: (JSON.JSON a) =>
                       [(String, a)] -> JSON.JSObject (Private JSON.JSValue)
showPrivateJSObject value = JSON.toJSObject $ map f value
  where f (k, v) = (k, Private $ JSON.showJSON v)