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

{-| 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
All rights reserved.
16

17 18 19
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
20

21 22
1. Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
23

24 25 26 27 28 29 30 31 32 33 34 35 36 37 38
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
39 40 41 42 43 44 45 46 47 48 49 50 51

-}

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

191
import Control.Applicative
192
import Control.Monad (liftM)
193
import qualified Text.JSON as JSON
194
import Text.JSON (JSON, readJSON, showJSON)
195
import Data.Ratio (numerator, denominator)
196 197
import qualified Data.Set as Set
import System.Time (ClockTime)
198

199
import qualified Ganeti.ConstantUtils as ConstantUtils
200
import Ganeti.JSON
201
import qualified Ganeti.THH as THH
202
import Ganeti.Utils
203

204 205 206 207
-- * Generic types

-- | Type that holds a non-negative value.
newtype NonNegative a = NonNegative { fromNonNegative :: a }
208
  deriving (Show, Eq, Ord)
209 210 211 212 213 214 215 216 217 218 219 220 221

-- | 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 }
222
  deriving (Show, Eq, Ord)
223 224 225 226 227 228 229 230 231 232 233

-- | 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
234 235
-- | Type that holds a negative value.
newtype Negative a = Negative { fromNegative :: a }
236
  deriving (Show, Eq, Ord)
Iustin Pop's avatar
Iustin Pop committed
237 238 239 240 241 242 243 244 245 246 247

-- | 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

248 249
-- | Type that holds a non-null list.
newtype NonEmpty a = NonEmpty { fromNonEmpty :: [a] }
250
  deriving (Show, Eq, Ord)
251 252 253 254 255 256 257 258 259 260

-- | 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)

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
261 262 263
-- | A simple type alias for non-empty strings.
type NonEmptyString = NonEmpty Char

264 265 266
type QueryResultCode = Int

newtype IPv4Address = IPv4Address { fromIPv4Address :: String }
267
  deriving (Show, Eq, Ord)
268 269 270 271 272 273 274 275 276 277 278

-- 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 }
279
  deriving (Show, Eq, Ord)
280 281 282 283 284 285 286 287 288 289 290

-- 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 }
291
  deriving (Show, Eq, Ord)
292 293 294 295 296 297 298 299 300 301 302

-- 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 }
303
  deriving (Show, Eq, Ord)
304 305 306 307 308 309 310 311 312 313

-- 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

314 315
-- * Ganeti types

316 317 318
-- | Instance disk template type. The disk template is a name for the
-- constructor of the disk configuration 'DiskLogicalId' used for
-- serialization, configuration values, etc.
319 320 321 322 323 324 325 326 327
$(THH.declareLADT ''String "DiskTemplate"
       [ ("DTDiskless",   "diskless")
       , ("DTFile",       "file")
       , ("DTSharedFile", "sharedfile")
       , ("DTPlain",      "plain")
       , ("DTBlock",      "blockdev")
       , ("DTDrbd8",      "drbd")
       , ("DTRbd",        "rbd")
       , ("DTExt",        "ext")
328
       , ("DTGluster",    "gluster")
329 330 331
       ])
$(THH.makeJSONInstance ''DiskTemplate)

332 333 334
instance THH.PyValue DiskTemplate where
  showValue = show . diskTemplateToRaw

335 336 337 338
instance HasStringRepr DiskTemplate where
  fromStringRepr = diskTemplateFromRaw
  toStringRepr = diskTemplateToRaw

339 340 341 342 343 344 345 346 347 348 349 350 351 352 353
-- | Predicate on disk templates indicating if instances based on this
-- disk template can freely be moved (to any node in the node group).
diskTemplateMovable :: DiskTemplate -> Bool
-- Note: we deliberately do not use wildcard pattern to force an
-- update of this function whenever a new disk template is added.
diskTemplateMovable DTDiskless    = True
diskTemplateMovable DTFile        = False
diskTemplateMovable DTSharedFile  = True
diskTemplateMovable DTPlain       = False
diskTemplateMovable DTBlock       = False
diskTemplateMovable DTDrbd8       = False
diskTemplateMovable DTRbd         = True
diskTemplateMovable DTExt         = True
diskTemplateMovable DTGluster     = True

