Cluster.hs: add a new type alias

[ganeti-local] / hail.hs

diff --git a/hail.hs b/hail.hs
index 90902e6..541e1a9 100644 (file)
--- a/hail.hs
+++ b/hail.hs
@@ -4,7 +4,7 @@
 
 {-
 
-Copyright (C) 2009, 2010 Google Inc.
+Copyright (C) 2009, 2010, 2011 Google Inc.
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -32,51 +32,69 @@ import System (exitWith, ExitCode(..))
 import System.IO
 import qualified System
 
-import Text.Printf (printf)
-
 import qualified Ganeti.HTools.Cluster as Cluster
-import qualified Ganeti.HTools.Node as Node
 
 import Ganeti.HTools.CLI
 import Ganeti.HTools.IAlloc
 import Ganeti.HTools.Types
-import Ganeti.HTools.Loader (RqType(..), Request(..))
+import Ganeti.HTools.Loader (RqType(..), Request(..), ClusterData(..))
+import Ganeti.HTools.ExtLoader (loadExternalData)
 
 -- | Options list and functions
 options :: [OptType]
-options = [oPrintNodes, oShowVer, oShowHelp]
+options =
+    [ oPrintNodes
+    , oDataFile
+    , oNodeSim
+    , oShowVer
+    , oShowHelp
+    ]
 
 processResults :: (Monad m) =>
                   RqType -> Cluster.AllocSolution
-               -> m (String, Cluster.AllocSolution)
-processResults _ (_, _, []) = fail "No valid allocation solutions"
-processResults (Evacuate _) as@(fstats, successes, sols) =
-    let (_, _, _, best) = head sols
-        tfails = length fstats
-        info = printf "for last allocation, successes %d, failures %d,\
-                      \ best score: %.8f" successes tfails best::String
-    in return (info, as)
-
-processResults _ as@(fstats, successes, sols) =
-    case sols of
-      (_, _, w, best):[] ->
-          let tfails = length fstats
-              info = printf "successes %d, failures %d,\
-                            \ best score: %.8f for node(s) %s"
-                            successes tfails
-                            best (intercalate "/" . map Node.name $ w)::String
-          in return (info, as)
+               -> m Cluster.AllocSolution
+processResults _ (Cluster.AllocSolution { Cluster.asSolutions = [],
+                                          Cluster.asLog = msgs }) =
+  fail $ intercalate ", " msgs
+
+processResults (Evacuate _) as = return as
+
+processResults _ as =
+    case Cluster.asSolutions as of
+      _:[] -> return as
       _ -> fail "Internal error: multiple allocation solutions"
 
 -- | Process a request and return new node lists
 processRequest :: Request
                -> Result Cluster.AllocSolution
 processRequest request =
-  let Request rqtype nl il _ = request
+  let Request rqtype (ClusterData gl nl il _) = request
   in case rqtype of
-       Allocate xi reqn -> Cluster.tryAlloc nl il xi reqn
-       Relocate idx reqn exnodes -> Cluster.tryReloc nl il idx reqn exnodes
-       Evacuate exnodes -> Cluster.tryEvac nl il exnodes
+       Allocate xi reqn -> Cluster.tryMGAlloc gl nl il xi reqn
+       Relocate idx reqn exnodes -> Cluster.tryMGReloc gl nl il
+                                    idx reqn exnodes
+       Evacuate exnodes -> Cluster.tryMGEvac gl nl il exnodes
+
+-- | Reads the request from the data file(s)
+readRequest :: Options -> [String] -> IO Request
+readRequest opts args = do
+  when (null args) $ do
+         hPutStrLn stderr "Error: this program needs an input file."
+         exitWith $ ExitFailure 1
+
+  input_data <- readFile (head args)
+  r1 <- case (parseData input_data) of
+          Bad err -> do
+            hPutStrLn stderr $ "Error: " ++ err
+            exitWith $ ExitFailure 1
+          Ok rq -> return rq
+  r2 <- if isJust (optDataFile opts) ||  (not . null . optNodeSim) opts
+        then  do
+          cdata <- loadExternalData opts
+          let Request rqt _ = r1
+          return $ Request rqt cdata
+        else return r1
+  return r2
 
 -- | Main function.
 main :: IO ()
@@ -84,31 +102,23 @@ main = do
   cmd_args <- System.getArgs
   (opts, args) <- parseOpts cmd_args "hail" options
 
-  when (null args) $ do
-         hPutStrLn stderr "Error: this program needs an input file."
-         exitWith $ ExitFailure 1
-
-  let input_file = head args
-      shownodes = optShowNodes opts
-  input_data <- readFile input_file
+  let shownodes = optShowNodes opts
 
-  request <- case (parseData input_data) of
-               Bad err -> do
-                 hPutStrLn stderr $ "Error: " ++ err
-                 exitWith $ ExitFailure 1
-               Ok rq -> return rq
+  request <- readRequest opts args
 
-  let Request rq nl _ _ = request
+  let Request rq cdata = request
 
   when (isJust shownodes) $ do
          hPutStrLn stderr "Initial cluster status:"
-         hPutStrLn stderr $ Cluster.printNodes nl (fromJust shownodes)
+         hPutStrLn stderr $ Cluster.printNodes (cdNodes cdata)
+                       (fromJust shownodes)
 
   let sols = processRequest request >>= processResults rq
   let (ok, info, rn) =
           case sols of
-            Ok (ginfo, (_, _, sn)) -> (True, "Request successful: " ++ ginfo,
-                                       sn)
+            Ok as -> (True, "Request successful: " ++
+                            intercalate ", " (Cluster.asLog as),
+                      Cluster.asSolutions as)
             Bad s -> (False, "Request failed: " ++ s, [])
       resp = formatResponse ok info rq rn
   putStrLn resp