Statistics
| Branch: | Tag: | Revision:

root / hail.hs @ 608efcce

History | View | Annotate | Download (5.4 kB)

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 Node.List
55
getOnline :: Node.List -> [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
            Node.List
61
         -> Instance.List
62
         -> Instance.Instance
63
         -> Int
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]))
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
            Node.List
87
         -> Instance.List
88
         -> Idx
89
         -> Int
90
         -> [Ndx]
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])
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 Node.List, [Node.Node])]
110
            -> m [(Node.List, [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) => [(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)
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) . Node.name) sn)
160
               Bad s -> (False, "Request failed: " ++ s, [])
161
      resp = formatResponse ok info rn
162
  putStrLn resp