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