, LuxiReq(..)
, Client
, JobId
+ , fromJobId
+ , makeJobId
, RecvResult(..)
, strOfOp
, getClient
import Control.Exception (catch)
import Data.IORef
-import Data.Ratio (numerator, denominator)
import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.UTF8 as UTF8
+import qualified Data.ByteString.Lazy.UTF8 as UTF8L
import Data.Word (Word8)
import Control.Monad
import Text.JSON (encodeStrict, decodeStrict)
import Ganeti.Constants
import Ganeti.Errors
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
data RecvResult = RecvConnClosed -- ^ Connection closed
| RecvError String -- ^ Any other error
| RecvOk String -- ^ Successfull receive
- deriving (Show, Read, Eq)
-
--- | The Ganeti job type.
-type JobId = Int
+ deriving (Show, Eq)
-- | Currently supported Luxi operations and JSON serialization.
$(genLuxiOp "LuxiOp"
, simpleField "lock" [t| Bool |]
])
, (luxiReqQueryJobs,
- [ simpleField "ids" [t| [Int] |]
+ [ simpleField "ids" [t| [JobId] |]
, simpleField "fields" [t| [String] |]
])
, (luxiReqQueryExports,
)
, (luxiReqQueryClusterInfo, [])
, (luxiReqQueryTags,
- [ customField 'decodeTagObject 'encodeTagObject $
- simpleField "kind" [t| TagObject |]
- ])
+ [ pTagsObject ])
, (luxiReqSubmitJob,
- [ simpleField "job" [t| [OpCode] |] ]
+ [ simpleField "job" [t| [MetaOpCode] |] ]
)
, (luxiReqSubmitManyJobs,
- [ simpleField "ops" [t| [[OpCode]] |] ]
+ [ simpleField "ops" [t| [[MetaOpCode]] |] ]
)
, (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| JobId |]
+ , simpleField "priority" [t| Int |] ]
)
, (luxiReqSetDrainFlag,
[ simpleField "flag" [t| Bool |] ]
-- | Sends a message over a luxi transport.
sendMsg :: Client -> String -> IO ()
sendMsg s buf = withTimeout luxiDefRwto "sending luxi message" $ do
- let encoded = UTF8.fromString buf
+ let encoded = UTF8L.fromString buf
handle = socket s
- B.hPut handle encoded
+ BL.hPut handle encoded
B.hPut handle bEOM
hFlush handle
decodeCall (LuxiCall call args) =
case call of
ReqQueryJobs -> do
- (jid, jargs) <- fromJVal args
- rid <- mapM parseJobId jid
- let rargs = map fromJSString jargs
- return $ QueryJobs rid rargs
+ (jids, jargs) <- fromJVal args
+ jids' <- case jids of
+ JSNull -> return []
+ _ -> fromJVal jids
+ return $ QueryJobs jids' jargs
ReqQueryInstances -> do
(names, fields, locking) <- fromJVal args
return $ QueryInstances names fields locking
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
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
+ (jid, priority) <- fromJVal args
+ return $ ChangeJobPriority jid priority
ReqSetDrainFlag -> do
[flag] <- fromJVal args
return $ SetDrainFlag flag
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 =
show (pp_value v)
-- | Specialized submitManyJobs call.
-submitManyJobs :: Client -> [[OpCode]] -> IO (ErrorResult [JobId])
+submitManyJobs :: Client -> [[MetaOpCode]] -> IO (ErrorResult [JobId])
submitManyJobs s jobs = do
rval <- callMethod (SubmitManyJobs jobs) s
-- map each result (status, payload) pair into a nice Result ADT