1 {-| Solver for N+1 cluster errors
5 module Main (main) where
9 import Data.Maybe (isJust, fromJust)
13 import System.Console.GetOpt
14 import qualified System
16 import Text.Printf (printf)
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
26 -- | Command line options structure.
27 data Options = Options
28 { optShowVer :: Bool -- ^ Just show the program version
29 , optShowHelp :: Bool -- ^ Just show the help
32 -- | Default values for the command line options.
33 defaultOptions :: Options
34 defaultOptions = Options
39 instance CLI.CLIOptions Options where
40 showVersion = optShowVer
41 showHelp = optShowHelp
43 -- | Options list and functions
44 options :: [OptDescr (Options -> 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}))
54 -- | Compute online nodes from a Node.List
55 getOnline :: Node.List -> [Node.Node]
56 getOnline = filter (not . Node.offline) . Container.elems
58 -- | Try to allocate an instance on the cluster
59 tryAlloc :: (Monad m) =>
64 -> m [(Maybe Node.List, [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]))
74 tryAlloc nl _ inst 1 =
75 let all_nodes = getOnline nl
76 sols = map (\p -> (fst $ Cluster.allocateOnSingle nl inst p, [p]))
80 tryAlloc _ _ _ reqn = fail $ "Unsupported number of alllocation \
81 \destinations required (" ++ (show reqn) ++
82 "), only two supported"
84 -- | Try to allocate an instance on the cluster
85 tryReloc :: (Monad m) =>
91 -> m [(Maybe Node.List, [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' . Node.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])
105 tryReloc _ _ _ reqn _ = fail $ "Unsupported number of relocation \
106 \destinations required (" ++ (show reqn) ++
107 "), only one supported"
109 filterFails :: (Monad m) => [(Maybe Node.List, [Node.Node])]
110 -> m [(Node.List, [Node.Node])]
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"
117 return $ map (\(x, y) -> (fromJust x, y)) sols'
119 processResults :: (Monad m) => [(Node.List, [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)
135 cmd_args <- System.getArgs
136 (_, args) <- CLI.parseOpts cmd_args "hail" options defaultOptions
138 when (null args) $ do
139 hPutStrLn stderr "Error: this program needs an input file."
140 exitWith $ ExitFailure 1
142 let input_file = head args
143 input_data <- readFile input_file
145 request <- case (parseData input_data) of
147 putStrLn $ "Error: " ++ err
148 exitWith $ ExitFailure 1
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) . Node.name) sn)
160 Bad s -> (False, "Request failed: " ++ s, [])
161 resp = formatResponse ok info rn