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