code.grnet.gr Git - ganeti-local/blob - hail.hs

   1 {-| Solver for N+1 cluster errors
   2
   3 -}
   4
   5 module Main (main) where
   6
   7 import Data.List
   8 import Data.Function
   9 import Data.Maybe (isJust, fromJust)
  10 import Monad
  11 import System
  12 import System.IO
  13 import System.Console.GetOpt
  14 import qualified System
  15
  16 import Text.Printf (printf)
  17
  18 import qualified Ganeti.HTools.Container as Container
  19 import qualified Ganeti.HTools.Cluster as Cluster
  20 import qualified Ganeti.HTools.Node as Node
  21 import qualified Ganeti.HTools.Instance as Instance
  22 import qualified Ganeti.HTools.CLI as CLI
  23 import Ganeti.HTools.IAlloc
  24 import Ganeti.HTools.Types
  25 import Ganeti.HTools.Loader (RqType(..), Request(..))
  26
  27 -- | Command line options structure.
  28 data Options = Options
  29     { optShowVer   :: Bool           -- ^ Just show the program version
  30     , optShowHelp  :: Bool           -- ^ Just show the help
  31     } deriving Show
  32
  33 -- | Default values for the command line options.
  34 defaultOptions :: Options
  35 defaultOptions  = Options
  36  { optShowVer   = False
  37  , optShowHelp  = False
  38  }
  39
  40 instance CLI.CLIOptions Options where
  41     showVersion = optShowVer
  42     showHelp    = optShowHelp
  43
  44 -- | Options list and functions
  45 options :: [OptDescr (Options -> Options)]
  46 options =
  47     [ Option ['V']     ["version"]
  48       (NoArg (\ opts -> opts { optShowVer = True}))
  49       "show the version of the program"
  50     , Option ['h']     ["help"]
  51       (NoArg (\ opts -> opts { optShowHelp = True}))
  52       "show help"
  53     ]
  54
  55 -- | Compute online nodes from a Node.List
  56 getOnline :: Node.List -> [Node.Node]
  57 getOnline = filter (not . Node.offline) . Container.elems
  58
  59 -- | Try to allocate an instance on the cluster
  60 tryAlloc :: (Monad m) =>
  61             Node.List
  62          -> Instance.List
  63          -> Instance.Instance
  64          -> Int
  65          -> m [(Maybe Node.List, [Node.Node])]
  66 tryAlloc nl _ inst 2 =
  67     let all_nodes = getOnline nl
  68         all_pairs = liftM2 (,) all_nodes all_nodes
  69         ok_pairs = filter (\(x, y) -> Node.idx x /= Node.idx y) all_pairs
  70         sols = map (\(p, s) ->
  71                         (fst $ Cluster.allocateOnPair nl inst p s, [p, s]))
  72                ok_pairs
  73     in return sols
  74
  75 tryAlloc nl _ inst 1 =
  76     let all_nodes = getOnline nl
  77         sols = map (\p -> (fst $ Cluster.allocateOnSingle nl inst p, [p]))
  78                all_nodes
  79     in return sols
  80
  81 tryAlloc _ _ _ reqn = fail $ "Unsupported number of alllocation \
  82                              \destinations required (" ++ (show reqn) ++
  83                                                "), only two supported"
  84
  85 -- | Try to allocate an instance on the cluster
  86 tryReloc :: (Monad m) =>
  87             Node.List
  88          -> Instance.List
  89          -> Idx
  90          -> Int
  91          -> [Ndx]
  92          -> m [(Maybe Node.List, [Node.Node])]
  93 tryReloc nl il xid 1 ex_idx =
  94     let all_nodes = getOnline nl
  95         inst = Container.find xid il
  96         ex_idx' = (Instance.pnode inst):ex_idx
  97         valid_nodes = filter (not . flip elem ex_idx' . Node.idx) all_nodes
  98         valid_idxes = map Node.idx valid_nodes
  99         sols1 = map (\x -> let (mnl, _, _, _) =
 100                                     Cluster.applyMove nl inst
 101                                                (Cluster.ReplaceSecondary x)
 102                             in (mnl, [Container.find x nl])
 103                      ) valid_idxes
 104     in return sols1
 105
 106 tryReloc _ _ _ reqn _  = fail $ "Unsupported number of relocation \
 107                                 \destinations required (" ++ (show reqn) ++
 108                                                   "), only one supported"
 109
 110 filterFails :: (Monad m) => [(Maybe Node.List, [Node.Node])]
 111             -> m [(Node.List, [Node.Node])]
 112 filterFails sols =
 113     if null sols then fail "No nodes onto which to allocate at all"
 114     else let sols' = filter (isJust . fst) sols
 115          in if null sols' then
 116                 fail "No valid allocation solutions"
 117             else
 118                 return $ map (\(x, y) -> (fromJust x, y)) sols'
 119
 120 processResults :: (Monad m) => [(Node.List, [Node.Node])]
 121                -> m (String, [Node.Node])
 122 processResults sols =
 123     let sols' = map (\(nl', ns) -> (Cluster.compCV  nl', ns)) sols
 124         sols'' = sortBy (compare `on` fst) sols'
 125         (best, w) = head sols''
 126         (worst, l) = last sols''
 127         info = printf "Valid results: %d, best score: %.8f for node(s) %s, \
 128                       \worst score: %.8f for node(s) %s" (length sols'')
 129                       best (intercalate "/" . map Node.name $ w)
 130                       worst (intercalate "/" . map Node.name $ l)
 131     in return (info, w)
 132
 133 -- | Main function.
 134 main :: IO ()
 135 main = do
 136   cmd_args <- System.getArgs
 137   (_, args) <- CLI.parseOpts cmd_args "hail" options defaultOptions
 138
 139   when (null args) $ do
 140          hPutStrLn stderr "Error: this program needs an input file."
 141          exitWith $ ExitFailure 1
 142
 143   let input_file = head args
 144   input_data <- readFile input_file
 145
 146   request <- case (parseData input_data) of
 147                Bad err -> do
 148                  putStrLn $ "Error: " ++ err
 149                  exitWith $ ExitFailure 1
 150                Ok rq -> return rq
 151
 152   let Request rqtype nl il csf = request
 153       new_nodes = case rqtype of
 154                     Allocate xi reqn -> tryAlloc nl il xi reqn
 155                     Relocate idx reqn exnodes ->
 156                         tryReloc nl il idx reqn exnodes
 157   let sols = new_nodes >>= filterFails >>= processResults
 158   let (ok, info, rn) = case sols of
 159                Ok (info, sn) -> (True, "Request successful: " ++ info,
 160                                      map ((++ csf) . Node.name) sn)
 161                Bad s -> (False, "Request failed: " ++ s, [])
 162       resp = formatResponse ok info rn
 163   putStrLn resp