code.grnet.gr Git - ganeti-local/blob - hbal.hs

   1 {-| Cluster rebalancer
   2
   3 -}
   4
   5 {-
   6
   7 Copyright (C) 2009, 2010 Google Inc.
   8
   9 This program is free software; you can redistribute it and/or modify
  10 it under the terms of the GNU General Public License as published by
  11 the Free Software Foundation; either version 2 of the License, or
  12 (at your option) any later version.
  13
  14 This program is distributed in the hope that it will be useful, but
  15 WITHOUT ANY WARRANTY; without even the implied warranty of
  16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 General Public License for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with this program; if not, write to the Free Software
  21 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  22 02110-1301, USA.
  23
  24 -}
  25
  26 module Main (main) where
  27
  28 import Control.Concurrent (threadDelay)
  29 import Control.Exception (bracket)
  30 import Data.List
  31 import Data.Maybe (isJust, isNothing, fromJust)
  32 import Data.IORef
  33 import Monad
  34 import System (exitWith, ExitCode(..))
  35 import System.IO
  36 import System.Posix.Process
  37 import System.Posix.Signals
  38 import qualified System
  39
  40 import Text.Printf (printf, hPrintf)
  41
  42 import qualified Ganeti.HTools.Container as Container
  43 import qualified Ganeti.HTools.Cluster as Cluster
  44 import qualified Ganeti.HTools.Node as Node
  45 import qualified Ganeti.HTools.Instance as Instance
  46
  47 import Ganeti.HTools.CLI
  48 import Ganeti.HTools.ExtLoader
  49 import Ganeti.HTools.Utils
  50 import Ganeti.HTools.Types
  51
  52 import Ganeti.HTools.Text (serializeCluster)
  53
  54 import qualified Ganeti.Luxi as L
  55 import Ganeti.Jobs
  56
  57 -- | Options list and functions
  58 options :: [OptType]
  59 options =
  60     [ oPrintNodes
  61     , oPrintInsts
  62     , oPrintCommands
  63     , oOneline
  64     , oDataFile
  65     , oEvacMode
  66     , oRapiMaster
  67     , oLuxiSocket
  68     , oExecJobs
  69     , oGroup
  70     , oMaxSolLength
  71     , oVerbose
  72     , oQuiet
  73     , oOfflineNode
  74     , oMinScore
  75     , oMaxCpu
  76     , oMinDisk
  77     , oMinGain
  78     , oMinGainLim
  79     , oDiskMoves
  80     , oDynuFile
  81     , oExTags
  82     , oExInst
  83     , oSaveCluster
  84     , oShowVer
  85     , oShowHelp
  86     ]
  87
  88 {- | Start computing the solution at the given depth and recurse until
  89 we find a valid solution or we exceed the maximum depth.
  90
  91 -}
  92 iterateDepth :: Cluster.Table    -- ^ The starting table
  93              -> Int              -- ^ Remaining length
  94              -> Bool             -- ^ Allow disk moves
  95              -> Int              -- ^ Max node name len
  96              -> Int              -- ^ Max instance name len
  97              -> [MoveJob]        -- ^ Current command list
  98              -> Bool             -- ^ Whether to be silent
  99              -> Score            -- ^ Score at which to stop
 100              -> Score            -- ^ Min gain limit
 101              -> Score            -- ^ Min score gain
 102              -> Bool             -- ^ Enable evacuation mode
 103              -> IO (Cluster.Table, [MoveJob]) -- ^ The resulting table
 104                                               -- and commands
 105 iterateDepth ini_tbl max_rounds disk_moves nmlen imlen
 106              cmd_strs oneline min_score mg_limit min_gain evac_mode =
 107     let Cluster.Table ini_nl ini_il _ _ = ini_tbl
 108         allowed_next = Cluster.doNextBalance ini_tbl max_rounds min_score
 109         m_fin_tbl = if allowed_next
 110                     then Cluster.tryBalance ini_tbl disk_moves evac_mode
 111                          mg_limit min_gain
 112                     else Nothing
 113     in
 114       case m_fin_tbl of
 115         Just fin_tbl ->
 116             do
 117               let
 118                   (Cluster.Table _ _ _ fin_plc) = fin_tbl
 119                   fin_plc_len = length fin_plc
 120                   cur_plc@(idx, _, _, move, _) = head fin_plc
 121                   (sol_line, cmds) = Cluster.printSolutionLine ini_nl ini_il
 122                                      nmlen imlen cur_plc fin_plc_len
 123                   afn = Cluster.involvedNodes ini_il cur_plc
 124                   upd_cmd_strs = (afn, idx, move, cmds):cmd_strs
 125               unless oneline $ do
 126                        putStrLn sol_line
 127                        hFlush stdout
 128               iterateDepth fin_tbl max_rounds disk_moves
 129                            nmlen imlen upd_cmd_strs oneline min_score
 130                            mg_limit min_gain evac_mode
 131         Nothing -> return (ini_tbl, cmd_strs)
 132
 133 -- | Formats the solution for the oneline display
 134 formatOneline :: Double -> Int -> Double -> String
 135 formatOneline ini_cv plc_len fin_cv =
 136     printf "%.8f %d %.8f %8.3f" ini_cv plc_len fin_cv
 137                (if fin_cv == 0 then 1 else ini_cv / fin_cv)
 138
 139 -- | Polls a set of jobs at a fixed interval until all are finished
 140 -- one way or another
 141 waitForJobs :: L.Client -> [String] -> IO (Result [JobStatus])
 142 waitForJobs client jids = do
 143   sts <- L.queryJobsStatus client jids
 144   case sts of
 145     Bad x -> return $ Bad x
 146     Ok s -> if any (<= JOB_STATUS_RUNNING) s
 147             then do
 148               -- TODO: replace hardcoded value with a better thing
 149               threadDelay (1000000 * 15)
 150               waitForJobs client jids
 151             else return $ Ok s
 152
 153 -- | Check that a set of job statuses is all success
 154 checkJobsStatus :: [JobStatus] -> Bool
 155 checkJobsStatus = all (== JOB_STATUS_SUCCESS)
 156
 157 -- | Execute an entire jobset
 158 execJobSet :: String -> Node.List
 159            -> Instance.List -> IORef Int -> [JobSet] -> IO ()
 160 execJobSet _      _  _  _    [] = return ()
 161 execJobSet master nl il cref alljss@(js:jss) = do
 162   -- map from jobset (htools list of positions) to [[opcodes]]
 163   cancel <- readIORef cref
 164   when (cancel > 0) $ do
 165     putStrLn ("Exiting early due to user request, " ++ show (length alljss) ++
 166               " jobset(s) remaining.")
 167     exitWith $ ExitFailure 1
 168
 169   let jobs = map (\(_, idx, move, _) ->
 170                       Cluster.iMoveToJob nl il idx move) js
 171   let descr = map (\(_, idx, _, _) -> Container.nameOf il idx) js
 172   putStrLn $ "Executing jobset for instances " ++ commaJoin descr
 173   jrs <- bracket (L.getClient master) L.closeClient
 174          (\client -> do
 175             jids <- L.submitManyJobs client jobs
 176             case jids of
 177               Bad x -> return $ Bad x
 178               Ok x -> do
 179                 putStrLn $ "Got job IDs " ++ commaJoin x
 180                 waitForJobs client x
 181          )
 182   (case jrs of
 183      Bad x -> do
 184        hPutStrLn stderr $ "Cannot compute job status, aborting: " ++ show x
 185        return ()
 186      Ok x -> if checkJobsStatus x
 187              then execJobSet master nl il cref jss
 188              else do
 189                hPutStrLn stderr $ "Not all jobs completed successfully: " ++
 190                          show x
 191                hPutStrLn stderr "Aborting.")
 192
 193 -- | Signal handler for graceful termination
 194 hangleSigInt :: IORef Int -> IO ()
 195 hangleSigInt cref = do
 196   writeIORef cref 1
 197   putStrLn ("Cancel request registered, will exit at" ++
 198             " the end of the current job set...")
 199
 200 -- | Signal handler for immediate termination
 201 hangleSigTerm :: IORef Int -> IO ()
 202 hangleSigTerm cref = do
 203   -- update the cref to 2, just for consistency
 204   writeIORef cref 2
 205   putStrLn "Double cancel request, exiting now..."
 206   exitImmediately $ ExitFailure 2
 207
 208 runJobSet :: String -> Node.List -> Instance.List -> [JobSet] -> IO ()
 209 runJobSet master fin_nl il cmd_jobs = do
 210   cref <- newIORef 0
 211   mapM_ (\(hnd, sig) -> installHandler sig (Catch (hnd cref)) Nothing)
 212     [(hangleSigTerm, softwareTermination), (hangleSigInt, keyboardSignal)]
 213   execJobSet master fin_nl il cref cmd_jobs
 214
 215 -- | Main function.
 216 main :: IO ()
 217 main = do
 218   cmd_args <- System.getArgs
 219   (opts, args) <- parseOpts cmd_args "hbal" options
 220
 221   unless (null args) $ do
 222          hPutStrLn stderr "Error: this program doesn't take any arguments."
 223          exitWith $ ExitFailure 1
 224
 225   let oneline = optOneline opts
 226       verbose = optVerbose opts
 227       shownodes = optShowNodes opts
 228
 229   (_, fixed_nl, ilf, ctags) <- loadExternalData opts
 230
 231   let offline_names = optOffline opts
 232       all_nodes = Container.elems fixed_nl
 233       all_names = concatMap allNames all_nodes
 234       offline_wrong = filter (`notElem` all_names) offline_names
 235       offline_indices = map Node.idx $
 236                         filter (\n ->
 237                                  Node.name n `elem` offline_names ||
 238                                  Node.alias n `elem` offline_names)
 239                                all_nodes
 240       m_cpu = optMcpu opts
 241       m_dsk = optMdsk opts
 242       csf = commonSuffix fixed_nl ilf
 243
 244   when (length offline_wrong > 0) $ do
 245          hPrintf stderr "Wrong node name(s) set as offline: %s\n"
 246                      (commaJoin offline_wrong) :: IO ()
 247          exitWith $ ExitFailure 1
 248
 249   let nm = Container.map (\n -> if Node.idx n `elem` offline_indices
 250                                 then Node.setOffline n True
 251                                 else n) fixed_nl
 252       nlf = Container.map (flip Node.setMdsk m_dsk . flip Node.setMcpu m_cpu)
 253             nm
 254
 255   when (not oneline && verbose > 1) $
 256        putStrLn $ "Loaded cluster tags: " ++ intercalate "," ctags
 257
 258   when (Container.size ilf == 0) $ do
 259          (if oneline then putStrLn $ formatOneline 0 0 0
 260           else printf "Cluster is empty, exiting.\n")
 261          exitWith ExitSuccess
 262
 263   let split_insts = Cluster.findSplitInstances nlf ilf
 264   when (not . null $ split_insts) $ do
 265     hPutStrLn stderr "Found instances belonging to multiple node groups:"
 266     mapM_ (\i -> hPutStrLn stderr $ "  " ++ Instance.name i) split_insts
 267     hPutStrLn stderr "Aborting."
 268     exitWith $ ExitFailure 1
 269
 270   let ngroups = Cluster.splitCluster nlf ilf
 271   when (length ngroups > 1 && isNothing (optGroup opts)) $ do
 272     hPutStrLn stderr "Found multiple node groups:"
 273     mapM_ (hPutStrLn stderr . ("  " ++) . fst ) ngroups
 274     hPutStrLn stderr "Aborting."
 275     exitWith $ ExitFailure 1
 276
 277   unless oneline $ printf "Loaded %d nodes, %d instances\n"
 278              (Container.size nlf)
 279              (Container.size ilf)
 280
 281   (guuid, (nl, il)) <- case optGroup opts of
 282     Nothing -> return $ head ngroups
 283     Just g -> case lookup g ngroups of
 284       Nothing -> do
 285         hPutStrLn stderr $ "Node group " ++ g ++
 286           " not found. Node group list is:"
 287         mapM_ (hPutStrLn stderr . ("  " ++) . fst ) ngroups
 288         hPutStrLn stderr "Aborting."
 289         exitWith $ ExitFailure 1
 290       Just cdata -> return (g, cdata)
 291
 292   unless oneline $ printf "Group size %d nodes, %d instances\n"
 293              (Container.size nl)
 294              (Container.size il)
 295
 296   putStrLn $ "Selected node group: " ++ guuid
 297
 298   when (length csf > 0 && not oneline && verbose > 1) $
 299        printf "Note: Stripping common suffix of '%s' from names\n" csf
 300
 301   let (bad_nodes, bad_instances) = Cluster.computeBadItems nl il
 302   unless (oneline || verbose == 0) $ printf
 303              "Initial check done: %d bad nodes, %d bad instances.\n"
 304              (length bad_nodes) (length bad_instances)
 305
 306   when (length bad_nodes > 0) $
 307          putStrLn "Cluster is not N+1 happy, continuing but no guarantee \
 308                   \that the cluster will end N+1 happy."
 309
 310   when (optShowInsts opts) $ do
 311          putStrLn ""
 312          putStrLn "Initial instance map:"
 313          putStrLn $ Cluster.printInsts nl il
 314
 315   when (isJust shownodes) $
 316        do
 317          putStrLn "Initial cluster status:"
 318          putStrLn $ Cluster.printNodes nl (fromJust shownodes)
 319
 320   let ini_cv = Cluster.compCV nl
 321       ini_tbl = Cluster.Table nl il ini_cv []
 322       min_cv = optMinScore opts
 323
 324   when (ini_cv < min_cv) $ do
 325          (if oneline then
 326               putStrLn $ formatOneline ini_cv 0 ini_cv
 327           else printf "Cluster is already well balanced (initial score %.6g,\n\
 328                       \minimum score %.6g).\nNothing to do, exiting\n"
 329                       ini_cv min_cv)
 330          exitWith ExitSuccess
 331
 332   unless oneline (if verbose > 2 then
 333                       printf "Initial coefficients: overall %.8f, %s\n"
 334                       ini_cv (Cluster.printStats nl)
 335                   else
 336                       printf "Initial score: %.8f\n" ini_cv)
 337
 338   unless oneline $ putStrLn "Trying to minimize the CV..."
 339   let imlen = maximum . map (length . Instance.alias) $ Container.elems il
 340       nmlen = maximum . map (length . Node.alias) $ Container.elems nl
 341
 342   (fin_tbl, cmd_strs) <- iterateDepth ini_tbl (optMaxLength opts)
 343                          (optDiskMoves opts)
 344                          nmlen imlen [] oneline min_cv
 345                          (optMinGainLim opts) (optMinGain opts)
 346                          (optEvacMode opts)
 347   let (Cluster.Table fin_nl fin_il fin_cv fin_plc) = fin_tbl
 348       ord_plc = reverse fin_plc
 349       sol_msg = if null fin_plc
 350                 then printf "No solution found\n"
 351                 else if verbose > 2
 352                      then printf "Final coefficients:   overall %.8f, %s\n"
 353                           fin_cv (Cluster.printStats fin_nl)
 354                      else printf "Cluster score improved from %.8f to %.8f\n"
 355                           ini_cv fin_cv
 356                               ::String
 357
 358   unless oneline $ putStr sol_msg
 359
 360   unless (oneline || verbose == 0) $
 361          printf "Solution length=%d\n" (length ord_plc)
 362
 363   let cmd_jobs = Cluster.splitJobs cmd_strs
 364       cmd_data = Cluster.formatCmds cmd_jobs
 365
 366   when (isJust $ optShowCmds opts) $
 367        do
 368          let out_path = fromJust $ optShowCmds opts
 369          putStrLn ""
 370          (if out_path == "-" then
 371               printf "Commands to run to reach the above solution:\n%s"
 372                      (unlines . map ("  " ++) .
 373                       filter (/= "  check") .
 374                       lines $ cmd_data)
 375           else do
 376             writeFile out_path (shTemplate ++ cmd_data)
 377             printf "The commands have been written to file '%s'\n" out_path)
 378
 379   when (isJust $ optSaveCluster opts) $
 380        do
 381          let out_path = fromJust $ optSaveCluster opts
 382              adata = serializeCluster fin_nl fin_il
 383          writeFile out_path adata
 384          printf "The cluster state has been written to file '%s'\n" out_path
 385
 386   when (optShowInsts opts) $ do
 387          putStrLn ""
 388          putStrLn "Final instance map:"
 389          putStr $ Cluster.printInsts fin_nl fin_il
 390
 391   when (isJust shownodes) $
 392        do
 393          let ini_cs = Cluster.totalResources nl
 394              fin_cs = Cluster.totalResources fin_nl
 395          putStrLn ""
 396          putStrLn "Final cluster status:"
 397          putStrLn $ Cluster.printNodes fin_nl (fromJust shownodes)
 398          when (verbose > 3) $
 399               do
 400                 printf "Original: mem=%d disk=%d\n"
 401                        (Cluster.csFmem ini_cs) (Cluster.csFdsk ini_cs) :: IO ()
 402                 printf "Final:    mem=%d disk=%d\n"
 403                        (Cluster.csFmem fin_cs) (Cluster.csFdsk fin_cs)
 404   when oneline $
 405          putStrLn $ formatOneline ini_cv (length ord_plc) fin_cv
 406
 407   when (optExecJobs opts && not (null ord_plc))
 408            (case optLuxi opts of
 409               Nothing -> do
 410                 hPutStrLn stderr "Execution of commands possible only on LUXI"
 411                 exitWith $ ExitFailure 1
 412               Just master -> runJobSet master fin_nl il cmd_jobs)