Unify the command line options and structures

[ganeti-local] / hail.hs

diff --git a/hail.hs b/hail.hs
index ae8e112..7690f44 100644 (file)
--- a/hail.hs
+++ b/hail.hs
@@ -27,80 +27,40 @@ module Main (main) where
 
 import Data.List
 import Data.Function
-import Data.Maybe (isJust, fromJust)
 import Monad
 import System
 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.Instance as Instance
-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(..))
-import Ganeti.HTools.Utils
-
--- | 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"
-    ]
-
-
-filterFails :: (Monad m) => [(Maybe Node.List, Instance.Instance, [Node.Node])]
-            -> m [(Node.List, [Node.Node])]
-filterFails sols =
-    if null sols then fail "No nodes onto which to allocate at all"
-    else let sols' = filter (isJust . fst3) sols
-         in if null sols' then
-                fail "No valid allocation solutions"
-            else
-                return $ map (\(x, _, y) -> (fromJust x, y)) sols'
-
-processResults :: (Monad m) => [(Node.List, [Node.Node])]
-               -> 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''
-        info = (printf "Valid results: %d, best score: %.8f for node(s) %s, \
-                       \worst score: %.8f for node(s) %s" (length sols'')
-                       best (intercalate "/" . map Node.name $ w)
-                       worst (intercalate "/" . map Node.name $ l))::String
-    in return (info, w)
+options :: [OptType]
+options = [oShowVer, oShowHelp]
+
+processResults :: (Monad m) => Cluster.AllocSolution -> m (String, [Node.Node])
+processResults (fstats, succ, sols) =
+    case sols of
+      Nothing -> fail "No valid allocation solutions"
+      Just (best, (_, _, w)) ->
+          let tfails = length fstats
+              info = printf "successes %d, failures %d,\
+                            \ best score: %.8f for node(s) %s"
+                            succ tfails
+                            best (intercalate "/" . map Node.name $ w)::String
+          in return (info, w)
 
 -- | Process a request and return new node lists
-processRequest ::
-                  Request
-               -> Result [(Maybe Node.List, Instance.Instance, [Node.Node])]
+processRequest :: Request
+               -> Result Cluster.AllocSolution
 processRequest request =
   let Request rqtype nl il _ = request
   in case rqtype of
@@ -111,7 +71,7 @@ processRequest request =
 main :: IO ()
 main = do
   cmd_args <- System.getArgs
-  (_, args) <- CLI.parseOpts cmd_args "hail" options defaultOptions
+  (_, args) <- parseOpts cmd_args "hail" options
 
   when (null args) $ do
          hPutStrLn stderr "Error: this program needs an input file."
@@ -122,15 +82,16 @@ main = do
 
   request <- case (parseData input_data) of
                Bad err -> do
-                 putStrLn $ "Error: " ++ err
+                 hPutStrLn stderr $ "Error: " ++ err
                  exitWith $ ExitFailure 1
                Ok rq -> return rq
 
   let Request _ _ _ csf = request
-      sols = processRequest request >>= filterFails >>= processResults
-  let (ok, info, rn) = case sols of
-               Ok (info, sn) -> (True, "Request successful: " ++ info,
-                                     map ((++ csf) . Node.name) sn)
-               Bad s -> (False, "Request failed: " ++ s, [])
+      sols = processRequest request >>= processResults
+  let (ok, info, rn) =
+          case sols of
+            Ok (info, sn) -> (True, "Request successful: " ++ info,
+                                  map ((++ csf) . Node.name) sn)
+            Bad s -> (False, "Request failed: " ++ s, [])
       resp = formatResponse ok info rn
   putStrLn resp