hail.hs 5.44 KB
Newer Older
Iustin Pop's avatar
Iustin Pop committed
1
2
3
4
5
6
7
8
{-| Solver for N+1 cluster errors

-}

module Main (main) where

import Data.List
import Data.Function
Iustin Pop's avatar
Iustin Pop committed
9
import Data.Maybe (isJust, fromJust)
Iustin Pop's avatar
Iustin Pop committed
10
11
12
13
14
15
16
17
18
19
20
import Monad
import System
import System.IO
import System.Console.GetOpt
import qualified System

import Text.Printf (printf)

import qualified Ganeti.HTools.Container as Container
import qualified Ganeti.HTools.Cluster as Cluster
import qualified Ganeti.HTools.Node as Node
21
import qualified Ganeti.HTools.Instance as Instance
Iustin Pop's avatar
Iustin Pop committed
22
23
import qualified Ganeti.HTools.CLI as CLI
import Ganeti.HTools.IAlloc
Iustin Pop's avatar
Iustin Pop committed
24
import Ganeti.HTools.Types
Iustin Pop's avatar
Iustin Pop committed
25
26
27

-- | Command line options structure.
data Options = Options
Iustin Pop's avatar
Iustin Pop committed
28
    { optShowVer   :: Bool           -- ^ Just show the program version
Iustin Pop's avatar
Iustin Pop committed
29
30
31
32
33
34
    , optShowHelp  :: Bool           -- ^ Just show the help
    } deriving Show

-- | Default values for the command line options.
defaultOptions :: Options
defaultOptions  = Options
Iustin Pop's avatar
Iustin Pop committed
35
 { optShowVer   = False
Iustin Pop's avatar
Iustin Pop committed
36
37
38
 , optShowHelp  = False
 }

Iustin Pop's avatar
Iustin Pop committed
39
40
41
42
instance CLI.CLIOptions Options where
    showVersion = optShowVer
    showHelp    = optShowHelp

Iustin Pop's avatar
Iustin Pop committed
43
44
45
-- | Options list and functions
options :: [OptDescr (Options -> Options)]
options =
Iustin Pop's avatar
Iustin Pop committed
46
    [ Option ['V']     ["version"]
Iustin Pop's avatar
Iustin Pop committed
47
48
49
50
51
52
53
      (NoArg (\ opts -> opts { optShowVer = True}))
      "show the version of the program"
    , Option ['h']     ["help"]
      (NoArg (\ opts -> opts { optShowHelp = True}))
      "show help"
    ]

54
55
-- | Compute online nodes from a Node.List
getOnline :: Node.List -> [Node.Node]
56
57
getOnline = filter (not . Node.offline) . Container.elems

58
-- | Try to allocate an instance on the cluster
59
tryAlloc :: (Monad m) =>
60
61
            Node.List
         -> Instance.List
62
63
         -> Instance.Instance
         -> Int
64
         -> m [(Maybe Node.List, [Node.Node])]
65
tryAlloc nl _ inst 2 =
66
    let all_nodes = getOnline nl
67
68
        all_pairs = liftM2 (,) all_nodes all_nodes
        ok_pairs = filter (\(x, y) -> Node.idx x /= Node.idx y) all_pairs
69
70
71
72
73
74
        sols = map (\(p, s) ->
                        (fst $ Cluster.allocateOnPair nl inst p s, [p, s]))
               ok_pairs
    in return sols

tryAlloc nl _ inst 1 =
75
    let all_nodes = getOnline nl
76
77
78
        sols = map (\p -> (fst $ Cluster.allocateOnSingle nl inst p, [p]))
               all_nodes
    in return sols
79
80
81
82

tryAlloc _ _ _ reqn = fail $ "Unsupported number of alllocation \
                             \destinations required (" ++ (show reqn) ++
                                               "), only two supported"
83
84

-- | Try to allocate an instance on the cluster
85
tryReloc :: (Monad m) =>
86
87
            Node.List
         -> Instance.List
88
89
90
         -> Int
         -> Int
         -> [Int]
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' . idxOf) all_nodes
97
98
        valid_idxes = map Node.idx valid_nodes
        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
104
105
106
107
108
    in return sols1

tryReloc _ _ _ reqn _  = fail $ "Unsupported number of relocation \
                                \destinations required (" ++ (show reqn) ++
                                                  "), only one supported"

109
110
filterFails :: (Monad m) => [(Maybe Node.List, [Node.Node])]
            -> m [(Node.List, [Node.Node])]
111
112
113
114
115
filterFails sols =
    if null sols then fail "No nodes onto which to allocate at all"
    else let sols' = filter (isJust . fst) sols
         in if null sols' then
                fail "No valid allocation solutions"
116
            else
117
118
                return $ map (\(x, y) -> (fromJust x, y)) sols'

119
processResults :: (Monad m) => [(Node.List, [Node.Node])]
120
121
122
123
124
125
               -> m (String, [Node.Node])
processResults sols =
    let sols' = map (\(nl', ns) -> (Cluster.compCV  nl', ns)) sols
        sols'' = sortBy (compare `on` fst) sols'
        (best, w) = head sols''
        (worst, l) = last sols''
126
127
        info = printf "Valid results: %d, best score: %.8f for node(s) %s, \
                      \worst score: %.8f for node(s) %s" (length sols'')
128
129
130
                      best (intercalate "/" . map Node.name $ w)
                      worst (intercalate "/" . map Node.name $ l)
    in return (info, w)
Iustin Pop's avatar
Iustin Pop committed
131
132
133
134
135

-- | Main function.
main :: IO ()
main = do
  cmd_args <- System.getArgs
Iustin Pop's avatar
Iustin Pop committed
136
  (_, args) <- CLI.parseOpts cmd_args "hail" options defaultOptions
Iustin Pop's avatar
Iustin Pop committed
137
138
139
140
141
142
143
144
145
146
147
148
149
150

  when (null args) $ do
         hPutStrLn stderr "Error: this program needs an input file."
         exitWith $ ExitFailure 1

  let input_file = head args
  input_data <- readFile input_file

  request <- case (parseData input_data) of
               Bad err -> do
                 putStrLn $ "Error: " ++ err
                 exitWith $ ExitFailure 1
               Ok rq -> return rq

151
152
153
154
155
  let Request rqtype nl il csf = request
      new_nodes = case rqtype of
                    Allocate xi reqn -> tryAlloc nl il xi reqn
                    Relocate idx reqn exnodes ->
                        tryReloc nl il idx reqn exnodes
156
157
  let sols = new_nodes >>= filterFails >>= processResults
  let (ok, info, rn) = case sols of
158
               Ok (info, sn) -> (True, "Request successful: " ++ info,
159
                                     map ((++ csf) . Node.name) sn)
160
161
162
               Bad s -> (False, "Request failed: " ++ s, [])
      resp = formatResponse ok info rn
  putStrLn resp