diff --git a/htest/Test/Ganeti/Types.hs b/htest/Test/Ganeti/Types.hs index 281bbbbb3db61a2ed84f8ea1ca44c2e1285e0f39..f758456e7c0965881220553b8eb039577d57d5e1 100644 --- a/htest/Test/Ganeti/Types.hs +++ b/htest/Test/Ganeti/Types.hs @@ -47,7 +47,6 @@ import Test.Ganeti.TestCommon import Ganeti.BasicTypes import qualified Ganeti.Constants as C import Ganeti.Types as Types -import Ganeti.Luxi as Luxi {-# ANN module "HLint: ignore Use camelCase" #-} @@ -118,10 +117,16 @@ $(genArbitrary ''NICMode) $(genArbitrary ''FinalizedJobStatus) -instance Arbitrary Luxi.JobId where +instance Arbitrary JobId where arbitrary = do (Positive i) <- arbitrary - Luxi.makeJobId i + makeJobId i + +$(genArbitrary ''JobIdDep) + +$(genArbitrary ''JobDependency) + +$(genArbitrary ''OpSubmitPriority) -- * Properties @@ -307,6 +312,14 @@ prop_JobId_serialisation jid = testSerialisation jid .&&. (J.readJSON . J.showJSON . show $ fromJobId jid) ==? J.Ok jid +-- | Test 'JobDependency' serialisation. +prop_JobDependency_serialisation :: JobDependency -> Property +prop_JobDependency_serialisation = testSerialisation + +-- | Test 'OpSubmitPriority' serialisation. +prop_OpSubmitPriority_serialisation :: OpSubmitPriority -> Property +prop_OpSubmitPriority_serialisation = testSerialisation + testSuite "Types" [ 'prop_AllocPolicy_serialisation , 'prop_DiskTemplate_serialisation @@ -343,4 +356,6 @@ testSuite "Types" , 'prop_FinalizedJobStatus_serialisation , 'case_FinalizedJobStatus_pyequiv , 'prop_JobId_serialisation + , 'prop_JobDependency_serialisation + , 'prop_OpSubmitPriority_serialisation ] diff --git a/htools/Ganeti/OpParams.hs b/htools/Ganeti/OpParams.hs index 9debfadfed1676a5d5c4af6a15d4da53fe295b14..cda751e392c5db294999b758d9d6d90b5c7b7ef6 100644 --- a/htools/Ganeti/OpParams.hs +++ b/htools/Ganeti/OpParams.hs @@ -229,6 +229,11 @@ module Ganeti.OpParams , pNetworkRemoveRsvdIps , pNetworkMode , pNetworkLink + , pDryRun + , pDebugLevel + , pOpPriority + , pDependencies + , pComment , dOldQuery , dOldQueryNoLocking ) where @@ -1393,6 +1398,31 @@ pNetworkMode = simpleField "network_mode" [t| NICMode |] pNetworkLink :: Field pNetworkLink = simpleField "network_link" [t| NonEmptyString |] +-- * Common opcode parameters + +-- | Run checks only, don't execute. +pDryRun :: Field +pDryRun = optionalField $ booleanField "dry_run" + +-- | Debug level. +pDebugLevel :: Field +pDebugLevel = optionalField $ simpleField "debug_level" [t| NonNegative Int |] + +-- | Opcode priority. Note: python uses a separate constant, we're +-- using the actual value we know it's the default. +pOpPriority :: Field +pOpPriority = + defaultField [| OpPrioNormal |] $ + simpleField "priority" [t| OpSubmitPriority |] + +-- | Job dependencies. +pDependencies :: Field +pDependencies = optionalField $ simpleField "depends" [t| [JobDependency] |] + +-- | Comment field. +pComment :: Field +pComment = optionalField $ stringField "comment" + -- * Entire opcode parameter list -- | Old-style query opcode, with locking. diff --git a/htools/Ganeti/Types.hs b/htools/Ganeti/Types.hs index 1768ab6b10726d88944206ff1f97bf72b616db93..bafc5bcc281998fcbd761e9dd68caf552cffd4af 100644 --- a/htools/Ganeti/Types.hs +++ b/htools/Ganeti/Types.hs @@ -79,9 +79,15 @@ module Ganeti.Types , JobId , fromJobId , makeJobId + , RelativeJobId + , JobIdDep(..) + , JobDependency(..) + , OpSubmitPriority(..) ) 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 @@ -388,3 +394,38 @@ 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)