Synnefo » snf-ganeti

{-# 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'.

-}

{-

Copyright (C) 2012 Google Inc.

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

  , NonNegative

  , fromNonNegative

  , mkNonNegative

  , Positive

  , fromPositive

  , mkPositive

  , Negative

  , fromNegative

  , mkNegative

  , NonEmpty

  , fromNonEmpty

  , mkNonEmpty

  , NonEmptyString

  , MigrationMode(..)

  , VerifyOptionalChecks(..)

  , DdmSimple(..)

  , DdmFull(..)

  , CVErrorCode(..)

  , cVErrorCodeToRaw

  , Hypervisor(..)

  , OobCommand(..)

  , StorageType(..)

  , NodeEvacMode(..)

  , FileDriver(..)

  , InstCreateMode(..)

  , RebootType(..)

  , ExportMode(..)

  , IAllocatorTestDir(..)

  , IAllocatorMode(..)

  , iAllocatorModeToRaw

  , NetworkType(..)

  , networkTypeToRaw

  , NICMode(..)

  , nICModeToRaw

  , JobStatus(..)

  , jobStatusToRaw

  , jobStatusFromRaw

  , FinalizedJobStatus(..)

  , finalizedJobStatusToRaw

  , JobId

  , fromJobId

  , makeJobId

  , RelativeJobId

  , JobIdDep(..)

  , JobDependency(..)

  , OpSubmitPriority(..)

  , OpStatus(..)

  , opStatusToRaw

  , opStatusFromRaw

  ) 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

-- * Generic types

-- | Type that holds a non-negative value.

newtype NonNegative a = NonNegative { fromNonNegative :: a }

  deriving (Show, Eq)

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

  deriving (Show, Eq)

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

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

-- | Type that holds a non-null list.

newtype NonEmpty a = NonEmpty { fromNonEmpty :: [a] }

  deriving (Show, Eq)

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

-- | A simple type alias for non-empty strings.

type NonEmptyString = NonEmpty Char

-- * Ganeti types

-- | Instance disk template type.

