module Ganeti.Types
( AllocPolicy(..)
, allocPolicyFromRaw
, allocPolicyToRaw
, InstanceStatus(..)
, instanceStatusFromRaw
, instanceStatusToRaw
, DiskTemplate(..)
, diskTemplateToRaw
, diskTemplateFromRaw
, NonNegative
, fromNonNegative
, mkNonNegative
, Positive
, fromPositive
, mkPositive
, Negative
, fromNegative
, mkNegative
, NonEmpty
, fromNonEmpty
, mkNonEmpty
, NonEmptyString
, MigrationMode(..)
, VerifyOptionalChecks(..)
, DdmSimple(..)
, DdmFull(..)
, CVErrorCode(..)
, cVErrorCodeToRaw
, Hypervisor(..)
, hypervisorToRaw
, OobCommand(..)
, StorageType(..)
, storageTypeToRaw
, NodeEvacMode(..)
, FileDriver(..)
, InstCreateMode(..)
, RebootType(..)
, ExportMode(..)
, IAllocatorTestDir(..)
, IAllocatorMode(..)
, iAllocatorModeToRaw
, NICMode(..)
, nICModeToRaw
, JobStatus(..)
, jobStatusToRaw
, jobStatusFromRaw
, FinalizedJobStatus(..)
, finalizedJobStatusToRaw
, JobId
, fromJobId
, makeJobId
, makeJobIdS
, RelativeJobId
, JobIdDep(..)
, JobDependency(..)
, OpSubmitPriority(..)
, opSubmitPriorityToRaw
, parseSubmitPriority
, fmtSubmitPriority
, OpStatus(..)
, opStatusToRaw
, opStatusFromRaw
, ELogType(..)
, ReasonElem
, ReasonTrail
, StorageUnit(..)
, StorageUnitRaw(..)
, StorageKey
, addParamsToStorageUnit
, diskTemplateToStorageType
) where
import Control.Monad (liftM)
import qualified Text.JSON as JSON
import Text.JSON (JSON, readJSON, showJSON)
import Data.Ratio (numerator, denominator)
import qualified Ganeti.Constants as C
import qualified Ganeti.THH as THH
import Ganeti.JSON
import Ganeti.Utils
newtype NonNegative a = NonNegative { fromNonNegative :: a }
deriving (Show, Eq)
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
newtype Positive a = Positive { fromPositive :: a }
deriving (Show, Eq)
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
newtype Negative a = Negative { fromNegative :: a }
deriving (Show, Eq)
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
newtype NonEmpty a = NonEmpty { fromNonEmpty :: [a] }
deriving (Show, Eq)
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
type NonEmptyString = NonEmpty Char
$(THH.declareSADT "DiskTemplate"
[ ("DTDiskless", 'C.dtDiskless)
, ("DTFile", 'C.dtFile)
, ("DTSharedFile", 'C.dtSharedFile)
, ("DTPlain", 'C.dtPlain)
, ("DTBlock", 'C.dtBlock)
, ("DTDrbd8", 'C.dtDrbd8)
, ("DTRbd", 'C.dtRbd)
, ("DTExt", 'C.dtExt)
])
$(THH.makeJSONInstance ''DiskTemplate)
instance HasStringRepr DiskTemplate where
fromStringRepr = diskTemplateFromRaw
toStringRepr = diskTemplateToRaw
$(THH.declareSADT "AllocPolicy"
[ ("AllocPreferred", 'C.allocPolicyPreferred)
, ("AllocLastResort", 'C.allocPolicyLastResort)
, ("AllocUnallocable", 'C.allocPolicyUnallocable)
])
$(THH.makeJSONInstance ''AllocPolicy)
$(THH.declareSADT "InstanceStatus"
[ ("StatusDown", 'C.inststAdmindown)
, ("StatusOffline", 'C.inststAdminoffline)
, ("ErrorDown", 'C.inststErrordown)
, ("ErrorUp", 'C.inststErrorup)
, ("NodeDown", 'C.inststNodedown)
, ("NodeOffline", 'C.inststNodeoffline)
, ("Running", 'C.inststRunning)
, ("WrongNode", 'C.inststWrongnode)
])
$(THH.makeJSONInstance ''InstanceStatus)
$(THH.declareSADT "MigrationMode"
[ ("MigrationLive", 'C.htMigrationLive)
, ("MigrationNonLive", 'C.htMigrationNonlive)
])
$(THH.makeJSONInstance ''MigrationMode)
$(THH.declareSADT "VerifyOptionalChecks"
[ ("VerifyNPlusOneMem", 'C.verifyNplusoneMem)
])
$(THH.makeJSONInstance ''VerifyOptionalChecks)
$(THH.declareSADT "CVErrorCode"
[ ("CvECLUSTERCFG", 'C.cvEclustercfgCode)
, ("CvECLUSTERCERT", 'C.cvEclustercertCode)
, ("CvECLUSTERFILECHECK", 'C.cvEclusterfilecheckCode)
, ("CvECLUSTERDANGLINGNODES", 'C.cvEclusterdanglingnodesCode)
, ("CvECLUSTERDANGLINGINST", 'C.cvEclusterdanglinginstCode)
, ("CvEINSTANCEBADNODE", 'C.cvEinstancebadnodeCode)
, ("CvEINSTANCEDOWN", 'C.cvEinstancedownCode)
, ("CvEINSTANCELAYOUT", 'C.cvEinstancelayoutCode)
, ("CvEINSTANCEMISSINGDISK", 'C.cvEinstancemissingdiskCode)
, ("CvEINSTANCEFAULTYDISK", 'C.cvEinstancefaultydiskCode)
, ("CvEINSTANCEWRONGNODE", 'C.cvEinstancewrongnodeCode)
, ("CvEINSTANCESPLITGROUPS", 'C.cvEinstancesplitgroupsCode)
, ("CvEINSTANCEPOLICY", 'C.cvEinstancepolicyCode)
, ("CvENODEDRBD", 'C.cvEnodedrbdCode)
, ("CvENODEDRBDHELPER", 'C.cvEnodedrbdhelperCode)
, ("CvENODEFILECHECK", 'C.cvEnodefilecheckCode)
, ("CvENODEHOOKS", 'C.cvEnodehooksCode)
, ("CvENODEHV", 'C.cvEnodehvCode)
, ("CvENODELVM", 'C.cvEnodelvmCode)
, ("CvENODEN1", 'C.cvEnoden1Code)
, ("CvENODENET", 'C.cvEnodenetCode)
, ("CvENODEOS", 'C.cvEnodeosCode)
, ("CvENODEORPHANINSTANCE", 'C.cvEnodeorphaninstanceCode)
, ("CvENODEORPHANLV", 'C.cvEnodeorphanlvCode)
, ("CvENODERPC", 'C.cvEnoderpcCode)
, ("CvENODESSH", 'C.cvEnodesshCode)
, ("CvENODEVERSION", 'C.cvEnodeversionCode)
, ("CvENODESETUP", 'C.cvEnodesetupCode)
, ("CvENODETIME", 'C.cvEnodetimeCode)
, ("CvENODEOOBPATH", 'C.cvEnodeoobpathCode)
, ("CvENODEUSERSCRIPTS", 'C.cvEnodeuserscriptsCode)
, ("CvENODEFILESTORAGEPATHS", 'C.cvEnodefilestoragepathsCode)
, ("CvENODEFILESTORAGEPATHUNUSABLE", 'C.cvEnodefilestoragepathunusableCode)
, ("CvENODESHAREDFILESTORAGEPATHUNUSABLE",
'C.cvEnodesharedfilestoragepathunusableCode)
])
$(THH.makeJSONInstance ''CVErrorCode)
$(THH.declareSADT "DdmSimple"
[ ("DdmSimpleAdd", 'C.ddmAdd)
, ("DdmSimpleRemove", 'C.ddmRemove)
])
$(THH.makeJSONInstance ''DdmSimple)
$(THH.declareSADT "DdmFull"
[ ("DdmFullAdd", 'C.ddmAdd)
, ("DdmFullRemove", 'C.ddmRemove)
, ("DdmFullModify", 'C.ddmModify)
])
$(THH.makeJSONInstance ''DdmFull)
$(THH.declareSADT "Hypervisor"
[ ( "Kvm", 'C.htKvm )
, ( "XenPvm", 'C.htXenPvm )
, ( "Chroot", 'C.htChroot )
, ( "XenHvm", 'C.htXenHvm )
, ( "Lxc", 'C.htLxc )
, ( "Fake", 'C.htFake )
])
$(THH.makeJSONInstance ''Hypervisor)
$(THH.declareSADT "OobCommand"
[ ("OobHealth", 'C.oobHealth)
, ("OobPowerCycle", 'C.oobPowerCycle)
, ("OobPowerOff", 'C.oobPowerOff)
, ("OobPowerOn", 'C.oobPowerOn)
, ("OobPowerStatus", 'C.oobPowerStatus)
])
$(THH.makeJSONInstance ''OobCommand)
$(THH.declareSADT "StorageType"
[ ("StorageFile", 'C.stFile)
, ("StorageLvmPv", 'C.stLvmPv)
, ("StorageLvmVg", 'C.stLvmVg)
, ("StorageDiskless", 'C.stDiskless)
, ("StorageBlock", 'C.stBlock)
, ("StorageRados", 'C.stRados)
, ("StorageExt", 'C.stExt)
])
$(THH.makeJSONInstance ''StorageType)
type StorageKey = String
type SPExclusiveStorage = Bool
data StorageUnitRaw = SURaw StorageType StorageKey
data StorageUnit = SUFile StorageKey
| 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
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])
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])
readJSON = fail "Not implemented"
showSUSimple :: StorageType -> StorageKey -> String
showSUSimple st sk = show (storageTypeToRaw st, sk, []::[String])
showSULvm :: StorageType -> StorageKey -> SPExclusiveStorage -> String
showSULvm st sk es = show (storageTypeToRaw st, sk, [es])
diskTemplateToStorageType :: DiskTemplate -> StorageType
diskTemplateToStorageType DTExt = StorageExt
diskTemplateToStorageType DTFile = StorageFile
diskTemplateToStorageType DTSharedFile = StorageFile
diskTemplateToStorageType DTDrbd8 = StorageLvmVg
diskTemplateToStorageType DTPlain = StorageLvmVg
diskTemplateToStorageType DTRbd = StorageRados
diskTemplateToStorageType DTDiskless = StorageDiskless
diskTemplateToStorageType DTBlock = StorageBlock
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
addParamsToStorageUnit es (SURaw StorageLvmPv key) = SULvmPv key es
addParamsToStorageUnit es (SURaw StorageLvmVg key) = SULvmVg key es
addParamsToStorageUnit _ (SURaw StorageRados key) = SURados key
$(THH.declareSADT "NodeEvacMode"
[ ("NEvacPrimary", 'C.iallocatorNevacPri)
, ("NEvacSecondary", 'C.iallocatorNevacSec)
, ("NEvacAll", 'C.iallocatorNevacAll)
])
$(THH.makeJSONInstance ''NodeEvacMode)
$(THH.declareSADT "FileDriver"
[ ("FileLoop", 'C.fdLoop)
, ("FileBlktap", 'C.fdBlktap)
])
$(THH.makeJSONInstance ''FileDriver)
$(THH.declareSADT "InstCreateMode"
[ ("InstCreate", 'C.instanceCreate)
, ("InstImport", 'C.instanceImport)
, ("InstRemoteImport", 'C.instanceRemoteImport)
])
$(THH.makeJSONInstance ''InstCreateMode)
$(THH.declareSADT "RebootType"
[ ("RebootSoft", 'C.instanceRebootSoft)
, ("RebootHard", 'C.instanceRebootHard)
, ("RebootFull", 'C.instanceRebootFull)
])
$(THH.makeJSONInstance ''RebootType)
$(THH.declareSADT "ExportMode"
[ ("ExportModeLocal", 'C.exportModeLocal)
, ("ExportModeRemove", 'C.exportModeRemote)
])
$(THH.makeJSONInstance ''ExportMode)
$(THH.declareSADT "IAllocatorTestDir"
[ ("IAllocatorDirIn", 'C.iallocatorDirIn)
, ("IAllocatorDirOut", 'C.iallocatorDirOut)
])
$(THH.makeJSONInstance ''IAllocatorTestDir)
$(THH.declareSADT "IAllocatorMode"
[ ("IAllocatorAlloc", 'C.iallocatorModeAlloc)
, ("IAllocatorMultiAlloc", 'C.iallocatorModeMultiAlloc)
, ("IAllocatorReloc", 'C.iallocatorModeReloc)
, ("IAllocatorNodeEvac", 'C.iallocatorModeNodeEvac)
, ("IAllocatorChangeGroup", 'C.iallocatorModeChgGroup)
])
$(THH.makeJSONInstance ''IAllocatorMode)
$(THH.declareSADT "NICMode"
[ ("NMBridged", 'C.nicModeBridged)
, ("NMRouted", 'C.nicModeRouted)
, ("NMOvs", 'C.nicModeOvs)
])
$(THH.makeJSONInstance ''NICMode)
$(THH.declareSADT "JobStatus"
[ ("JOB_STATUS_QUEUED", 'C.jobStatusQueued)
, ("JOB_STATUS_WAITING", 'C.jobStatusWaiting)
, ("JOB_STATUS_CANCELING", 'C.jobStatusCanceling)
, ("JOB_STATUS_RUNNING", 'C.jobStatusRunning)
, ("JOB_STATUS_CANCELED", 'C.jobStatusCanceled)
, ("JOB_STATUS_SUCCESS", 'C.jobStatusSuccess)
, ("JOB_STATUS_ERROR", 'C.jobStatusError)
])
$(THH.makeJSONInstance ''JobStatus)
$(THH.declareSADT "FinalizedJobStatus"
[ ("JobStatusCanceled", 'C.jobStatusCanceled)
, ("JobStatusSuccessful", 'C.jobStatusSuccess)
, ("JobStatusFailed", 'C.jobStatusError)
])
$(THH.makeJSONInstance ''FinalizedJobStatus)
newtype JobId = JobId { fromJobId :: Int }
deriving (Show, Eq)
makeJobId :: (Monad m) => Int -> m JobId
makeJobId i | i >= 0 = return $ JobId i
| otherwise = fail $ "Invalid value for job ID ' " ++ show i ++ "'"
makeJobIdS :: (Monad m) => String -> m JobId
makeJobIdS s = tryRead "parsing job id" s >>= makeJobId
parseJobId :: (Monad m) => JSON.JSValue -> m JobId
parseJobId (JSON.JSString x) = makeJobIdS $ JSON.fromJSString x
parseJobId (JSON.JSRational _ x) =
if denominator x /= 1
then fail $ "Got fractional job ID from master daemon?! Value:" ++ show x
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
type RelativeJobId = Negative Int
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
JSON.Ok r -> return $ JobDepRelative r
JSON.Error _ -> liftM JobDepAbsolute (parseJobId v)
data JobDependency = JobDependency JobIdDep [FinalizedJobStatus]
deriving (Show, Eq)
instance JSON JobDependency where
showJSON (JobDependency dep status) = showJSON (dep, status)
readJSON = liftM (uncurry JobDependency) . readJSON
$(THH.declareIADT "OpSubmitPriority"
[ ("OpPrioLow", 'C.opPrioLow)
, ("OpPrioNormal", 'C.opPrioNormal)
, ("OpPrioHigh", 'C.opPrioHigh)
])
$(THH.makeJSONInstance ''OpSubmitPriority)
parseSubmitPriority :: (Monad m) => String -> m OpSubmitPriority
parseSubmitPriority "low" = return OpPrioLow
parseSubmitPriority "normal" = return OpPrioNormal
parseSubmitPriority "high" = return OpPrioHigh
parseSubmitPriority str = fail $ "Unknown priority '" ++ str ++ "'"
fmtSubmitPriority :: OpSubmitPriority -> String
fmtSubmitPriority OpPrioLow = "low"
fmtSubmitPriority OpPrioNormal = "normal"
fmtSubmitPriority OpPrioHigh = "high"
$(THH.declareSADT "OpStatus"
[ ("OP_STATUS_QUEUED", 'C.opStatusQueued)
, ("OP_STATUS_WAITING", 'C.opStatusWaiting)
, ("OP_STATUS_CANCELING", 'C.opStatusCanceling)
, ("OP_STATUS_RUNNING", 'C.opStatusRunning)
, ("OP_STATUS_CANCELED", 'C.opStatusCanceled)
, ("OP_STATUS_SUCCESS", 'C.opStatusSuccess)
, ("OP_STATUS_ERROR", 'C.opStatusError)
])
$(THH.makeJSONInstance ''OpStatus)
$(THH.declareSADT "ELogType"
[ ("ELogMessage", 'C.elogMessage)
, ("ELogRemoteImport", 'C.elogRemoteImport)
, ("ELogJqueueTest", 'C.elogJqueueTest)
])
$(THH.makeJSONInstance ''ELogType)
type ReasonElem = (String, String, Integer)
type ReasonTrail = [ReasonElem]