Synnefo » snf-ganeti » ganeti-local

{-# 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, 2013 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

  , TagKind(..)

  , tagKindToRaw

  , tagKindFromRaw

  , NonNegative

  , fromNonNegative

  , mkNonNegative

  , Positive

  , fromPositive

  , mkPositive

  , Negative

  , fromNegative

  , mkNegative

  , NonEmpty

  , fromNonEmpty

  , mkNonEmpty

  , NonEmptyString

  , QueryResultCode

  , IPv4Address

  , mkIPv4Address

  , IPv4Network

  , mkIPv4Network

  , IPv6Address

  , mkIPv6Address

  , IPv6Network

  , mkIPv6Network

  , MigrationMode(..)

  , migrationModeToRaw

  , VerifyOptionalChecks(..)

  , verifyOptionalChecksToRaw

  , DdmSimple(..)

  , DdmFull(..)

  , ddmFullToRaw

  , CVErrorCode(..)

  , cVErrorCodeToRaw

  , Hypervisor(..)

  , hypervisorToRaw

  , OobCommand(..)

  , oobCommandToRaw

  , StorageType(..)

  , storageTypeToRaw

  , NodeEvacMode(..)

  , nodeEvacModeToRaw

  , FileDriver(..)

  , fileDriverToRaw

  , InstCreateMode(..)

  , instCreateModeToRaw

  , RebootType(..)

  , rebootTypeToRaw

  , ExportMode(..)

  , exportModeToRaw

  , IAllocatorTestDir(..)

  , iAllocatorTestDirToRaw

  , IAllocatorMode(..)

  , iAllocatorModeToRaw

  , NICMode(..)

  , nICModeToRaw

  , JobStatus(..)

  , jobStatusToRaw

  , jobStatusFromRaw

  , FinalizedJobStatus(..)

  , finalizedJobStatusToRaw

  , JobId

  , fromJobId

  , makeJobId

  , makeJobIdS

  , RelativeJobId

  , JobIdDep(..)

  , JobDependency(..)

  , OpSubmitPriority(..)

  , opSubmitPriorityToRaw

  , parseSubmitPriority

  , fmtSubmitPriority

  , OpStatus(..)

  , opStatusToRaw

  , opStatusFromRaw

  , ELogType(..)

  , eLogTypeToRaw

  , 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

-- * 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 (Eq a, Ord a) => Ord (NonEmpty a) where

  NonEmpty { fromNonEmpty = x1 } `compare` NonEmpty { fromNonEmpty = x2 } =

    x1 `compare` x2

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

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

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

       , ("DTExt",        'C.dtExt)

       ])

$(THH.makeJSONInstance ''DiskTemplate)

instance HasStringRepr DiskTemplate where

  fromStringRepr = diskTemplateFromRaw

  toStringRepr = diskTemplateToRaw

-- | Data type representing what items the tag operations apply to.

$(THH.declareSADT "TagKind"

  [ ("TagKindInstance", 'C.tagInstance)

  , ("TagKindNode",     'C.tagNode)

  , ("TagKindGroup",    'C.tagNodegroup)

  , ("TagKindCluster",  'C.tagCluster)

  ])

$(THH.makeJSONInstance ''TagKind)

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

  , ("CvENODEFILESTORAGEPATHUNUSABLE", 'C.cvEnodefilestoragepathunusableCode)

  , ("CvENODESHAREDFILESTORAGEPATHUNUSABLE",

     'C.cvEnodesharedfilestoragepathunusableCode)

  ])

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

  , ("StorageDiskless", 'C.stDiskless)

  , ("StorageBlock", 'C.stBlock)

  , ("StorageRados", 'C.stRados)

  , ("StorageExt", 'C.stExt)

  ])

$(THH.makeJSONInstance ''StorageType)

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

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

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

-- | Mapping fo disk templates to storage type

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

diskTemplateToStorageType DTSharedFile = StorageFile

diskTemplateToStorageType DTDrbd8 = StorageLvmVg

diskTemplateToStorageType DTPlain = StorageLvmVg

diskTemplateToStorageType DTRbd = StorageRados

diskTemplateToStorageType DTDiskless = StorageDiskless

diskTemplateToStorageType DTBlock = StorageBlock

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

addParamsToStorageUnit es (SURaw StorageLvmPv key) = SULvmPv key es

addParamsToStorageUnit es (SURaw StorageLvmVg key) = SULvmVg key es

addParamsToStorageUnit _ (SURaw StorageRados key) = SURados key

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

-- | Builds a job ID from a string.

makeJobIdS :: (Monad m) => String -> m JobId

makeJobIdS s = tryRead "parsing job id" s >>= makeJobId

-- | Parses a job ID.

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

    -- 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 (parseJobId v)

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

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

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

-- | Type for the job message type.

$(THH.declareSADT "ELogType"

  [ ("ELogMessage",      'C.elogMessage)

  , ("ELogRemoteImport", 'C.elogRemoteImport)

  , ("ELogJqueueTest",   'C.elogJqueueTest)

  ])

$(THH.makeJSONInstance ''ELogType)

-- | Type of one element of a reason trail.

type ReasonElem = (String, String, Integer)

-- | Type representing a reason trail.

type ReasonTrail = [ReasonElem]