Unify the command line options and structures

[ganeti-local] / hail.hs

diff --git a/hail.hs b/hail.hs
index 4befe38..7690f44 100644 (file)
--- a/hail.hs
+++ b/hail.hs
@@ -30,79 +30,37 @@ import Data.Function
 import Monad
 import System
 import System.IO
 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 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.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 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) => [(OpResult 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' = concatMap (\ (onl, _, nn) ->
-                                    case onl of
-                                      OpFail _ -> []
-                                      OpGood gnl -> [(gnl, nn)]
-                               ) sols
-         in
-           if null sols'
-           then fail "No valid allocation solutions"
-           else return 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
 
 -- | Process a request and return new node lists
 processRequest :: Request

-               -> Result [(OpResult Node.List, Instance.Instance, [Node.Node])]
+               -> Result Cluster.AllocSolution

 processRequest request =
   let Request rqtype nl il _ = request
   in case rqtype of
 processRequest request =
   let Request rqtype nl il _ = request
   in case rqtype of

@@ -113,7 +71,7 @@ processRequest request =
 main :: IO ()
 main = do
   cmd_args <- System.getArgs
 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."
 
   when (null args) $ do
          hPutStrLn stderr "Error: this program needs an input file."

@@ -124,15 +82,16 @@ main = do
 
   request <- case (parseData input_data) of
                Bad err -> 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
                  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
       resp = formatResponse ok info rn
   putStrLn resp