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, 2010 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 qualified Ganeti.HTools.Cluster as Cluster
  36
  37 import Ganeti.HTools.CLI
  38 import Ganeti.HTools.IAlloc
  39 import Ganeti.HTools.Types
  40 import Ganeti.HTools.Loader (RqType(..), Request(..))
  41
  42 -- | Options list and functions
  43 options :: [OptType]
  44 options = [oPrintNodes, oShowVer, oShowHelp]
  45
  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
  52
  53 processResults (Evacuate _) as = return as
  54
  55 processResults _ as =
  56     case Cluster.asSolutions as of
  57       _:[] -> return as
  58       _ -> fail "Internal error: multiple allocation solutions"
  59
  60 -- | Process a request and return new node lists
  61 processRequest :: Request
  62                -> Result Cluster.AllocSolution
  63 processRequest request =
  64   let Request rqtype nl il _ = request
  65   in case rqtype of
  66        Allocate xi reqn -> Cluster.tryAlloc nl il xi reqn
  67        Relocate idx reqn exnodes -> Cluster.tryReloc nl il idx reqn exnodes
  68        Evacuate exnodes -> Cluster.tryEvac nl il exnodes
  69
  70 -- | Main function.
  71 main :: IO ()
  72 main = do
  73   cmd_args <- System.getArgs
  74   (opts, args) <- parseOpts cmd_args "hail" options
  75
  76   when (null args) $ do
  77          hPutStrLn stderr "Error: this program needs an input file."
  78          exitWith $ ExitFailure 1
  79
  80   let input_file = head args
  81       shownodes = optShowNodes opts
  82   input_data <- readFile input_file
  83
  84   request <- case (parseData input_data) of
  85                Bad err -> do
  86                  hPutStrLn stderr $ "Error: " ++ err
  87                  exitWith $ ExitFailure 1
  88                Ok rq -> return rq
  89
  90   let Request rq nl _ _ = request
  91
  92   when (isJust shownodes) $ do
  93          hPutStrLn stderr "Initial cluster status:"
  94          hPutStrLn stderr $ Cluster.printNodes nl (fromJust shownodes)
  95
  96   let sols = processRequest request >>= processResults rq
  97   let (ok, info, rn) =
  98           case sols of
  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
 104   putStrLn resp