- do
- let
- (sol_line, cmds) = Cluster.printSolutionLine ini_il ktn kti
- nmlen imlen (head fin_plc) fin_plc_len
- upd_cmd_strs = cmds:cmd_strs
- unless (oneline || fin_plc_len == ini_plc_len) $ do
- putStrLn sol_line
- hFlush stdout
- (if fin_cv < ini_cv then -- this round made success, try deeper
- if allowed_next && fin_cv > min_score
- then iterateDepth fin_tbl max_rounds ktn kti
- nmlen imlen upd_cmd_strs oneline min_score
- -- don't go deeper, but return the better solution
- else return (fin_tbl, upd_cmd_strs)
- else
- return (ini_tbl, cmd_strs))
+ case m_fin_tbl of
+ Just fin_tbl ->
+ do
+ let
+ (Cluster.Table _ _ _ fin_plc) = fin_tbl
+ fin_plc_len = length fin_plc
+ cur_plc@(idx, _, _, move, _) = head fin_plc
+ (sol_line, cmds) = Cluster.printSolutionLine ini_nl ini_il
+ nmlen imlen cur_plc fin_plc_len
+ afn = Cluster.involvedNodes ini_il cur_plc
+ upd_cmd_strs = (afn, idx, move, cmds):cmd_strs
+ unless oneline $ do
+ putStrLn sol_line
+ hFlush stdout
+ iterateDepth fin_tbl max_rounds disk_moves
+ nmlen imlen upd_cmd_strs oneline min_score
+ evac_mode
+ Nothing -> return (ini_tbl, cmd_strs)
+
+-- | Formats the solution for the oneline display
+formatOneline :: Double -> Int -> Double -> String
+formatOneline ini_cv plc_len fin_cv =
+ printf "%.8f %d %.8f %8.3f" ini_cv plc_len fin_cv
+ (if fin_cv == 0 then 1 else ini_cv / fin_cv)
+
+-- | 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.")
projects / ganeti-local / blobdiff