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