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

   1 {-| Solver for N+1 cluster errors
   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 Data.List
  29 import Data.Maybe (isJust, fromJust)
  30 import Monad
  31 import System (exitWith, ExitCode(..))
  32 import System.IO
  33 import qualified System
  34
  35 import Text.Printf (printf)
  36
  37 import qualified Ganeti.HTools.Cluster as Cluster
  38 import qualified Ganeti.HTools.Node as Node
  39
  40 import Ganeti.HTools.CLI
  41 import Ganeti.HTools.IAlloc
  42 import Ganeti.HTools.Types
  43 import Ganeti.HTools.Loader (RqType(..), Request(..))
  44
  45 -- | Options list and functions
  46 options :: [OptType]
  47 options = [oPrintNodes, oShowVer, oShowHelp]
  48
  49 processResults :: (Monad m) =>
  50                   RqType -> Cluster.AllocSolution
  51                -> m (String, Cluster.AllocSolution)
  52 processResults _ (_, _, []) = fail "No valid allocation solutions"
  53 processResults (Evacuate _) as@(fstats, successes, sols) =
  54     let best = fst $ head sols
  55         tfails = length fstats
  56         info = printf "for last allocation, successes %d, failures %d,\
  57                       \ best score: %.8f" successes tfails best::String
  58     in return (info, as)
  59
  60 processResults _ as@(fstats, successes, sols) =
  61     case sols of
  62       (best, (_, _, w)):[] ->
  63           let tfails = length fstats
  64               info = printf "successes %d, failures %d,\
  65                             \ best score: %.8f for node(s) %s"
  66                             successes tfails
  67                             best (intercalate "/" . map Node.name $ w)::String
  68           in return (info, as)
  69       _ -> fail "Internal error: multiple allocation solutions"
  70
  71 -- | Process a request and return new node lists
  72 processRequest :: Request
  73                -> Result Cluster.AllocSolution
  74 processRequest request =
  75   let Request rqtype nl il _ = request
  76   in case rqtype of
  77        Allocate xi reqn -> Cluster.tryAlloc nl il xi reqn
  78        Relocate idx reqn exnodes -> Cluster.tryReloc nl il idx reqn exnodes
  79        Evacuate exnodes -> Cluster.tryEvac nl il exnodes
  80
  81 -- | Main function.
  82 main :: IO ()
  83 main = do
  84   cmd_args <- System.getArgs
  85   (opts, args) <- parseOpts cmd_args "hail" options
  86
  87   when (null args) $ do
  88          hPutStrLn stderr "Error: this program needs an input file."
  89          exitWith $ ExitFailure 1
  90
  91   let input_file = head args
  92       shownodes = optShowNodes opts
  93   input_data <- readFile input_file
  94
  95   request <- case (parseData input_data) of
  96                Bad err -> do
  97                  hPutStrLn stderr $ "Error: " ++ err
  98                  exitWith $ ExitFailure 1
  99                Ok rq -> return rq
 100
 101   let Request rq nl _ _ = request
 102
 103   when (isJust shownodes) $ do
 104          hPutStrLn stderr "Initial cluster status:"
 105          hPutStrLn stderr $ Cluster.printNodes nl (fromJust shownodes)
 106
 107   let sols = processRequest request >>= processResults rq
 108   let (ok, info, rn) =
 109           case sols of
 110             Ok (ginfo, (_, _, sn)) -> (True, "Request successful: " ++ ginfo,
 111                                        map snd sn)
 112             Bad s -> (False, "Request failed: " ++ s, [])
 113       resp = formatResponse ok info rq rn
 114   putStrLn resp