1 {-| Solver for N+1 cluster errors
7 Copyright (C) 2009, 2010 Google Inc.
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.
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.
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
26 module Main (main) where
29 import Data.Maybe (isJust, fromJust)
31 import System (exitWith, ExitCode(..))
33 import qualified System
35 import qualified Ganeti.HTools.Cluster as Cluster
37 import Ganeti.HTools.CLI
38 import Ganeti.HTools.IAlloc
39 import Ganeti.HTools.Types
40 import Ganeti.HTools.Loader (RqType(..), Request(..))
42 -- | Options list and functions
44 options = [oPrintNodes, oShowVer, oShowHelp]
46 processResults :: (Monad m) =>
47 RqType -> Cluster.AllocSolution
48 -> m Cluster.AllocSolution
49 processResults _ (Cluster.AllocSolution { Cluster.asSolutions = [],
50 Cluster.asLog = msgs }) =
51 fail $ intercalate ", " msgs
53 processResults (Evacuate _) as = return as
56 case Cluster.asSolutions as of
58 _ -> fail "Internal error: multiple allocation solutions"
60 -- | Process a request and return new node lists
61 processRequest :: Request
62 -> Result Cluster.AllocSolution
63 processRequest request =
64 let Request rqtype gl nl il _ = request
66 Allocate xi reqn -> Cluster.tryMGAlloc gl nl il xi reqn
67 Relocate idx reqn exnodes -> Cluster.tryReloc nl il idx reqn exnodes
68 Evacuate exnodes -> Cluster.tryEvac nl il exnodes
73 cmd_args <- System.getArgs
74 (opts, args) <- parseOpts cmd_args "hail" options
77 hPutStrLn stderr "Error: this program needs an input file."
78 exitWith $ ExitFailure 1
80 let input_file = head args
81 shownodes = optShowNodes opts
82 input_data <- readFile input_file
84 request <- case (parseData input_data) of
86 hPutStrLn stderr $ "Error: " ++ err
87 exitWith $ ExitFailure 1
90 let Request rq _ nl _ _ = request
92 when (isJust shownodes) $ do
93 hPutStrLn stderr "Initial cluster status:"
94 hPutStrLn stderr $ Cluster.printNodes nl (fromJust shownodes)
96 let sols = processRequest request >>= processResults rq
99 Ok as -> (True, "Request successful: " ++
100 intercalate ", " (Cluster.asLog as),
101 Cluster.asSolutions as)
102 Bad s -> (False, "Request failed: " ++ s, [])
103 resp = formatResponse ok info rq rn