354
-- | Data type representing what items the tag operations apply to.
355 356 357 358 359
$(THH.declareLADT ''String "TagKind"
  [ ("TagKindInstance", "instance")
  , ("TagKindNode",     "node")
  , ("TagKindGroup",    "nodegroup")
  , ("TagKindCluster",  "cluster")
360
  , ("TagKindNetwork",  "network")
361 362 363
  ])
$(THH.makeJSONInstance ''TagKind)

364 365 366 367 368 369
-- | 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.
370 371 372 373
$(THH.declareLADT ''String "AllocPolicy"
       [ ("AllocPreferred",   "preferred")
       , ("AllocLastResort",  "last_resort")
       , ("AllocUnallocable", "unallocable")
374 375 376
       ])
$(THH.makeJSONInstance ''AllocPolicy)

377
-- | The Instance real state type.
378 379 380 381 382 383 384 385
$(THH.declareLADT ''String "InstanceStatus"
       [ ("StatusDown",    "ADMIN_down")
       , ("StatusOffline", "ADMIN_offline")
       , ("ErrorDown",     "ERROR_down")
       , ("ErrorUp",       "ERROR_up")
       , ("NodeDown",      "ERROR_nodedown")
       , ("NodeOffline",   "ERROR_nodeoffline")
       , ("Running",       "running")
386
       , ("UserDown",      "USER_down")
387
       , ("WrongNode",     "ERROR_wrongnode")
388 389
       ])
$(THH.makeJSONInstance ''InstanceStatus)
Iustin Pop's avatar
Iustin Pop committed
390 391

-- | Migration mode.
392 393 394
$(THH.declareLADT ''String "MigrationMode"
     [ ("MigrationLive",    "live")
     , ("MigrationNonLive", "non-live")
Iustin Pop's avatar
Iustin Pop committed
395 396 397 398
     ])
$(THH.makeJSONInstance ''MigrationMode)

-- | Verify optional checks.
399 400
$(THH.declareLADT ''String "VerifyOptionalChecks"
     [ ("VerifyNPlusOneMem", "nplusone_mem")
Iustin Pop's avatar
Iustin Pop committed
401 402 403 404
     ])
$(THH.makeJSONInstance ''VerifyOptionalChecks)

-- | Cluster verify error codes.
405 406 407
$(THH.declareLADT ''String "CVErrorCode"
  [ ("CvECLUSTERCFG",                  "ECLUSTERCFG")
  , ("CvECLUSTERCERT",                 "ECLUSTERCERT")
408
  , ("CvECLUSTERCLIENTCERT",           "ECLUSTERCLIENTCERT")
409 410 411 412 413 414 415 416 417 418 419
  , ("CvECLUSTERFILECHECK",            "ECLUSTERFILECHECK")
  , ("CvECLUSTERDANGLINGNODES",        "ECLUSTERDANGLINGNODES")
  , ("CvECLUSTERDANGLINGINST",         "ECLUSTERDANGLINGINST")
  , ("CvEINSTANCEBADNODE",             "EINSTANCEBADNODE")
  , ("CvEINSTANCEDOWN",                "EINSTANCEDOWN")
  , ("CvEINSTANCELAYOUT",              "EINSTANCELAYOUT")
  , ("CvEINSTANCEMISSINGDISK",         "EINSTANCEMISSINGDISK")
  , ("CvEINSTANCEFAULTYDISK",          "EINSTANCEFAULTYDISK")
  , ("CvEINSTANCEWRONGNODE",           "EINSTANCEWRONGNODE")
  , ("CvEINSTANCESPLITGROUPS",         "EINSTANCESPLITGROUPS")
  , ("CvEINSTANCEPOLICY",              "EINSTANCEPOLICY")
420 421
  , ("CvEINSTANCEUNSUITABLENODE",      "EINSTANCEUNSUITABLENODE")
  , ("CvEINSTANCEMISSINGCFGPARAMETER", "EINSTANCEMISSINGCFGPARAMETER")
422
  , ("CvENODEDRBD",                    "ENODEDRBD")
423
  , ("CvENODEDRBDVERSION",             "ENODEDRBDVERSION")
424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442
  , ("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")
443
  , ("CvENODESHAREDFILESTORAGEPATHUNUSABLE",
444
     "ENODESHAREDFILESTORAGEPATHUNUSABLE")
445 446
  , ("CvENODEGLUSTERSTORAGEPATHUNUSABLE",
     "ENODEGLUSTERSTORAGEPATHUNUSABLE")
447
  , ("CvEGROUPDIFFERENTPVSIZE",        "EGROUPDIFFERENTPVSIZE")
448
  , ("CvEEXTAGS",                      "EEXTAGS")
Iustin Pop's avatar
Iustin Pop committed
449 450 451
  ])
