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.Function
  30 import Data.Maybe (isJust, fromJust)
  31 import Monad
  32 import System
  33 import System.IO
  34 import System.Console.GetOpt
  35 import qualified System
  36
  37 import Text.Printf (printf)
  38
  39 import qualified Ganeti.HTools.Container as Container
  40 import qualified Ganeti.HTools.Cluster as Cluster
  41 import qualified Ganeti.HTools.Node as Node
  42 import qualified Ganeti.HTools.Instance as Instance
  43 import qualified Ganeti.HTools.CLI as CLI
  44 import Ganeti.HTools.IAlloc
  45 import Ganeti.HTools.Types
  46 import Ganeti.HTools.Loader (RqType(..), Request(..))
  47 import Ganeti.HTools.Utils
  48
  49 -- | Command line options structure.
  50 data Options = Options
  51     { optShowVer   :: Bool           -- ^ Just show the program version
  52     , optShowHelp  :: Bool           -- ^ Just show the help
  53     } deriving Show
  54
  55 -- | Default values for the command line options.
  56 defaultOptions :: Options
  57 defaultOptions  = Options
  58  { optShowVer   = False
  59  , optShowHelp  = False
  60  }
  61
  62 instance CLI.CLIOptions Options where
  63     showVersion = optShowVer
  64     showHelp    = optShowHelp
  65
  66 -- | Options list and functions
  67 options :: [OptDescr (Options -> Options)]
  68 options =
  69     [ Option ['V']     ["version"]
  70       (NoArg (\ opts -> opts { optShowVer = True}))
  71       "show the version of the program"
  72     , Option ['h']     ["help"]
  73       (NoArg (\ opts -> opts { optShowHelp = True}))
  74       "show help"
  75     ]
  76
  77
  78 filterFails :: (Monad m) => [(Maybe Node.List, Instance.Instance, [Node.Node])]
  79             -> m [(Node.List, [Node.Node])]
  80 filterFails sols =
  81     if null sols then fail "No nodes onto which to allocate at all"
  82     else let sols' = filter (isJust . fst3) sols
  83          in if null sols' then
  84                 fail "No valid allocation solutions"
  85             else
  86                 return $ map (\(x, _, y) -> (fromJust x, y)) sols'
  87
  88 processResults :: (Monad m) => [(Node.List, [Node.Node])]
  89                -> m (String, [Node.Node])
  90 processResults sols =
  91     let sols' = map (\(nl', ns) -> (Cluster.compCV  nl', ns)) sols
  92         sols'' = sortBy (compare `on` fst) sols'
  93         (best, w) = head sols''
  94         (worst, l) = last sols''
  95         info = printf "Valid results: %d, best score: %.8f for node(s) %s, \
  96                       \worst score: %.8f for node(s) %s" (length sols'')
  97                       best (intercalate "/" . map Node.name $ w)
  98                       worst (intercalate "/" . map Node.name $ l)
  99     in return (info, w)
 100
 101 -- | Main function.
 102 main :: IO ()
 103 main = do
 104   cmd_args <- System.getArgs
 105   (_, args) <- CLI.parseOpts cmd_args "hail" options defaultOptions
 106
 107   when (null args) $ do
 108          hPutStrLn stderr "Error: this program needs an input file."
 109          exitWith $ ExitFailure 1
 110
 111   let input_file = head args
 112   input_data <- readFile input_file
 113
 114   request <- case (parseData input_data) of
 115                Bad err -> do
 116                  putStrLn $ "Error: " ++ err
 117                  exitWith $ ExitFailure 1
 118                Ok rq -> return rq
 119
 120   let Request rqtype nl il csf = request
 121       new_nodes = case rqtype of
 122                     Allocate xi reqn -> Cluster.tryAlloc nl il xi reqn
 123                     Relocate idx reqn exnodes ->
 124                         Cluster.tryReloc nl il idx reqn exnodes
 125   let sols = new_nodes >>= filterFails >>= processResults
 126   let (ok, info, rn) = case sols of
 127                Ok (info, sn) -> (True, "Request successful: " ++ info,
 128                                      map ((++ csf) . Node.name) sn)
 129                Bad s -> (False, "Request failed: " ++ s, [])
 130       resp = formatResponse ok info rn
 131   putStrLn resp