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 NodeList
55 getOnline :: NodeList -> [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 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]))
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 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
100 sols1 = map (\x -> let (mnl, _, _, _) =
101 Cluster.applyMove nl' inst
102 (Cluster.ReplaceSecondary x)
103 in (mnl, [Container.find x nl'])
107 tryReloc _ _ _ reqn _ = fail $ "Unsupported number of relocation \
108 \destinations required (" ++ (show reqn) ++
109 "), only one supported"
111 filterFails :: (Monad m) => [(Maybe NodeList, [Node.Node])]
112 -> m [(NodeList, [Node.Node])]
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"
119 return $ map (\(x, y) -> (fromJust x, y)) sols'
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)
137 cmd_args <- System.getArgs
138 (_, args) <- CLI.parseOpts cmd_args "hail" options defaultOptions
140 when (null args) $ do
141 hPutStrLn stderr "Error: this program needs an input file."
142 exitWith $ ExitFailure 1
144 let input_file = head args
145 input_data <- readFile input_file
147 request <- case (parseData input_data) of
149 putStrLn $ "Error: " ++ err
150 exitWith $ ExitFailure 1
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