$(THH.makeJSONInstance ''CVErrorCode)

452
-- | Dynamic device modification, just add/remove version.
453 454
$(THH.declareLADT ''String "DdmSimple"
     [ ("DdmSimpleAdd",    "add")
455
     , ("DdmSimpleAttach", "attach")
456
     , ("DdmSimpleRemove", "remove")
457
     , ("DdmSimpleDetach", "detach")
Iustin Pop's avatar
Iustin Pop committed
458 459
     ])
$(THH.makeJSONInstance ''DdmSimple)
460

461
-- | Dynamic device modification, all operations version.
462 463
--
-- TODO: DDM_SWAP, DDM_MOVE?
464 465
$(THH.declareLADT ''String "DdmFull"
     [ ("DdmFullAdd",    "add")
466
     , ("DdmFullAttach", "attach")
467
     , ("DdmFullRemove", "remove")
468
     , ("DdmFullDetach", "detach")
469
     , ("DdmFullModify", "modify")
470 471 472
     ])
$(THH.makeJSONInstance ''DdmFull)

473
-- | Hypervisor type definitions.
474 475 476 477 478 479 480
$(THH.declareLADT ''String "Hypervisor"
  [ ("Kvm",    "kvm")
  , ("XenPvm", "xen-pvm")
  , ("Chroot", "chroot")
  , ("XenHvm", "xen-hvm")
  , ("Lxc",    "lxc")
  , ("Fake",   "fake")
481 482
  ])
$(THH.makeJSONInstance ''Hypervisor)
483

484 485 486
instance THH.PyValue Hypervisor where
  showValue = show . hypervisorToRaw

487 488 489 490
instance HasStringRepr Hypervisor where
  fromStringRepr = hypervisorFromRaw
  toStringRepr = hypervisorToRaw

Iustin Pop's avatar
Iustin Pop committed
491
-- | Oob command type.
492 493 494 495 496 497
$(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
498 499 500
  ])
$(THH.makeJSONInstance ''OobCommand)

501 502 503 504 505 506 507 508 509
-- | Oob command status
$(THH.declareLADT ''String "OobStatus"
  [ ("OobStatusCritical", "CRITICAL")
  , ("OobStatusOk",       "OK")
  , ("OobStatusUnknown",  "UNKNOWN")
  , ("OobStatusWarning",  "WARNING")
  ])
$(THH.makeJSONInstance ''OobStatus)

510
-- | Storage type.
511 512
$(THH.declareLADT ''String "StorageType"
  [ ("StorageFile", "file")
513
  , ("StorageSharedFile", "sharedfile")
514
  , ("StorageGluster", "gluster")
515 516 517 518 519 520
  , ("StorageLvmPv", "lvm-pv")
  , ("StorageLvmVg", "lvm-vg")
  , ("StorageDiskless", "diskless")
  , ("StorageBlock", "blockdev")
  , ("StorageRados", "rados")
  , ("StorageExt", "ext")
521 522
  ])
$(THH.makeJSONInstance ''StorageType)
Iustin Pop's avatar
Iustin Pop committed
523

524 525 526 527 528 529 530 531 532 533 534 535 536
-- | 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
537
                 | SUSharedFile StorageKey
538
                 | SUGluster StorageKey
539 540 541 542 543 544 545 546 547 548
                 | 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
549
  show (SUSharedFile key) = showSUSimple StorageSharedFile key
550
  show (SUGluster key) = showSUSimple StorageGluster key
551 552 553 554 555 556 557 558 559
  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])
560
  showJSON (SUSharedFile key) = showJSON (StorageSharedFile, key, []::[String])
561
  showJSON (SUGluster key) = showJSON (StorageGluster, key, []::[String])
562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579
  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])

