RAPI: read the group UUID from the server

[ganeti-local] / hail.hs

diff --git a/hail.hs b/hail.hs
index 0167d55..d67bd68 100644 (file)
--- a/hail.hs
+++ b/hail.hs
@@ -26,62 +26,47 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 module Main (main) where
 
 import Data.List
-import Data.Function
+import Data.Maybe (isJust, fromJust)
 import Monad
-import System
+import System (exitWith, ExitCode(..))
 import System.IO
-import System.Console.GetOpt
 import qualified System
 
 import Text.Printf (printf)
 
 import qualified Ganeti.HTools.Cluster as Cluster
 import qualified Ganeti.HTools.Node as Node
-import qualified Ganeti.HTools.CLI as CLI
+
+import Ganeti.HTools.CLI
 import Ganeti.HTools.IAlloc
 import Ganeti.HTools.Types
 import Ganeti.HTools.Loader (RqType(..), Request(..))
 
--- | Command line options structure.
-data Options = Options
-    { optShowVer   :: Bool           -- ^ Just show the program version
-    , optShowHelp  :: Bool           -- ^ Just show the help
-    } deriving Show
-
--- | Default values for the command line options.
-defaultOptions :: Options
-defaultOptions  = Options
- { optShowVer   = False
- , optShowHelp  = False
- }
-
-instance CLI.CLIOptions Options where
-    showVersion = optShowVer
-    showHelp    = optShowHelp
-
 -- | Options list and functions
-options :: [OptDescr (Options -> Options)]
-options =
-    [ Option ['V']     ["version"]
-      (NoArg (\ opts -> opts { optShowVer = True}))
-      "show the version of the program"
-    , Option ['h']     ["help"]
-      (NoArg (\ opts -> opts { optShowHelp = True}))
-      "show help"
-    ]
-
-
-processResults :: (Monad m) => Cluster.AllocSolution -> m (String, [Node.Node])
-processResults (fstats, succ, sols) =
+options :: [OptType]
+options = [oPrintNodes, 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 = fst $ 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
-      Nothing -> fail "No valid allocation solutions"
-      Just (best, (_, _, w)) ->
+      (best, (_, _, w)):[] ->
           let tfails = length fstats
               info = printf "successes %d, failures %d,\
                             \ best score: %.8f for node(s) %s"
-                            succ tfails
+                            successes tfails
                             best (intercalate "/" . map Node.name $ w)::String
-          in return (info, w)
+          in return (info, as)
+      _ -> fail "Internal error: multiple allocation solutions"
 
 -- | Process a request and return new node lists
 processRequest :: Request
@@ -91,18 +76,20 @@ processRequest 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
 
 -- | Main function.
 main :: IO ()
 main = do
   cmd_args <- System.getArgs
-  (_, args) <- CLI.parseOpts cmd_args "hail" options defaultOptions
+  (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
 
   request <- case (parseData input_data) of
@@ -111,12 +98,17 @@ main = do
                  exitWith $ ExitFailure 1
                Ok rq -> return rq
 
-  let Request _ _ _ csf = request
-      sols = processRequest request >>= processResults
+  let Request rq nl _ _ = request
+
+  when (isJust shownodes) $ do
+         hPutStrLn stderr "Initial cluster status:"
+         hPutStrLn stderr $ Cluster.printNodes nl (fromJust shownodes)
+
+  let sols = processRequest request >>= processResults rq
   let (ok, info, rn) =
           case sols of
-            Ok (info, sn) -> (True, "Request successful: " ++ info,
-                                  map ((++ csf) . Node.name) sn)
+            Ok (ginfo, (_, _, sn)) -> (True, "Request successful: " ++ ginfo,
+                                       map snd sn)
             Bad s -> (False, "Request failed: " ++ s, [])
-      resp = formatResponse ok info rn
+      resp = formatResponse ok info rq rn
   putStrLn resp