$(THH.declareSADT "DiskTemplate"

       [ ("DTDiskless",   'C.dtDiskless)

       , ("DTFile",       'C.dtFile)

       , ("DTSharedFile", 'C.dtSharedFile)

       , ("DTPlain",      'C.dtPlain)

       , ("DTBlock",      'C.dtBlock)

       , ("DTDrbd8",      'C.dtDrbd8)

       , ("DTRbd",        'C.dtRbd)

       ])

$(THH.makeJSONInstance ''DiskTemplate)

instance HasStringRepr DiskTemplate where

  fromStringRepr = diskTemplateFromRaw

  toStringRepr = diskTemplateToRaw

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

$(THH.declareSADT "AllocPolicy"

       [ ("AllocPreferred",   'C.allocPolicyPreferred)

       , ("AllocLastResort",  'C.allocPolicyLastResort)

       , ("AllocUnallocable", 'C.allocPolicyUnallocable)

       ])

$(THH.makeJSONInstance ''AllocPolicy)

-- | The Instance real state type. FIXME: this could be improved to

-- just wrap a /NormalState AdminStatus | ErrorState ErrorCondition/.

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

-- | Migration mode.

$(THH.declareSADT "MigrationMode"

     [ ("MigrationLive",    'C.htMigrationLive)

     , ("MigrationNonLive", 'C.htMigrationNonlive)

     ])

$(THH.makeJSONInstance ''MigrationMode)

-- | Verify optional checks.

$(THH.declareSADT "VerifyOptionalChecks"

     [ ("VerifyNPlusOneMem", 'C.verifyNplusoneMem)

     ])

$(THH.makeJSONInstance ''VerifyOptionalChecks)

-- | Cluster verify error codes.

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

  ])

$(THH.makeJSONInstance ''CVErrorCode)

-- | Dynamic device modification, just add\/remove version.

$(THH.declareSADT "DdmSimple"

     [ ("DdmSimpleAdd",    'C.ddmAdd)

     , ("DdmSimpleRemove", 'C.ddmRemove)

     ])

$(THH.makeJSONInstance ''DdmSimple)

-- | Dynamic device modification, all operations version.

$(THH.declareSADT "DdmFull"

     [ ("DdmFullAdd",    'C.ddmAdd)

     , ("DdmFullRemove", 'C.ddmRemove)

     , ("DdmFullModify", 'C.ddmModify)

     ])

$(THH.makeJSONInstance ''DdmFull)

-- | Hypervisor type definitions.

$(THH.declareSADT "Hypervisor"

  [ ( "Kvm",    'C.htKvm )

  , ( "XenPvm", 'C.htXenPvm )

  , ( "Chroot", 'C.htChroot )

  , ( "XenHvm", 'C.htXenHvm )

  , ( "Lxc",    'C.htLxc )

  , ( "Fake",   'C.htFake )

  ])

$(THH.makeJSONInstance ''Hypervisor)

-- | Oob command type.

$(THH.declareSADT "OobCommand"

  [ ("OobHealth",      'C.oobHealth)

  , ("OobPowerCycle",  'C.oobPowerCycle)

  , ("OobPowerOff",    'C.oobPowerOff)

  , ("OobPowerOn",     'C.oobPowerOn)

  , ("OobPowerStatus", 'C.oobPowerStatus)

  ])

$(THH.makeJSONInstance ''OobCommand)

-- | Storage type.

$(THH.declareSADT "StorageType"

  [ ("StorageFile", 'C.stFile)

  , ("StorageLvmPv", 'C.stLvmPv)

  , ("StorageLvmVg", 'C.stLvmVg)

  ])

$(THH.makeJSONInstance ''StorageType)

-- | Node evac modes.

$(THH.declareSADT "NodeEvacMode"

  [ ("NEvacPrimary",   'C.iallocatorNevacPri)

  , ("NEvacSecondary", 'C.iallocatorNevacSec)

  , ("NEvacAll",       'C.iallocatorNevacAll)

  ])

$(THH.makeJSONInstance ''NodeEvacMode)

-- | The file driver type.

$(THH.declareSADT "FileDriver"

  [ ("FileLoop",   'C.fdLoop)

  , ("FileBlktap", 'C.fdBlktap)

  ])

$(THH.makeJSONInstance ''FileDriver)

-- | The instance create mode.

$(THH.declareSADT "InstCreateMode"

  [ ("InstCreate",       'C.instanceCreate)

  , ("InstImport",       'C.instanceImport)

  , ("InstRemoteImport", 'C.instanceRemoteImport)

  ])

$(THH.makeJSONInstance ''InstCreateMode)

-- | Reboot type.

$(THH.declareSADT "RebootType"

  [ ("RebootSoft", 'C.instanceRebootSoft)

  , ("RebootHard", 'C.instanceRebootHard)

  , ("RebootFull", 'C.instanceRebootFull)

  ])

$(THH.makeJSONInstance ''RebootType)

-- | Export modes.

$(THH.declareSADT "ExportMode"

  [ ("ExportModeLocal",  'C.exportModeLocal)

  , ("ExportModeRemove", 'C.exportModeRemote)

  ])

$(THH.makeJSONInstance ''ExportMode)

-- | IAllocator run types (OpTestIAllocator).

$(THH.declareSADT "IAllocatorTestDir"

  [ ("IAllocatorDirIn",  'C.iallocatorDirIn)

  , ("IAllocatorDirOut", 'C.iallocatorDirOut)

  ])

$(THH.makeJSONInstance ''IAllocatorTestDir)

-- | IAllocator mode. FIXME: use this in "HTools.Backend.IAlloc".

$(THH.declareSADT "IAllocatorMode"

  [ ("IAllocatorAlloc",       'C.iallocatorModeAlloc)

  , ("IAllocatorMultiAlloc",  'C.iallocatorModeMultiAlloc)

  , ("IAllocatorReloc",       'C.iallocatorModeReloc)

  , ("IAllocatorNodeEvac",    'C.iallocatorModeNodeEvac)

  , ("IAllocatorChangeGroup", 'C.iallocatorModeChgGroup)

  ])

$(THH.makeJSONInstance ''IAllocatorMode)

-- | Network type.

$(THH.declareSADT "NetworkType"

  [ ("PrivateNetwork", 'C.networkTypePrivate)

  , ("PublicNetwork",  'C.networkTypePublic)

  ])

$(THH.makeJSONInstance ''NetworkType)

-- | Netork mode.

$(THH.declareSADT "NICMode"

  [ ("NMBridged", 'C.nicModeBridged)

  , ("NMRouted",  'C.nicModeRouted)

  , ("NMOvs",     'C.nicModeOvs)

  ])

$(THH.makeJSONInstance ''NICMode)

-- | The JobStatus data type. Note that this is ordered especially

-- such that greater\/lesser comparison on values of this type makes

-- sense.

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

-- | Finalized job status.

$(THH.declareSADT "FinalizedJobStatus"

  [ ("JobStatusCanceled",   'C.jobStatusCanceled)

  , ("JobStatusSuccessful", 'C.jobStatusSuccess)

  , ("JobStatusFailed",     'C.jobStatusError)

  ])

$(THH.makeJSONInstance ''FinalizedJobStatus)

-- | The Ganeti job type.

newtype JobId = JobId { fromJobId :: Int }

  deriving (Show, Eq)

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

-- | Parses a job ID.

parseJobId :: (Monad m) => JSON.JSValue -> m JobId

parseJobId (JSON.JSString x) =

  tryRead "parsing job id" (JSON.fromJSString x) >>= makeJobId

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

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

      JSON.Error _ -> liftM JobDepAbsolute

                      (fromJResult "parsing absolute job id" (readJSON v) >>=

                       makeJobId)

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

-- | Valid opcode priorities for submit.

$(THH.declareIADT "OpSubmitPriority"

  [ ("OpPrioLow",    'C.opPrioLow)

  , ("OpPrioNormal", 'C.opPrioNormal)

  , ("OpPrioHigh",   'C.opPrioHigh)

  ])

$(THH.makeJSONInstance ''OpSubmitPriority)

-- | Our ADT for the OpCode status at runtime (while in a job).

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