580
-- | Mapping from disk templates to storage types.
581 582 583
diskTemplateToStorageType :: DiskTemplate -> StorageType
diskTemplateToStorageType DTExt = StorageExt
diskTemplateToStorageType DTFile = StorageFile
584
diskTemplateToStorageType DTSharedFile = StorageSharedFile
585 586 587 588 589
diskTemplateToStorageType DTDrbd8 = StorageLvmVg
diskTemplateToStorageType DTPlain = StorageLvmVg
diskTemplateToStorageType DTRbd = StorageRados
diskTemplateToStorageType DTDiskless = StorageDiskless
diskTemplateToStorageType DTBlock = StorageBlock
590
diskTemplateToStorageType DTGluster = StorageGluster
591 592 593 594 595 596 597

-- | 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
598
addParamsToStorageUnit _ (SURaw StorageSharedFile key) = SUSharedFile key
599
addParamsToStorageUnit _ (SURaw StorageGluster key) = SUGluster key
600 601 602 603
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
604
-- | Node evac modes.
605 606 607 608
--
-- 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
609
-- also used by 'Ganeti.Constants'.
610 611 612 613
$(THH.declareLADT ''String "EvacMode"
  [ ("ChangePrimary",   "primary-only")
  , ("ChangeSecondary", "secondary-only")
  , ("ChangeAll",       "all")
Iustin Pop's avatar
Iustin Pop committed
614
  ])
615
$(THH.makeJSONInstance ''EvacMode)
616 617

-- | The file driver type.
618 619 620
$(THH.declareLADT ''String "FileDriver"
  [ ("FileLoop",   "loop")
  , ("FileBlktap", "blktap")
621
  , ("FileBlktap2", "blktap2")
622 623
  ])
$(THH.makeJSONInstance ''FileDriver)
624 625

-- | The instance create mode.
626 627 628 629
$(THH.declareLADT ''String "InstCreateMode"
  [ ("InstCreate",       "create")
  , ("InstImport",       "import")
  , ("InstRemoteImport", "remote-import")
630 631
  ])
$(THH.makeJSONInstance ''InstCreateMode)
632 633

-- | Reboot type.
634 635 636 637
$(THH.declareLADT ''String "RebootType"
  [ ("RebootSoft", "soft")
  , ("RebootHard", "hard")
  , ("RebootFull", "full")
638 639
  ])
$(THH.makeJSONInstance ''RebootType)
640 641

-- | Export modes.
642 643
$(THH.declareLADT ''String "ExportMode"
  [ ("ExportModeLocal",  "local")
644
  , ("ExportModeRemote", "remote")
645 646
  ])
$(THH.makeJSONInstance ''ExportMode)
Iustin Pop's avatar
Iustin Pop committed
647 648

-- | IAllocator run types (OpTestIAllocator).
649 650 651
$(THH.declareLADT ''String "IAllocatorTestDir"
  [ ("IAllocatorDirIn",  "in")
  , ("IAllocatorDirOut", "out")
Iustin Pop's avatar
Iustin Pop committed
652 653 654 655
  ])
$(THH.makeJSONInstance ''IAllocatorTestDir)

-- | IAllocator mode. FIXME: use this in "HTools.Backend.IAlloc".
656 657
$(THH.declareLADT ''String "IAllocatorMode"
  [ ("IAllocatorAlloc",       "allocate")
658
  , ("IAllocatorAllocateSecondary", "allocate-secondary")
659 660 661 662
  , ("IAllocatorMultiAlloc",  "multi-allocate")
  , ("IAllocatorReloc",       "relocate")
  , ("IAllocatorNodeEvac",    "node-evacuate")
  , ("IAllocatorChangeGroup", "change-group")
Iustin Pop's avatar
Iustin Pop committed
663 664
  ])
$(THH.makeJSONInstance ''IAllocatorMode)
665

666
-- | Network mode.
667 668 669 670
$(THH.declareLADT ''String "NICMode"
  [ ("NMBridged", "bridged")
  , ("NMRouted",  "routed")
  , ("NMOvs",     "openvswitch")
671
  , ("NMPool",    "pool")
672 673
  ])
$(THH.makeJSONInstance ''NICMode)
674

675 676 677
-- | The JobStatus data type. Note that this is ordered especially
-- such that greater\/lesser comparison on values of this type makes
-- sense.
678
$(THH.declareLADT ''String "JobStatus"
Jose A. Lopes's avatar
Jose A. Lopes committed
679 680 681 682 683 684 685 686
  [ ("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")
  ])
687 688
$(THH.makeJSONInstance ''JobStatus)

689
-- | Finalized job status.
690 691 692 693
$(THH.declareLADT ''String "FinalizedJobStatus"
  [ ("JobStatusCanceled",   "canceled")
  , ("JobStatusSuccessful", "success")
  , ("JobStatusFailed",     "error")
694 695
  ])
