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(..), ClusterData(..))
  41 import Ganeti.HTools.ExtLoader (loadExternalData)
  42
  43 -- | Options list and functions
  44 options :: [OptType]
  45 options =
  46     [ oPrintNodes
  47     , oDataFile
  48     , oNodeSim
  49     , oShowVer
  50     , oShowHelp
  51     ]
  52
  53 processResults :: (Monad m) =>
  54                   RqType -> Cluster.AllocSolution
  55                -> m Cluster.AllocSolution
  56 processResults _ (Cluster.AllocSolution { Cluster.asSolutions = [],
  57                                           Cluster.asLog = msgs }) =
  58   fail $ intercalate ", " msgs
  59
  60 processResults (Evacuate _) as = return as
  61
  62 processResults _ as =
  63     case Cluster.asSolutions as of
  64       _:[] -> return as
  65       _ -> fail "Internal error: multiple allocation solutions"
  66
  67 -- | Process a request and return new node lists
  68 processRequest :: Request
  69                -> Result Cluster.AllocSolution
  70 processRequest request =
  71   let Request rqtype (ClusterData gl nl il _) = request
  72   in case rqtype of
  73        Allocate xi reqn -> Cluster.tryMGAlloc gl nl il xi reqn
  74        Relocate idx reqn exnodes -> Cluster.tryReloc nl il idx reqn exnodes
  75        Evacuate exnodes -> Cluster.tryEvac nl il exnodes
  76
  77 -- | Reads the request from the data file(s)
  78 readRequest :: Options -> [String] -> IO Request
  79 readRequest opts args = do
  80   when (null args) $ do
  81          hPutStrLn stderr "Error: this program needs an input file."
  82          exitWith $ ExitFailure 1
  83
  84   input_data <- readFile (head args)
  85   r1 <- case (parseData input_data) of
  86           Bad err -> do
  87             hPutStrLn stderr $ "Error: " ++ err
  88             exitWith $ ExitFailure 1
  89           Ok rq -> return rq
  90   r2 <- if isJust (optDataFile opts) ||  (not . null . optNodeSim) opts
  91         then  do
  92           cdata <- loadExternalData opts
  93           let Request rqt _ = r1
  94           return $ Request rqt cdata
  95         else return r1
  96   return r2
  97
  98 -- | Main function.
  99 main :: IO ()
 100 main = do
 101   cmd_args <- System.getArgs
 102   (opts, args) <- parseOpts cmd_args "hail" options
 103
 104   let shownodes = optShowNodes opts
 105
 106   request <- readRequest opts args
 107
 108   let Request rq cdata = request
 109
 110   when (isJust shownodes) $ do
 111          hPutStrLn stderr "Initial cluster status:"
 112          hPutStrLn stderr $ Cluster.printNodes (cdNodes cdata)
 113                        (fromJust shownodes)
 114
 115   let sols = processRequest request >>= processResults rq
 116   let (ok, info, rn) =
 117           case sols of
 118             Ok as -> (True, "Request successful: " ++
 119                             intercalate ", " (Cluster.asLog as),
 120                       Cluster.asSolutions as)
 121             Bad s -> (False, "Request failed: " ++ s, [])
 122       resp = formatResponse ok info rq rn
 123   putStrLn resp