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         valid_nodes = filter (not . flip elem ex_idx . idx) all_nodes
  96         valid_idxes = map Node.idx valid_nodes
  97         nl' = Container.map (\n -> if elem (Node.idx n) ex_idx then
  98                                        Node.setOffline n True
  99                                    else n) nl
 100         sols1 = map (\x -> let (mnl, _, _, _) =
 101                                     Cluster.applyMove nl' inst
 102                                                (Cluster.ReplaceSecondary x)
 103                             in (mnl, [Container.find x nl'])
 104                      ) valid_idxes
 105     in return sols1
 106
 107 tryReloc _ _ _ reqn _  = fail $ "Unsupported number of relocation \
 108                                 \destinations required (" ++ (show reqn) ++
 109                                                   "), only one supported"
 110
 111 filterFails :: (Monad m) => [(Maybe NodeList, [Node.Node])]
 112             -> m [(NodeList, [Node.Node])]
 113 filterFails sols =
 114     if null sols then fail "No nodes onto which to allocate at all"
 115     else let sols' = filter (isJust . fst) sols
 116          in if null sols' then
 117                 fail "No valid allocation solutions"
 118             else
 119                 return $ map (\(x, y) -> (fromJust x, y)) sols'
 120
 121 processResults :: (Monad m) => [(NodeList, [Node.Node])]
 122                -> m (String, [Node.Node])
 123 processResults sols =
 124     let sols' = map (\(nl', ns) -> (Cluster.compCV  nl', ns)) sols
 125         sols'' = sortBy (compare `on` fst) sols'
 126         (best, w) = head sols''
 127         (worst, l) = last sols''
 128         info = printf "Valid results: %d, best score: %.8f for node(s) %s, \
 129                       \worst score: %.8f for node(s) %s" (length sols'')
 130                       best (intercalate "/" . map Node.name $ w)
 131                       worst (intercalate "/" . map Node.name $ l)
 132     in return (info, w)
 133
 134 -- | Main function.
 135 main :: IO ()
 136 main = do
 137   cmd_args <- System.getArgs
 138   (_, args) <- CLI.parseOpts cmd_args "hail" options defaultOptions
 139
 140   when (null args) $ do
 141          hPutStrLn stderr "Error: this program needs an input file."
 142          exitWith $ ExitFailure 1
 143
 144   let input_file = head args
 145   input_data <- readFile input_file
 146
 147   request <- case (parseData input_data) of
 148                Bad err -> do
 149                  putStrLn $ "Error: " ++ err
 150                  exitWith $ ExitFailure 1
 151                Ok rq -> return rq
 152
 153   let Request rqtype nl il csf = request
 154       new_nodes = case rqtype of
 155                     Allocate xi reqn -> tryAlloc nl il xi reqn
 156                     Relocate idx reqn exnodes ->
 157                         tryReloc nl il idx reqn exnodes
 158   let sols = new_nodes >>= filterFails >>= processResults
 159   let (ok, info, rn) = case sols of
 160                Ok (info, sn) -> (True, "Request successful: " ++ info,
 161                                      map ((++ csf) . name) sn)
 162                Bad s -> (False, "Request failed: " ++ s, [])
 163       resp = formatResponse ok info rn
 164   putStrLn resp