diff --git a/htest/Test/Ganeti/Types.hs b/htest/Test/Ganeti/Types.hs index 790f948190884768a10c817a35937d25b291c592..79abcef63a760da58213ebd3b6969f219ccc1cb5 100644 --- a/htest/Test/Ganeti/Types.hs +++ b/htest/Test/Ganeti/Types.hs @@ -33,11 +33,13 @@ module Test.Ganeti.Types , InstanceStatus(..) , NonEmpty(..) , Hypervisor(..) + , JobId(..) ) where import Data.List (sort) import Test.QuickCheck as QuickCheck hiding (Result) import Test.HUnit +import qualified Text.JSON as J import Test.Ganeti.TestHelper import Test.Ganeti.TestCommon @@ -45,6 +47,7 @@ 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" #-} @@ -109,6 +112,11 @@ $(genArbitrary ''NICMode) $(genArbitrary ''FinalizedJobStatus) +instance Arbitrary Luxi.JobId where + arbitrary = do + (Positive i) <- arbitrary + Luxi.makeJobId i + -- * Properties prop_AllocPolicy_serialisation :: AllocPolicy -> Property @@ -271,6 +279,12 @@ case_FinalizedJobStatus_pyequiv = do [minBound..maxBound] assertEqual "for FinalizedJobStatus equivalence" all_py_codes all_hs_codes +-- | Tests JobId serialisation (both from string and ints). +prop_JobId_serialisation :: JobId -> Property +prop_JobId_serialisation jid = + testSerialisation jid .&&. + (J.readJSON . J.showJSON . show $ fromJobId jid) ==? J.Ok jid + testSuite "Types" [ 'prop_AllocPolicy_serialisation , 'prop_DiskTemplate_serialisation @@ -304,4 +318,5 @@ testSuite "Types" , 'case_NICMode_pyequiv , 'prop_FinalizedJobStatus_serialisation , 'case_FinalizedJobStatus_pyequiv + , 'prop_JobId_serialisation ] diff --git a/htools/Ganeti/Luxi.hs b/htools/Ganeti/Luxi.hs index 073f0e0e5540a91ab61fc16d298fe27e2cf0172c..b7d99b9445c4dadec377ae1a7901bc4154d2e407 100644 --- a/htools/Ganeti/Luxi.hs +++ b/htools/Ganeti/Luxi.hs @@ -30,6 +30,8 @@ module Ganeti.Luxi , LuxiReq(..) , Client , JobId + , fromJobId + , makeJobId , RecvResult(..) , strOfOp , getClient @@ -52,7 +54,6 @@ module Ganeti.Luxi import Control.Exception (catch) import Data.IORef -import Data.Ratio (numerator, denominator) import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as UTF8 import Data.Word (Word8) @@ -74,9 +75,9 @@ import Ganeti.JSON import Ganeti.Jobs (JobStatus) import Ganeti.OpParams (pTagsObject) import Ganeti.OpCodes -import Ganeti.Utils import qualified Ganeti.Query.Language as Qlang import Ganeti.THH +import Ganeti.Types -- * Utility functions @@ -96,9 +97,6 @@ data RecvResult = RecvConnClosed -- ^ Connection closed | RecvOk String -- ^ Successfull receive deriving (Show, Eq) --- | The Ganeti job type. -type JobId = Int - -- | Currently supported Luxi operations and JSON serialization. $(genLuxiOp "LuxiOp" [ (luxiReqQuery, @@ -126,7 +124,7 @@ $(genLuxiOp "LuxiOp" , simpleField "lock" [t| Bool |] ]) , (luxiReqQueryJobs, - [ simpleField "ids" [t| [Int] |] + [ simpleField "ids" [t| [JobId] |] , simpleField "fields" [t| [String] |] ]) , (luxiReqQueryExports, @@ -146,24 +144,24 @@ $(genLuxiOp "LuxiOp" [ simpleField "ops" [t| [[OpCode]] |] ] ) , (luxiReqWaitForJobChange, - [ simpleField "job" [t| Int |] + [ simpleField "job" [t| JobId |] , simpleField "fields" [t| [String]|] , simpleField "prev_job" [t| JSValue |] , simpleField "prev_log" [t| JSValue |] , simpleField "tmout" [t| Int |] ]) , (luxiReqArchiveJob, - [ simpleField "job" [t| Int |] ] + [ simpleField "job" [t| JobId |] ] ) , (luxiReqAutoArchiveJobs, [ simpleField "age" [t| Int |] , simpleField "tmout" [t| Int |] ]) , (luxiReqCancelJob, - [ simpleField "job" [t| Int |] ] + [ simpleField "job" [t| JobId |] ] ) , (luxiReqChangeJobPriority, - [ simpleField "job" [t| Int |] + [ simpleField "job" [t| JobId |] , simpleField "priority" [t| Int |] ] ) , (luxiReqSetDrainFlag, @@ -326,10 +324,9 @@ decodeCall :: LuxiCall -> Result LuxiOp decodeCall (LuxiCall call args) = case call of ReqQueryJobs -> do - (jid, jargs) <- fromJVal args - rid <- mapM parseJobId jid + (jids, jargs) <- fromJVal args let rargs = map fromJSString jargs - return $ QueryJobs rid rargs + return $ QueryJobs jids rargs ReqQueryInstances -> do (names, fields, locking) <- fromJVal args return $ QueryInstances names fields locking @@ -372,12 +369,10 @@ decodeCall (LuxiCall call args) = J.readJSON d `ap` J.readJSON e _ -> J.Error "Not enough values" - rid <- parseJobId jid - return $ WaitForJobChange rid fields pinfo pidx wtmout + return $ WaitForJobChange jid fields pinfo pidx wtmout ReqArchiveJob -> do [jid] <- fromJVal args - rid <- parseJobId jid - return $ ArchiveJob rid + return $ ArchiveJob jid ReqAutoArchiveJobs -> do (age, tmout) <- fromJVal args return $ AutoArchiveJobs age tmout @@ -392,13 +387,11 @@ decodeCall (LuxiCall call args) = item <- tagObjectFrom kind name return $ QueryTags item ReqCancelJob -> do - [job] <- fromJVal args - rid <- parseJobId job - return $ CancelJob rid + [jid] <- fromJVal args + return $ CancelJob jid ReqChangeJobPriority -> do - (job, priority) <- fromJVal args - rid <- parseJobId job - return $ ChangeJobPriority rid priority + (jid, priority) <- fromJVal args + return $ ChangeJobPriority jid priority ReqSetDrainFlag -> do [flag] <- fromJVal args return $ SetDrainFlag flag @@ -437,22 +430,12 @@ callMethod method s = do let rval = validateResult result return rval --- | Parses a job ID. -parseJobId :: JSValue -> Result JobId -parseJobId (JSString x) = tryRead "parsing job id" . fromJSString $ x -parseJobId (JSRational _ x) = - if denominator x /= 1 - then Bad $ "Got fractional job ID from master daemon?! Value:" ++ show x - -- FIXME: potential integer overflow here on 32-bit platforms - else Ok . fromIntegral . numerator $ x -parseJobId x = Bad $ "Wrong type/value for job id: " ++ show x - -- | Parse job submission result. parseSubmitJobResult :: JSValue -> ErrorResult JobId parseSubmitJobResult (JSArray [JSBool True, v]) = - case parseJobId v of - Bad msg -> Bad $ LuxiError msg - Ok v' -> Ok v' + case J.readJSON v of + J.Error msg -> Bad $ LuxiError msg + J.Ok v' -> Ok v' parseSubmitJobResult (JSArray [JSBool False, JSString x]) = Bad . LuxiError $ fromJSString x parseSubmitJobResult v = diff --git a/htools/Ganeti/Types.hs b/htools/Ganeti/Types.hs index 90df5656fb9edac5f4be58e7b06d066ee0cede67..b70d704132fc7063e6b529a157f7dbf8e80b662e 100644 --- a/htools/Ganeti/Types.hs +++ b/htools/Ganeti/Types.hs @@ -73,13 +73,18 @@ module Ganeti.Types , nICModeToRaw , FinalizedJobStatus(..) , finalizedJobStatusToRaw + , JobId + , fromJobId + , makeJobId ) where import qualified Text.JSON as JSON +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 @@ -342,3 +347,27 @@ $(THH.declareSADT "FinalizedJobStatus" , ("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