code.grnet.gr Git - ganeti-local/blob - htools/Ganeti/HTools/Program/Hbal.hs

   1 {-| Cluster rebalancer.
   2
   3 -}
   4
   5 {-
   6
   7 Copyright (C) 2009, 2010, 2011, 2012 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 Ganeti.HTools.Program.Hbal
  27   ( main
  28   , options
  29   , arguments
  30   , iterateDepth
  31   ) where
  32
  33 import Control.Concurrent (threadDelay)
  34 import Control.Exception (bracket)
  35 import Control.Monad
  36 import Data.List
  37 import Data.Maybe (isJust, isNothing, fromJust)
  38 import Data.IORef
  39 import System.Exit
  40 import System.IO
  41 import System.Posix.Process
  42 import System.Posix.Signals
  43
  44 import Text.Printf (printf, hPrintf)
  45
  46 import qualified Ganeti.HTools.Container as Container
  47 import qualified Ganeti.HTools.Cluster as Cluster
  48 import qualified Ganeti.HTools.Group as Group
  49 import qualified Ganeti.HTools.Node as Node
  50 import qualified Ganeti.HTools.Instance as Instance
  51
  52 import Ganeti.BasicTypes
  53 import Ganeti.Common
  54 import Ganeti.Errors
  55 import Ganeti.HTools.CLI
  56 import Ganeti.HTools.ExtLoader
  57 import Ganeti.HTools.Types
  58 import Ganeti.HTools.Loader
  59 import Ganeti.Utils
  60
  61 import qualified Ganeti.Luxi as L
  62 import Ganeti.Jobs
  63
  64 -- | Options list and functions.
  65 options :: [OptType]
  66 options =
  67   [ oPrintNodes
  68   , oPrintInsts
  69   , oPrintCommands
  70   , oDataFile
  71   , oEvacMode
  72   , oRapiMaster
  73   , oLuxiSocket
  74   , oIAllocSrc
  75   , oExecJobs
  76   , oGroup
  77   , oMaxSolLength
  78   , oVerbose
  79   , oQuiet
  80   , oOfflineNode
  81   , oMinScore
  82   , oMaxCpu
  83   , oMinDisk
  84   , oMinGain
  85   , oMinGainLim
  86   , oDiskMoves
  87   , oSelInst
  88   , oInstMoves
  89   , oDynuFile
  90   , oExTags
  91   , oExInst
  92   , oSaveCluster
  93   ]
  94
  95 -- | The list of arguments supported by the program.
  96 arguments :: [ArgCompletion]
  97 arguments = []
  98
  99 {- | Start computing the solution at the given depth and recurse until
 100 we find a valid solution or we exceed the maximum depth.
 101
 102 -}
 103 iterateDepth :: Bool             -- ^ Whether to print moves
 104              -> Cluster.Table    -- ^ The starting table
 105              -> Int              -- ^ Remaining length
 106              -> Bool             -- ^ Allow disk moves
 107              -> Bool             -- ^ Allow instance moves
 108              -> Int              -- ^ Max node name len
 109              -> Int              -- ^ Max instance name len
 110              -> [MoveJob]        -- ^ Current command list
 111              -> Score            -- ^ Score at which to stop
 112              -> Score            -- ^ Min gain limit
 113              -> Score            -- ^ Min score gain
 114              -> Bool             -- ^ Enable evacuation mode
 115              -> IO (Cluster.Table, [MoveJob]) -- ^ The resulting table
 116                                               -- and commands
 117 iterateDepth printmove ini_tbl max_rounds disk_moves inst_moves nmlen imlen
 118              cmd_strs min_score mg_limit min_gain evac_mode =
 119   let Cluster.Table ini_nl ini_il _ _ = ini_tbl
 120       allowed_next = Cluster.doNextBalance ini_tbl max_rounds min_score
 121       m_fin_tbl = if allowed_next
 122                     then Cluster.tryBalance ini_tbl disk_moves inst_moves
 123                          evac_mode mg_limit min_gain
 124                     else Nothing
 125   in case m_fin_tbl of
 126        Just fin_tbl ->
 127          do
 128            let (Cluster.Table _ _ _ fin_plc) = fin_tbl
 129                fin_plc_len = length fin_plc
 130                cur_plc@(idx, _, _, move, _) = head fin_plc
 131                (sol_line, cmds) = Cluster.printSolutionLine ini_nl ini_il
 132                                   nmlen imlen cur_plc fin_plc_len
 133                afn = Cluster.involvedNodes ini_il cur_plc
 134                upd_cmd_strs = (afn, idx, move, cmds):cmd_strs
 135            when printmove $ do
 136                putStrLn sol_line
 137                hFlush stdout
 138            iterateDepth printmove fin_tbl max_rounds disk_moves inst_moves
 139                         nmlen imlen upd_cmd_strs min_score
 140                         mg_limit min_gain evac_mode
 141        Nothing -> return (ini_tbl, cmd_strs)
 142
 143 -- | Displays the cluster stats.
 144 printStats :: Node.List -> Node.List -> IO ()
 145 printStats ini_nl fin_nl = do
 146   let ini_cs = Cluster.totalResources ini_nl
 147       fin_cs = Cluster.totalResources fin_nl
 148   printf "Original: mem=%d disk=%d\n"
 149              (Cluster.csFmem ini_cs) (Cluster.csFdsk ini_cs) :: IO ()
 150   printf "Final:    mem=%d disk=%d\n"
 151              (Cluster.csFmem fin_cs) (Cluster.csFdsk fin_cs)
 152
 153 -- | Saves the rebalance commands to a text file.
 154 saveBalanceCommands :: Options -> String -> IO ()
 155 saveBalanceCommands opts cmd_data = do
 156   let out_path = fromJust $ optShowCmds opts
 157   putStrLn ""
 158   if out_path == "-"
 159     then printf "Commands to run to reach the above solution:\n%s"
 160            (unlines . map ("  " ++) .
 161             filter (/= "  check") .
 162             lines $ cmd_data)
 163     else do
 164       writeFile out_path (shTemplate ++ cmd_data)
 165       printf "The commands have been written to file '%s'\n" out_path
 166
 167 -- | Polls a set of jobs at a fixed interval until all are finished
 168 -- one way or another.
 169 waitForJobs :: L.Client -> [L.JobId] -> IO (Result [JobStatus])
 170 waitForJobs client jids = do
 171   sts <- L.queryJobsStatus client jids
 172   case sts of
 173     Bad e -> return . Bad $ "Checking job status: " ++ formatError e
 174     Ok s -> if any (<= JOB_STATUS_RUNNING) s
 175             then do
 176               -- TODO: replace hardcoded value with a better thing
 177               threadDelay (1000000 * 15)
 178               waitForJobs client jids
 179             else return $ Ok s
 180
 181 -- | Check that a set of job statuses is all success.
 182 checkJobsStatus :: [JobStatus] -> Bool
 183 checkJobsStatus = all (== JOB_STATUS_SUCCESS)
 184
 185 -- | Wrapper over execJobSet checking for early termination.
 186 execWrapper :: String -> Node.List
 187             -> Instance.List -> IORef Int -> [JobSet] -> IO Bool
 188 execWrapper _      _  _  _    [] = return True
 189 execWrapper master nl il cref alljss = do
 190   cancel <- readIORef cref
 191   if cancel > 0
 192     then do
 193       hPrintf stderr "Exiting early due to user request, %d\
 194                      \ jobset(s) remaining." (length alljss)::IO ()
 195       return True
 196     else execJobSet master nl il cref alljss
 197
 198 -- | Execute an entire jobset.
 199 execJobSet :: String -> Node.List
 200            -> Instance.List -> IORef Int -> [JobSet] -> IO Bool
 201 execJobSet _      _  _  _    [] = return True
 202 execJobSet master nl il cref (js:jss) = do
 203   -- map from jobset (htools list of positions) to [[opcodes]]
 204   let jobs = map (\(_, idx, move, _) ->
 205                       Cluster.iMoveToJob nl il idx move) js
 206   let descr = map (\(_, idx, _, _) -> Container.nameOf il idx) js
 207   putStrLn $ "Executing jobset for instances " ++ commaJoin descr
 208   jrs <- bracket (L.getClient master) L.closeClient
 209          (\client -> do
 210             jids <- L.submitManyJobs client jobs
 211             case jids of
 212               Bad e -> return . Bad $ "Job submission error: " ++ formatError e
 213               Ok x -> do
 214                 putStrLn $ "Got job IDs " ++ commaJoin (map show x)
 215                 waitForJobs client x
 216          )
 217   case jrs of
 218     Bad x -> do
 219       hPutStrLn stderr x
 220       return False
 221     Ok x -> if checkJobsStatus x
 222               then execWrapper master nl il cref jss
 223               else do
 224                 hPutStrLn stderr $ "Not all jobs completed successfully: " ++
 225                           show x
 226                 hPutStrLn stderr "Aborting."
 227                 return False
 228
 229 -- | Executes the jobs, if possible and desired.
 230 maybeExecJobs :: Options
 231               -> [a]
 232               -> Node.List
 233               -> Instance.List
 234               -> [JobSet]
 235               -> IO Bool
 236 maybeExecJobs opts ord_plc fin_nl il cmd_jobs =
 237   if optExecJobs opts && not (null ord_plc)
 238     then (case optLuxi opts of
 239             Nothing -> do
 240               hPutStrLn stderr "Execution of commands possible only on LUXI"
 241               return False
 242             Just master -> runJobSet master fin_nl il cmd_jobs)
 243     else return True
 244
 245 -- | Signal handler for graceful termination.
 246 hangleSigInt :: IORef Int -> IO ()
 247 hangleSigInt cref = do
 248   writeIORef cref 1
 249   putStrLn ("Cancel request registered, will exit at" ++
 250             " the end of the current job set...")
 251
 252 -- | Signal handler for immediate termination.
 253 hangleSigTerm :: IORef Int -> IO ()
 254 hangleSigTerm cref = do
 255   -- update the cref to 2, just for consistency
 256   writeIORef cref 2
 257   putStrLn "Double cancel request, exiting now..."
 258   exitImmediately $ ExitFailure 2
 259
 260 -- | Runs a job set with handling of signals.
 261 runJobSet :: String -> Node.List -> Instance.List -> [JobSet] -> IO Bool
 262 runJobSet master fin_nl il cmd_jobs = do
 263   cref <- newIORef 0
 264   mapM_ (\(hnd, sig) -> installHandler sig (Catch (hnd cref)) Nothing)
 265     [(hangleSigTerm, softwareTermination), (hangleSigInt, keyboardSignal)]
 266   execWrapper master fin_nl il cref cmd_jobs
 267
 268 -- | Select the target node group.
 269 selectGroup :: Options -> Group.List -> Node.List -> Instance.List
 270             -> IO (String, (Node.List, Instance.List))
 271 selectGroup opts gl nlf ilf = do
 272   let ngroups = Cluster.splitCluster nlf ilf
 273   when (length ngroups > 1 && isNothing (optGroup opts)) $ do
 274     hPutStrLn stderr "Found multiple node groups:"
 275     mapM_ (hPutStrLn stderr . ("  " ++) . Group.name .
 276            flip Container.find gl . fst) ngroups
 277     exitErr "Aborting."
 278
 279   case optGroup opts of
 280     Nothing -> do
 281       let (gidx, cdata) = head ngroups
 282           grp = Container.find gidx gl
 283       return (Group.name grp, cdata)
 284     Just g -> case Container.findByName gl g of
 285       Nothing -> do
 286         hPutStrLn stderr $ "Node group " ++ g ++
 287           " not found. Node group list is:"
 288         mapM_ (hPutStrLn stderr . ("  " ++) . Group.name ) (Container.elems gl)
 289         exitErr "Aborting."
 290       Just grp ->
 291           case lookup (Group.idx grp) ngroups of
 292             Nothing ->
 293               -- This will only happen if there are no nodes assigned
 294               -- to this group
 295               return (Group.name grp, (Container.empty, Container.empty))
 296             Just cdata -> return (Group.name grp, cdata)
 297
 298 -- | Do a few checks on the cluster data.
 299 checkCluster :: Int -> Node.List -> Instance.List -> IO ()
 300 checkCluster verbose nl il = do
 301   -- nothing to do on an empty cluster
 302   when (Container.null il) $ do
 303          printf "Cluster is empty, exiting.\n"::IO ()
 304          exitSuccess
 305
 306   -- hbal doesn't currently handle split clusters
 307   let split_insts = Cluster.findSplitInstances nl il
 308   unless (null split_insts || verbose <= 1) $ do
 309     hPutStrLn stderr "Found instances belonging to multiple node groups:"
 310     mapM_ (\i -> hPutStrLn stderr $ "  " ++ Instance.name i) split_insts
 311     hPutStrLn stderr "These instances will not be moved."
 312
 313   printf "Loaded %d nodes, %d instances\n"
 314              (Container.size nl)
 315              (Container.size il)::IO ()
 316
 317   let csf = commonSuffix nl il
 318   when (not (null csf) && verbose > 1) $
 319        printf "Note: Stripping common suffix of '%s' from names\n" csf
 320
 321 -- | Do a few checks on the selected group data.
 322 checkGroup :: Int -> String -> Node.List -> Instance.List -> IO ()
 323 checkGroup verbose gname nl il = do
 324   printf "Group size %d nodes, %d instances\n"
 325              (Container.size nl)
 326              (Container.size il)::IO ()
 327
 328   putStrLn $ "Selected node group: " ++ gname
 329
 330   let (bad_nodes, bad_instances) = Cluster.computeBadItems nl il
 331   unless (verbose == 0) $ printf
 332              "Initial check done: %d bad nodes, %d bad instances.\n"
 333              (length bad_nodes) (length bad_instances)
 334
 335   unless (null bad_nodes) $
 336          putStrLn "Cluster is not N+1 happy, continuing but no guarantee \
 337                   \that the cluster will end N+1 happy."
 338
 339 -- | Check that we actually need to rebalance.
 340 checkNeedRebalance :: Options -> Score -> IO ()
 341 checkNeedRebalance opts ini_cv = do
 342   let min_cv = optMinScore opts
 343   when (ini_cv < min_cv) $ do
 344          printf "Cluster is already well balanced (initial score %.6g,\n\
 345                 \minimum score %.6g).\nNothing to do, exiting\n"
 346                 ini_cv min_cv:: IO ()
 347          exitSuccess
 348
 349 -- | Main function.
 350 main :: Options -> [String] -> IO ()
 351 main opts args = do
 352   unless (null args) $ exitErr "This program doesn't take any arguments."
 353
 354   let verbose = optVerbose opts
 355       shownodes = optShowNodes opts
 356       showinsts = optShowInsts opts
 357
 358   ini_cdata@(ClusterData gl fixed_nl ilf ctags ipol) <- loadExternalData opts
 359
 360   when (verbose > 1) $ do
 361        putStrLn $ "Loaded cluster tags: " ++ intercalate "," ctags
 362        putStrLn $ "Loaded cluster ipolicy: " ++ show ipol
 363
 364   nlf <- setNodeStatus opts fixed_nl
 365   checkCluster verbose nlf ilf
 366
 367   maybeSaveData (optSaveCluster opts) "original" "before balancing" ini_cdata
 368
 369   (gname, (nl, il)) <- selectGroup opts gl nlf ilf
 370
 371   checkGroup verbose gname nl il
 372
 373   maybePrintInsts showinsts "Initial" (Cluster.printInsts nl il)
 374
 375   maybePrintNodes shownodes "Initial cluster" (Cluster.printNodes nl)
 376
 377   let ini_cv = Cluster.compCV nl
 378       ini_tbl = Cluster.Table nl il ini_cv []
 379       min_cv = optMinScore opts
 380
 381   checkNeedRebalance opts ini_cv
 382
 383   if verbose > 2
 384     then printf "Initial coefficients: overall %.8f\n%s"
 385            ini_cv (Cluster.printStats "  " nl)::IO ()
 386     else printf "Initial score: %.8f\n" ini_cv
 387
 388   putStrLn "Trying to minimize the CV..."
 389   let imlen = maximum . map (length . Instance.alias) $ Container.elems il
 390       nmlen = maximum . map (length . Node.alias) $ Container.elems nl
 391
 392   (fin_tbl, cmd_strs) <- iterateDepth True ini_tbl (optMaxLength opts)
 393                          (optDiskMoves opts)
 394                          (optInstMoves opts)
 395                          nmlen imlen [] min_cv
 396                          (optMinGainLim opts) (optMinGain opts)
 397                          (optEvacMode opts)
 398   let (Cluster.Table fin_nl fin_il fin_cv fin_plc) = fin_tbl
 399       ord_plc = reverse fin_plc
 400       sol_msg = case () of
 401                   _ | null fin_plc -> printf "No solution found\n"
 402                     | verbose > 2 ->
 403                         printf "Final coefficients:   overall %.8f\n%s"
 404                         fin_cv (Cluster.printStats "  " fin_nl)
 405                     | otherwise ->
 406                         printf "Cluster score improved from %.8f to %.8f\n"
 407                         ini_cv fin_cv ::String
 408
 409   putStr sol_msg
 410
 411   unless (verbose == 0) $
 412          printf "Solution length=%d\n" (length ord_plc)
 413
 414   let cmd_jobs = Cluster.splitJobs cmd_strs
 415
 416   when (isJust $ optShowCmds opts) .
 417        saveBalanceCommands opts $ Cluster.formatCmds cmd_jobs
 418
 419   maybeSaveData (optSaveCluster opts) "balanced" "after balancing"
 420                 ini_cdata { cdNodes = fin_nl, cdInstances = fin_il }
 421
 422   maybePrintInsts showinsts "Final" (Cluster.printInsts fin_nl fin_il)
 423
 424   maybePrintNodes shownodes "Final cluster" (Cluster.printNodes fin_nl)
 425
 426   when (verbose > 3) $ printStats nl fin_nl
 427
 428   eval <- maybeExecJobs opts ord_plc fin_nl il cmd_jobs
 429   unless eval (exitWith (ExitFailure 1))