From c48711d5c17aa1cc7ab0a5974245068c981d6aa2 Mon Sep 17 00:00:00 2001
From: Iustin Pop <iustin@google.com>
Date: Tue, 27 Nov 2012 16:45:39 +0100
Subject: [PATCH] Add a 'real' type for JobIds
Currently, the job ID is a simple type alias. This is suboptimal, as
it means we can't use a custom JSON (or Arbitrary) instance for it.
The patch changes it into a newtype, and then a) simplifies some
deserialisation code and b) changes some more fields to this new type
(rather than plain 'Int').
We also move the JobId to types, since it will be needed in opcodes as
well.
Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Guido Trotter <ultrotter@google.com>
---
htest/Test/Ganeti/Types.hs | 15 +++++++++++
htools/Ganeti/Luxi.hs | 55 +++++++++++++-------------------------
htools/Ganeti/Types.hs | 29 ++++++++++++++++++++
3 files changed, 63 insertions(+), 36 deletions(-)
diff --git a/htest/Test/Ganeti/Types.hs b/htest/Test/Ganeti/Types.hs
index 790f94819..79abcef63 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 073f0e0e5..b7d99b944 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 90df5656f..b70d70413 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
--
GitLab