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

   1 {-| Cluster rebalancer
   2
   3 -}
   4
   5 {-
   6
   7 Copyright (C) 2009 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, fromJust)
  32 import Monad
  33 import System (exitWith, ExitCode(..))
  34 import System.IO
  35 import qualified System
  36
  37 import Text.Printf (printf, hPrintf)
  38 import Text.JSON (showJSON)
  39
  40 import qualified Ganeti.HTools.Container as Container
  41 import qualified Ganeti.HTools.Cluster as Cluster
  42 import qualified Ganeti.HTools.Node as Node
  43 import qualified Ganeti.HTools.Instance as Instance
  44
  45 import Ganeti.HTools.CLI
  46 import Ganeti.HTools.ExtLoader
  47 import Ganeti.HTools.Utils
  48 import Ganeti.HTools.Types
  49
  50 import qualified Ganeti.Luxi as L
  51 import qualified Ganeti.OpCodes as OpCodes
  52 import Ganeti.Jobs
  53
  54 -- | Options list and functions
  55 options :: [OptType]
  56 options =
  57     [ oPrintNodes
  58     , oPrintInsts
  59     , oPrintCommands
  60     , oOneline
  61     , oDataFile
  62     , oEvacMode
  63     , oRapiMaster
  64     , oLuxiSocket
  65     , oExecJobs
  66     , oMaxSolLength
  67     , oVerbose
  68     , oQuiet
  69     , oOfflineNode
  70     , oMinScore
  71     , oMaxCpu
  72     , oMinDisk
  73     , oDiskMoves
  74     , oDynuFile
  75     , oExTags
  76     , oExInst
  77     , oShowVer
  78     , oShowHelp
  79     ]
  80
  81 {- | Start computing the solution at the given depth and recurse until
  82 we find a valid solution or we exceed the maximum depth.
  83
  84 -}
  85 iterateDepth :: Cluster.Table    -- ^ The starting table
  86              -> Int              -- ^ Remaining length
  87              -> Bool             -- ^ Allow disk moves
  88              -> Int              -- ^ Max node name len
  89              -> Int              -- ^ Max instance name len
  90              -> [MoveJob]        -- ^ Current command list
  91              -> Bool             -- ^ Whether to be silent
  92              -> Score            -- ^ Score at which to stop
  93              -> Bool             -- ^ Enable evacuation mode
  94              -> IO (Cluster.Table, [MoveJob]) -- ^ The resulting table
  95                                               -- and commands
  96 iterateDepth ini_tbl max_rounds disk_moves nmlen imlen
  97              cmd_strs oneline min_score evac_mode =
  98     let Cluster.Table ini_nl ini_il _ _ = ini_tbl
  99         allowed_next = Cluster.doNextBalance ini_tbl max_rounds min_score
 100         m_fin_tbl = if allowed_next
 101                     then Cluster.tryBalance ini_tbl disk_moves evac_mode
 102                     else Nothing
 103     in
 104       case m_fin_tbl of
 105         Just fin_tbl ->
 106             do
 107               let
 108                   (Cluster.Table _ _ _ fin_plc) = fin_tbl
 109                   fin_plc_len = length fin_plc
 110                   cur_plc@(idx, _, _, move, _) = head fin_plc
 111                   (sol_line, cmds) = Cluster.printSolutionLine ini_nl ini_il
 112                                      nmlen imlen cur_plc fin_plc_len
 113                   afn = Cluster.involvedNodes ini_il cur_plc
 114                   upd_cmd_strs = (afn, idx, move, cmds):cmd_strs
 115               unless oneline $ do
 116                        putStrLn sol_line
 117                        hFlush stdout
 118               iterateDepth fin_tbl max_rounds disk_moves
 119                            nmlen imlen upd_cmd_strs oneline min_score
 120                            evac_mode
 121         Nothing -> return (ini_tbl, cmd_strs)
 122
 123 -- | Formats the solution for the oneline display
 124 formatOneline :: Double -> Int -> Double -> String
 125 formatOneline ini_cv plc_len fin_cv =
 126     printf "%.8f %d %.8f %8.3f" ini_cv plc_len fin_cv
 127                (if fin_cv == 0 then 1 else ini_cv / fin_cv)
 128
 129 -- | Submits a list of jobs and waits for all to finish execution
 130 execJobs :: L.Client -> [[OpCodes.OpCode]] -> IO (Result [String])
 131 execJobs client = L.submitManyJobs client . showJSON
 132
 133 -- | Polls a set of jobs at a fixed interval until all are finished
 134 -- one way or another
 135 waitForJobs :: L.Client -> [String] -> IO (Result [JobStatus])
 136 waitForJobs client jids = do
 137   sts <- L.queryJobsStatus client jids
 138   case sts of
 139     Bad x -> return $ Bad x
 140     Ok s -> if any (<= JobRunning) s
 141             then do
 142               -- TODO: replace hardcoded value with a better thing
 143               threadDelay (1000000 * 15)
 144               waitForJobs client jids
 145             else return $ Ok s
 146
 147 -- | Check that a set of job statuses is all success
 148 checkJobsStatus :: [JobStatus] -> Bool
 149 checkJobsStatus = all (== JobSuccess)
 150
 151 -- | Execute an entire jobset
 152 execJobSet :: String -> Node.List
 153            -> Instance.List -> [JobSet] -> IO ()
 154 execJobSet _      _  _  [] = return ()
 155 execJobSet master nl il (js:jss) = do
 156   -- map from jobset (htools list of positions) to [[opcodes]]
 157   let jobs = map (\(_, idx, move, _) ->
 158                       Cluster.iMoveToJob nl il idx move) js
 159   let descr = map (\(_, idx, _, _) -> Container.nameOf il idx) js
 160   putStrLn $ "Executing jobset for instances " ++ commaJoin descr
 161   jrs <- bracket (L.getClient master) L.closeClient
 162          (\client -> do
 163             jids <- execJobs client jobs
 164             case jids of
 165               Bad x -> return $ Bad x
 166               Ok x -> do
 167                 putStrLn $ "Got job IDs " ++ commaJoin x
 168                 waitForJobs client x
 169          )
 170   (case jrs of
 171      Bad x -> do
 172        hPutStrLn stderr $ "Cannot compute job status, aborting: " ++ show x
 173        return ()
 174      Ok x -> if checkJobsStatus x
 175              then execJobSet master nl il jss
 176              else do
 177                hPutStrLn stderr $ "Not all jobs completed successfully: " ++
 178                          show x
 179                hPutStrLn stderr "Aborting.")
 180
 181 -- | Main function.
 182 main :: IO ()
 183 main = do
 184   cmd_args <- System.getArgs
 185   (opts, args) <- parseOpts cmd_args "hbal" options
 186
 187   unless (null args) $ do
 188          hPutStrLn stderr "Error: this program doesn't take any arguments."
 189          exitWith $ ExitFailure 1
 190
 191   let oneline = optOneline opts
 192       verbose = optVerbose opts
 193       shownodes = optShowNodes opts
 194
 195   (fixed_nl, il, ctags) <- loadExternalData opts
 196
 197   let offline_names = optOffline opts
 198       all_nodes = Container.elems fixed_nl
 199       all_names = concatMap allNames all_nodes
 200       offline_wrong = filter (`notElem` all_names) offline_names
 201       offline_indices = map Node.idx $
 202                         filter (\n -> Node.name n `elem` offline_names)
 203                                all_nodes
 204       m_cpu = optMcpu opts
 205       m_dsk = optMdsk opts
 206       csf = commonSuffix fixed_nl il
 207
 208   when (length offline_wrong > 0) $ do
 209          hPrintf stderr "Wrong node name(s) set as offline: %s\n"
 210                      (commaJoin offline_wrong) :: IO ()
 211          exitWith $ ExitFailure 1
 212
 213   let nm = Container.map (\n -> if Node.idx n `elem` offline_indices
 214                                 then Node.setOffline n True
 215                                 else n) fixed_nl
 216       nl = Container.map (flip Node.setMdsk m_dsk . flip Node.setMcpu m_cpu)
 217            nm
 218
 219   when (not oneline && verbose > 1) $
 220        putStrLn $ "Loaded cluster tags: " ++ intercalate "," ctags
 221
 222   when (Container.size il == 0) $ do
 223          (if oneline then putStrLn $ formatOneline 0 0 0
 224           else printf "Cluster is empty, exiting.\n")
 225          exitWith ExitSuccess
 226
 227   unless oneline $ printf "Loaded %d nodes, %d instances\n"
 228              (Container.size nl)
 229              (Container.size il)
 230
 231   when (length csf > 0 && not oneline && verbose > 1) $
 232        printf "Note: Stripping common suffix of '%s' from names\n" csf
 233
 234   let (bad_nodes, bad_instances) = Cluster.computeBadItems nl il
 235   unless (oneline || verbose == 0) $ printf
 236              "Initial check done: %d bad nodes, %d bad instances.\n"
 237              (length bad_nodes) (length bad_instances)
 238
 239   when (length bad_nodes > 0) $
 240          putStrLn "Cluster is not N+1 happy, continuing but no guarantee \
 241                   \that the cluster will end N+1 happy."
 242
 243   when (optShowInsts opts) $ do
 244          putStrLn ""
 245          putStrLn "Initial instance map:"
 246          putStrLn $ Cluster.printInsts nl il
 247
 248   when (isJust shownodes) $
 249        do
 250          putStrLn "Initial cluster status:"
 251          putStrLn $ Cluster.printNodes nl (fromJust shownodes)
 252
 253   let ini_cv = Cluster.compCV nl
 254       ini_tbl = Cluster.Table nl il ini_cv []
 255       min_cv = optMinScore opts
 256
 257   when (ini_cv < min_cv) $ do
 258          (if oneline then
 259               putStrLn $ formatOneline ini_cv 0 ini_cv
 260           else printf "Cluster is already well balanced (initial score %.6g,\n\
 261                       \minimum score %.6g).\nNothing to do, exiting\n"
 262                       ini_cv min_cv)
 263          exitWith ExitSuccess
 264
 265   unless oneline (if verbose > 2 then
 266                       printf "Initial coefficients: overall %.8f, %s\n"
 267                       ini_cv (Cluster.printStats nl)
 268                   else
 269                       printf "Initial score: %.8f\n" ini_cv)
 270
 271   unless oneline $ putStrLn "Trying to minimize the CV..."
 272   let imlen = Container.maxNameLen il
 273       nmlen = Container.maxNameLen nl
 274
 275   (fin_tbl, cmd_strs) <- iterateDepth ini_tbl (optMaxLength opts)
 276                          (optDiskMoves opts)
 277                          nmlen imlen [] oneline min_cv (optEvacMode opts)
 278   let (Cluster.Table fin_nl fin_il fin_cv fin_plc) = fin_tbl
 279       ord_plc = reverse fin_plc
 280       sol_msg = if null fin_plc
 281                 then printf "No solution found\n"
 282                 else if verbose > 2
 283                      then printf "Final coefficients:   overall %.8f, %s\n"
 284                           fin_cv (Cluster.printStats fin_nl)
 285                      else printf "Cluster score improved from %.8f to %.8f\n"
 286                           ini_cv fin_cv
 287                               ::String
 288
 289   unless oneline $ putStr sol_msg
 290
 291   unless (oneline || verbose == 0) $
 292          printf "Solution length=%d\n" (length ord_plc)
 293
 294   let cmd_jobs = Cluster.splitJobs cmd_strs
 295       cmd_data = Cluster.formatCmds cmd_jobs
 296
 297   when (isJust $ optShowCmds opts) $
 298        do
 299          let out_path = fromJust $ optShowCmds opts
 300          putStrLn ""
 301          (if out_path == "-" then
 302               printf "Commands to run to reach the above solution:\n%s"
 303                      (unlines . map ("  " ++) .
 304                       filter (/= "  check") .
 305                       lines $ cmd_data)
 306           else do
 307             writeFile out_path (shTemplate ++ cmd_data)
 308             printf "The commands have been written to file '%s'\n" out_path)
 309
 310   when (optExecJobs opts && not (null ord_plc))
 311            (case optLuxi opts of
 312               Nothing -> do
 313                 hPutStrLn stderr "Execution of commands possible only on LUXI"
 314                 exitWith $ ExitFailure 1
 315               Just master -> execJobSet master fin_nl il cmd_jobs)
 316
 317   when (optShowInsts opts) $ do
 318          putStrLn ""
 319          putStrLn "Final instance map:"
 320          putStr $ Cluster.printInsts fin_nl fin_il
 321
 322   when (isJust shownodes) $
 323        do
 324          let ini_cs = Cluster.totalResources nl
 325              fin_cs = Cluster.totalResources fin_nl
 326          putStrLn ""
 327          putStrLn "Final cluster status:"
 328          putStrLn $ Cluster.printNodes fin_nl (fromJust shownodes)
 329          when (verbose > 3) $
 330               do
 331                 printf "Original: mem=%d disk=%d\n"
 332                        (Cluster.csFmem ini_cs) (Cluster.csFdsk ini_cs) :: IO ()
 333                 printf "Final:    mem=%d disk=%d\n"
 334                        (Cluster.csFmem fin_cs) (Cluster.csFdsk fin_cs)
 335   when oneline $
 336          putStrLn $ formatOneline ini_cv (length ord_plc) fin_cv