X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/8880d8897b3959fdd040dd4c6ad732035349e13d..40ee14bc952c808cce5e627a7d94600d7335de11:/hail.hs diff --git a/hail.hs b/hail.hs index b412680..541e1a9 100644 --- a/hail.hs +++ b/hail.hs @@ -4,7 +4,7 @@ {- -Copyright (C) 2009 Google Inc. +Copyright (C) 2009, 2010, 2011 Google Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -26,113 +26,99 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA module Main (main) where import Data.List -import Data.Function +import Data.Maybe (isJust, fromJust) import Monad -import System +import System (exitWith, ExitCode(..)) import System.IO -import System.Console.GetOpt import qualified System -import Text.Printf (printf) - import qualified Ganeti.HTools.Cluster as Cluster -import qualified Ganeti.HTools.Node as Node -import qualified Ganeti.HTools.Instance as Instance -import qualified Ganeti.HTools.CLI as CLI + +import Ganeti.HTools.CLI import Ganeti.HTools.IAlloc import Ganeti.HTools.Types -import Ganeti.HTools.Loader (RqType(..), Request(..)) - --- | Command line options structure. -data Options = Options - { optShowVer :: Bool -- ^ Just show the program version - , optShowHelp :: Bool -- ^ Just show the help - } deriving Show - --- | Default values for the command line options. -defaultOptions :: Options -defaultOptions = Options - { optShowVer = False - , optShowHelp = False - } - -instance CLI.CLIOptions Options where - showVersion = optShowVer - showHelp = optShowHelp +import Ganeti.HTools.Loader (RqType(..), Request(..), ClusterData(..)) +import Ganeti.HTools.ExtLoader (loadExternalData) -- | Options list and functions -options :: [OptDescr (Options -> Options)] +options :: [OptType] options = - [ Option ['V'] ["version"] - (NoArg (\ opts -> opts { optShowVer = True})) - "show the version of the program" - , Option ['h'] ["help"] - (NoArg (\ opts -> opts { optShowHelp = True})) - "show help" + [ oPrintNodes + , oDataFile + , oNodeSim + , oShowVer + , oShowHelp ] +processResults :: (Monad m) => + RqType -> Cluster.AllocSolution + -> m Cluster.AllocSolution +processResults _ (Cluster.AllocSolution { Cluster.asSolutions = [], + Cluster.asLog = msgs }) = + fail $ intercalate ", " msgs + +processResults (Evacuate _) as = return as -filterFails :: (Monad m) => - [OpResult (Node.List, Instance.Instance, [Node.Node])] - -> m [(Node.List, [Node.Node])] -filterFails sols = - if null sols then fail "No nodes onto which to allocate at all" - else let sols' = concatMap (\ e -> - case e of - OpFail _ -> [] - OpGood (gnl, _, nn) -> [(gnl, nn)] - ) sols - in - if null sols' - then fail "No valid allocation solutions" - else return sols' - -processResults :: (Monad m) => [(Node.List, [Node.Node])] - -> m (String, [Node.Node]) -processResults sols = - let sols' = map (\(nl', ns) -> (Cluster.compCV nl', ns)) sols - sols'' = sortBy (compare `on` fst) sols' - (best, w) = head sols'' - (worst, l) = last sols'' - info = printf "Valid results: %d, best score: %.8f for node(s) %s, \ - \worst score: %.8f for node(s) %s" (length sols'') - best (intercalate "/" . map Node.name $ w) - worst (intercalate "/" . map Node.name $ l)::String - in return (info, w) +processResults _ as = + case Cluster.asSolutions as of + _:[] -> return as + _ -> fail "Internal error: multiple allocation solutions" -- | Process a request and return new node lists processRequest :: Request - -> Result [OpResult (Node.List, Instance.Instance, [Node.Node])] + -> Result Cluster.AllocSolution processRequest request = - let Request rqtype nl il _ = request + let Request rqtype (ClusterData gl nl il _) = request in case rqtype of - Allocate xi reqn -> Cluster.tryAlloc nl il xi reqn - Relocate idx reqn exnodes -> Cluster.tryReloc nl il idx reqn exnodes + Allocate xi reqn -> Cluster.tryMGAlloc gl nl il xi reqn + Relocate idx reqn exnodes -> Cluster.tryMGReloc gl nl il + idx reqn exnodes + Evacuate exnodes -> Cluster.tryMGEvac gl nl il exnodes + +-- | Reads the request from the data file(s) +readRequest :: Options -> [String] -> IO Request +readRequest opts args = do + when (null args) $ do + hPutStrLn stderr "Error: this program needs an input file." + exitWith $ ExitFailure 1 + + input_data <- readFile (head args) + r1 <- case (parseData input_data) of + Bad err -> do + hPutStrLn stderr $ "Error: " ++ err + exitWith $ ExitFailure 1 + Ok rq -> return rq + r2 <- if isJust (optDataFile opts) || (not . null . optNodeSim) opts + then do + cdata <- loadExternalData opts + let Request rqt _ = r1 + return $ Request rqt cdata + else return r1 + return r2 -- | Main function. main :: IO () main = do cmd_args <- System.getArgs - (_, args) <- CLI.parseOpts cmd_args "hail" options defaultOptions + (opts, args) <- parseOpts cmd_args "hail" options - when (null args) $ do - hPutStrLn stderr "Error: this program needs an input file." - exitWith $ ExitFailure 1 + let shownodes = optShowNodes opts + + request <- readRequest opts args + + let Request rq cdata = request + + when (isJust shownodes) $ do + hPutStrLn stderr "Initial cluster status:" + hPutStrLn stderr $ Cluster.printNodes (cdNodes cdata) + (fromJust shownodes) - let input_file = head args - input_data <- readFile input_file - - request <- case (parseData input_data) of - Bad err -> do - hPutStrLn stderr $ "Error: " ++ err - exitWith $ ExitFailure 1 - Ok rq -> return rq - - let Request _ _ _ csf = request - sols = processRequest request >>= filterFails >>= processResults - let (ok, info, rn) = case sols of - Ok (info, sn) -> (True, "Request successful: " ++ info, - map ((++ csf) . Node.name) sn) - Bad s -> (False, "Request failed: " ++ s, []) - resp = formatResponse ok info rn + let sols = processRequest request >>= processResults rq + let (ok, info, rn) = + case sols of + Ok as -> (True, "Request successful: " ++ + intercalate ", " (Cluster.asLog as), + Cluster.asSolutions as) + Bad s -> (False, "Request failed: " ++ s, []) + resp = formatResponse ok info rq rn putStrLn resp