$(THH.makeJSONInstance ''FinalizedJobStatus)
696 697 698

-- | The Ganeti job type.
newtype JobId = JobId { fromJobId :: Int }
Klaus Aehlig's avatar
Klaus Aehlig committed
699
  deriving (Show, Eq, Ord)
700 701 702 703 704 705

-- | 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 ++ "'"

706 707 708 709
-- | Builds a job ID from a string.
makeJobIdS :: (Monad m) => String -> m JobId
makeJobIdS s = tryRead "parsing job id" s >>= makeJobId

710 711
-- | Parses a job ID.
parseJobId :: (Monad m) => JSON.JSValue -> m JobId
712
parseJobId (JSON.JSString x) = makeJobIdS $ JSON.fromJSString x
713 714 715 716 717 718 719 720 721 722
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
723 724 725 726 727 728 729

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

-- | Job ID dependency.
data JobIdDep = JobDepRelative RelativeJobId
              | JobDepAbsolute JobId
730
                deriving (Show, Eq, Ord)
731 732 733 734 735 736 737 738

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
739
      JSON.Error _ -> liftM JobDepAbsolute (parseJobId v)
740

741 742 743 744
-- | 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 =
745
  liftM JobDepAbsolute . makeJobId $ fromJobId jid + fromNegative rjid
746

747 748
-- | Job Dependency type.
data JobDependency = JobDependency JobIdDep [FinalizedJobStatus]
749
                     deriving (Show, Eq, Ord)
750 751 752 753 754

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

755 756 757
-- | From job dependency and job id compute an absolute job dependency.
absoluteJobDependency :: (Monad m) => JobDependency -> JobId -> m JobDependency
absoluteJobDependency (JobDependency jdep fstats) jid =
758
  liftM (flip JobDependency fstats) $ absoluteJobIdDep jdep jid
759

760 761 762 763 764 765
-- | From a job dependency get the absolute job id it depends on,
-- if given absolutely.
getJobIdFromDependency :: JobDependency -> [JobId]
getJobIdFromDependency (JobDependency (JobDepAbsolute jid) _) = [jid]
getJobIdFromDependency _ = []

766 767
-- | Valid opcode priorities for submit.
$(THH.declareIADT "OpSubmitPriority"
768 769 770
  [ ("OpPrioLow",    'ConstantUtils.priorityLow)
  , ("OpPrioNormal", 'ConstantUtils.priorityNormal)
  , ("OpPrioHigh",   'ConstantUtils.priorityHigh)
771 772
  ])
$(THH.makeJSONInstance ''OpSubmitPriority)
773

774 775 776 777 778 779 780 781 782 783 784 785 786
-- | 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"

787
-- | Our ADT for the OpCode status at runtime (while in a job).
788 789 790 791 792 793 794 795
$(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")
796
  ])
797
$(THH.makeJSONInstance ''OpStatus)
798 799

-- | Type for the job message type.
800 801 802 803
$(THH.declareLADT ''String "ELogType"
  [ ("ELogMessage",      "message")
  , ("ELogRemoteImport", "remote-import")
  , ("ELogJqueueTest",   "jqueue-test")
Hrvoje Ribicic's avatar
Hrvoje Ribicic committed
804
  , ("ELogDelayTest",    "delay-test")
805 806
  ])
$(THH.makeJSONInstance ''ELogType)
807

808 809
-- | Type of one element of a reason trail, of form
-- @(source, reason, timestamp)@.
810 811 812 813
type ReasonElem = (String, String, Integer)

-- | Type representing a reason trail.
type ReasonTrail = [ReasonElem]
814 815 816 817 818 819 820 821

-- | 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
822
  , ("VTypeFloat",       "float")
823 824 825
  ])
$(THH.makeJSONInstance ''VType)

826 827 828
instance THH.PyValue VType where
  showValue = THH.showValue . vTypeToRaw

829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869
-- * 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)
870

871 872 873 874 875 876 877 878 879
$(THH.declareLADT ''String "AdminStateSource"
  [ ("AdminSource", "admin")
  , ("UserSource",  "user")
  ])
$(THH.makeJSONInstance ''AdminStateSource)

instance THH.PyValue AdminStateSource where
  showValue = THH.showValue . adminStateSourceToRaw

