Synnefo » snf-ganeti

import Control.Concurrent (threadDelay)

import Control.Exception (bracket)

import Text.JSON (showJSON)

import qualified Ganeti.HTools.Instance as Instance

import qualified Ganeti.Luxi as L

import qualified Ganeti.OpCodes as OpCodes

import Ganeti.Jobs

    , oExecJobs

-- | Submits a list of jobs and waits for all to finish execution

execJobs :: L.Client -> [[OpCodes.OpCode]] -> IO (Result [String])

execJobs client = L.submitManyJobs client . showJSON

-- | Polls a set of jobs at a fixed interval until all are finished

-- one way or another

waitForJobs :: L.Client -> [String] -> IO (Result [JobStatus])

waitForJobs client jids = do

  sts <- L.queryJobsStatus client jids

  case sts of

    Bad x -> return $ Bad x

    Ok s -> if any (<= JobRunning) s

            then do

              -- TODO: replace hardcoded value with a better thing

              threadDelay (1000000 * 15)

              waitForJobs client jids

            else return $ Ok s

-- | Check that a set of job statuses is all success

checkJobsStatus :: [JobStatus] -> Bool

checkJobsStatus = all (== JobSuccess)

-- | Execute an entire jobset

execJobSet :: String -> String -> Node.List

           -> Instance.List -> [JobSet] -> IO ()

execJobSet _      _   _  _  [] = return ()

execJobSet master csf nl il (js:jss) = do

  -- map from jobset (htools list of positions) to [[opcodes]]

  let jobs = map (\(_, idx, move, _) ->

                      Cluster.iMoveToJob csf nl il idx move) js

  let descr = map (\(_, idx, _, _) -> Container.nameOf il idx) js

  putStrLn $ "Executing jobset for instances " ++ commaJoin descr

  jrs <- bracket (L.getClient master) L.closeClient

         (\client -> do

            jids <- execJobs client jobs

            case jids of

              Bad x -> return $ Bad x

              Ok x -> do

                putStrLn $ "Got job IDs " ++ commaJoin x

                waitForJobs client x

         )

  (case jrs of

     Bad x -> do

       hPutStrLn stderr $ "Cannot compute job status, aborting: " ++ show x

       return ()

     Ok x -> if checkJobsStatus x

             then execJobSet master csf nl il jss

             else do

               hPutStrLn stderr $ "Not all jobs completed successfully: " ++

                         show x

               hPutStrLn stderr "Aborting.")

  let cmd_jobs = Cluster.splitJobs cmd_strs

      cmd_data = Cluster.formatCmds cmd_jobs

  when (optExecJobs opts && not (null ord_plc))

           (case optLuxi opts of

              Nothing -> do

                hPutStrLn stderr "Execution of commands possible only on LUXI"

                exitWith $ ExitFailure 1

              Just master -> execJobSet master csf fin_nl il cmd_jobs)