From b46ba79cf318eefb7036b96afe71ef9634838007 Mon Sep 17 00:00:00 2001 From: Iustin Pop <iustin@google.com> Date: Mon, 3 Dec 2012 10:17:32 +0100 Subject: [PATCH] Add types and parameters for common opcode implementation This will go into a separate type; this patch adds the needed underlying types and parameters. Signed-off-by: Iustin Pop <iustin@google.com> Reviewed-by: Guido Trotter <ultrotter@google.com> --- htest/Test/Ganeti/Types.hs | 21 ++++++++++++++++--- htools/Ganeti/OpParams.hs | 30 ++++++++++++++++++++++++++++ htools/Ganeti/Types.hs | 41 ++++++++++++++++++++++++++++++++++++++ 3 files changed, 89 insertions(+), 3 deletions(-) diff --git a/htest/Test/Ganeti/Types.hs b/htest/Test/Ganeti/Types.hs index 281bbbbb3..f758456e7 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 9debfadfe..cda751e39 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 1768ab6b1..bafc5bcc2 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) -- GitLab