Improve mon-collector drbd CLI handling

[ganeti-local] / htools / Ganeti / Luxi.hs

diff --git a/htools/Ganeti/Luxi.hs b/htools/Ganeti/Luxi.hs
index 8ad7f32..9e5b337 100644 (file)
--- 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,9 +54,10 @@ 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.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)
@@ -71,11 +74,11 @@ import Ganeti.BasicTypes
 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
 
@@ -93,10 +96,7 @@ withTimeout secs descr action = do
 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"
@@ -125,7 +125,7 @@ $(genLuxiOp "LuxiOp"
      , simpleField "lock"   [t| Bool     |]
      ])
   , (luxiReqQueryJobs,
-     [ simpleField "ids"    [t| [Int]    |]
+     [ simpleField "ids"    [t| [JobId]  |]
      , simpleField "fields" [t| [String] |]
      ])
   , (luxiReqQueryExports,
@@ -137,31 +137,33 @@ $(genLuxiOp "LuxiOp"
     )
   , (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 |] ]
@@ -245,9 +247,9 @@ closeClient = hClose . socket
 -- | 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
 
@@ -323,10 +325,11 @@ decodeCall :: LuxiCall -> Result LuxiOp
 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
@@ -369,12 +372,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
@@ -389,9 +390,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
+              (jid, priority) <- fromJVal args
+              return $ ChangeJobPriority jid priority
     ReqSetDrainFlag -> do
               [flag] <- fromJVal args
               return $ SetDrainFlag flag
@@ -430,22 +433,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 =
@@ -453,7 +446,7 @@ 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