Statistics
| Branch: | Tag: | Revision:

root / htools / hail.hs @ a69ff623

History | View | Annotate | Download (3.7 kB)

1
{-| Solver for N+1 cluster errors
2

    
3
-}
4

    
5
{-
6

    
7
Copyright (C) 2009, 2010, 2011 Google Inc.
8

    
9
This program is free software; you can redistribute it and/or modify
10
it under the terms of the GNU General Public License as published by
11
the Free Software Foundation; either version 2 of the License, or
12
(at your option) any later version.
13

    
14
This program is distributed in the hope that it will be useful, but
15
WITHOUT ANY WARRANTY; without even the implied warranty of
16
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
17
General Public License for more details.
18

    
19
You should have received a copy of the GNU General Public License
20
along with this program; if not, write to the Free Software
21
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
22
02110-1301, USA.
23

    
24
-}
25

    
26
module Main (main) where
27

    
28
import Data.List
29
import Data.Maybe (isJust, fromJust)
30
import Monad
31
import System (exitWith, ExitCode(..))
32
import System.IO
33
import qualified System
34

    
35
import qualified Ganeti.HTools.Cluster as Cluster
36

    
37
import Ganeti.HTools.CLI
38
import Ganeti.HTools.IAlloc
39
import Ganeti.HTools.Types
40
import Ganeti.HTools.Loader (RqType(..), Request(..), ClusterData(..))
41
import Ganeti.HTools.ExtLoader (loadExternalData)
42

    
43
-- | Options list and functions
44
options :: [OptType]
45
options =
46
    [ oPrintNodes
47
    , oDataFile
48
    , oNodeSim
49
    , oShowVer
50
    , oShowHelp
51
    ]
52

    
53
processResults :: (Monad m) =>
54
                  RqType -> Cluster.AllocSolution
55
               -> m Cluster.AllocSolution
56
processResults _ (Cluster.AllocSolution { Cluster.asSolutions = [],
57
                                          Cluster.asLog = msgs }) =
58
  fail $ intercalate ", " msgs
59

    
60
processResults (Evacuate _) as = return as
61

    
62
processResults _ as =
63
    case Cluster.asSolutions as of
64
      _:[] -> return as
65
      _ -> fail "Internal error: multiple allocation solutions"
66

    
67
-- | Process a request and return new node lists
68
processRequest :: Request
69
               -> Result Cluster.AllocSolution
70
processRequest request =
71
  let Request rqtype (ClusterData gl nl il _) = request
72
  in case rqtype of
73
       Allocate xi reqn -> Cluster.tryMGAlloc gl nl il xi reqn
74
       Relocate idx reqn exnodes -> Cluster.tryMGReloc gl nl il
75
                                    idx reqn exnodes
76
       Evacuate exnodes -> Cluster.tryMGEvac gl nl il exnodes
77

    
78
-- | Reads the request from the data file(s)
79
readRequest :: Options -> [String] -> IO Request
80
readRequest opts args = do
81
  when (null args) $ do
82
         hPutStrLn stderr "Error: this program needs an input file."
83
         exitWith $ ExitFailure 1
84

    
85
  input_data <- readFile (head args)
86
  r1 <- case (parseData input_data) of
87
          Bad err -> do
88
            hPutStrLn stderr $ "Error: " ++ err
89
            exitWith $ ExitFailure 1
90
          Ok rq -> return rq
91
  (if isJust (optDataFile opts) ||  (not . null . optNodeSim) opts
92
   then do
93
     cdata <- loadExternalData opts
94
     let Request rqt _ = r1
95
     return $ Request rqt cdata
96
   else return r1)
97

    
98
-- | Main function.
99
main :: IO ()
100
main = do
101
  cmd_args <- System.getArgs
102
  (opts, args) <- parseOpts cmd_args "hail" options
103

    
104
  let shownodes = optShowNodes opts
105

    
106
  request <- readRequest opts args
107

    
108
  let Request rq cdata = request
109

    
110
  when (isJust shownodes) $ do
111
         hPutStrLn stderr "Initial cluster status:"
112
         hPutStrLn stderr $ Cluster.printNodes (cdNodes cdata)
113
                       (fromJust shownodes)
114

    
115
  let sols = processRequest request >>= processResults rq
116
  let (ok, info, rn) =
117
          case sols of
118
            Ok as -> (True, "Request successful: " ++
119
                            intercalate ", " (Cluster.asLog as),
120
                      Cluster.asSolutions as)
121
            Bad s -> (False, "Request failed: " ++ s, [])
122
      resp = formatResponse ok info rq rn
123
  putStrLn resp