880 881 882 883 884 885 886 887 888 889
-- * Storage field type

$(THH.declareLADT ''String "StorageField"
  [ ( "SFUsed",        "used")
  , ( "SFName",        "name")
  , ( "SFAllocatable", "allocatable")
  , ( "SFFree",        "free")
  , ( "SFSize",        "size")
  ])
$(THH.makeJSONInstance ''StorageField)
890 891 892 893 894 895 896 897

-- * Disk access protocol

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

899 900 901 902 903
-- | Local disk status
--
-- Python code depends on:
--   DiskStatusOk < DiskStatusUnknown < DiskStatusFaulty
$(THH.declareILADT "LocalDiskStatus"
904 905 906 907
  [ ("DiskStatusOk",      1)
  , ("DiskStatusSync",    2)
  , ("DiskStatusUnknown", 3)
  , ("DiskStatusFaulty",  4)
908 909 910 911 912
  ])

localDiskStatusName :: LocalDiskStatus -> String
localDiskStatusName DiskStatusFaulty = "faulty"
localDiskStatusName DiskStatusOk = "ok"
913
localDiskStatusName DiskStatusSync = "syncing"
914 915
localDiskStatusName DiskStatusUnknown = "unknown"

916 917 918 919 920 921 922 923 924 925 926
-- | 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)
927 928 929 930 931 932 933 934 935 936

-- | 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
  ])
937

938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953
-- | 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)
954 955 956

-- * Private type and instances

957 958 959
redacted :: String
redacted = "<redacted>"

960 961 962
-- | 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 }
963
  deriving (Eq, Ord, Functor)
964 965 966 967 968 969 970 971 972 973

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
974
  show _ = redacted
975 976 977 978

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

979 980 981 982
instance Applicative Private where
  pure = Private
  Private f <*> Private x = Private (f x)

983 984 985 986 987 988 989 990
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)
991

992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016
-- * Secret type and instances

-- | A container for values that behaves like Private, but doesn't leak the
-- value through showJSON
newtype Secret a = Secret { getSecret :: a }
  deriving (Eq, Ord, Functor)

instance (Show a, JSON.JSON a) => JSON.JSON (Secret a) where
  readJSON = liftM Secret . JSON.readJSON
  showJSON = const . JSON.JSString $ JSON.toJSString redacted

instance Show a => Show (Secret a) where
  show _ = redacted

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

instance Applicative Secret where
  pure = Secret
  Secret f <*> Secret x = Secret (f x)

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

1017 1018
-- | We return "\<redacted\>" here to satisfy the idempotence of serialization
-- and deserialization, although this will impact the meaningfulness of secret
1019 1020 1021 1022 1023 1024 1025 1026 1027 1028
-- parameters within configuration tests.
showSecretJSObject :: (JSON.JSON a) =>
                       [(String, a)] -> JSON.JSObject (Secret JSON.JSValue)
showSecretJSObject value = JSON.toJSObject $ map f value
  where f (k, _) = (k, Secret $ JSON.showJSON redacted)

revealValInJSObject :: JSON.JSObject (Secret JSON.JSValue)
                  -> JSON.JSObject (Private JSON.JSValue)
revealValInJSObject object = JSON.toJSObject . map f $ JSON.fromJSObject object
  where f (k, v) = (k, Private $ getSecret v)
1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049

-- | The hypervisor parameter type. This is currently a simple map,
-- without type checking on key/value pairs.
type HvParams = Container JSON.JSValue

-- | The OS parameters type. This is, and will remain, a string
-- container, since the keys are dynamically declared by the OSes, and
-- the values are always strings.
type OsParams = Container String
type OsParamsPrivate = Container (Private String)


-- | Class of objects that have timestamps.
class TimeStampObject a where
  cTimeOf :: a -> ClockTime
  mTimeOf :: a -> ClockTime

-- | Class of objects that have an UUID.
class UuidObject a where
  uuidOf :: a -> String

1050 1051 1052 1053
-- | Class of objects that can be forthcoming.
class ForthcomingObject a where
  isForthcoming :: a -> Bool

1054 1055 1056 1057 1058 1059 1060 1061
-- | Class of object that have a serial number.
class SerialNoObject a where
  serialOf :: a -> Int

-- | Class of objects that have tags.
class TagsObject a where
  tagsOf :: a -> Set.Set String