Revision 36cb6837

b/src/Ganeti/Query/Server.hs
303 303
  _ <- executeRpcCall mcs $ RpcCallSetDrainFlag value
304 304
  return . Ok . showJSON $ True
305 305

  
306
handleCall _ qstat  cfg (CancelJob jid) = do
307
  let jName = (++) "job " . show $ fromJobId jid
308
  dequeueResult <- dequeueJob qstat jid
309
  case dequeueResult of
310
    Ok True -> do
311
      logDebug $ jName ++ " dequeued, marking as canceled"
312
      qDir <- queueDir
313
      readResult <- loadJobFromDisk qDir True jid
314
      let jobFileFailed = return . Ok . showJSON . (,) False
315
                            . (++) ("Dequeued " ++ jName
316
                                    ++ ", but failed to mark as cancelled: ")
317
                          :: String -> IO (ErrorResult JSValue)
318
      case readResult of
319
        Bad s -> jobFileFailed s
320
        Ok (job, _) -> do
321
          now <- currentTimestamp
322
          let job' = cancelQueuedJob now job
323
              mcs = Config.getMasterCandidates cfg
324
          write_result <- writeJobToDisk qDir job'
325
          case write_result of
326
            Bad s -> jobFileFailed s
327
            Ok () -> do
328
              replicateManyJobs qDir mcs [job']
329
              return . Ok . showJSON $ (True, "Dequeued " ++ jName)
330
    Ok False -> do
331
      logDebug $ jName ++ " not queued; trying to cancel directly"
332
      cancelJob jid
333
    Bad s -> return . Ok . showJSON $ (False, s)
334

  
306 335
handleCall _ _ _ op =
307 336
  return . Bad $
308 337
    GenericError ("Luxi call '" ++ strOfOp op ++ "' not implemented")

Also available in: Unified diff