diff --git a/Makefile.am b/Makefile.am
index aea7174c703de87ed45a7ec08ad8ce5df85617b1..7a377572841ea9c4fc10e7b3f138a8cd9288331d 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -412,6 +412,7 @@ HS_LIB_SRCS = \
htools/Ganeti/HTools/Program/Hscan.hs \
htools/Ganeti/HTools/Program/Hspace.hs \
htools/Ganeti/BasicTypes.hs \
+ htools/Ganeti/Common.hs \
htools/Ganeti/Compat.hs \
htools/Ganeti/Confd.hs \
htools/Ganeti/Confd/Server.hs \
@@ -439,6 +440,8 @@ HS_LIB_SRCS = \
HS_TEST_SRCS = \
htest/Test/Ganeti/BasicTypes.hs \
+ htest/Test/Ganeti/Common.hs \
+ htest/Test/Ganeti/Daemon.hs \
htest/Test/Ganeti/Confd/Utils.hs \
htest/Test/Ganeti/HTools/CLI.hs \
htest/Test/Ganeti/HTools/Cluster.hs \
diff --git a/htest/Test/Ganeti/Common.hs b/htest/Test/Ganeti/Common.hs
new file mode 100644
index 0000000000000000000000000000000000000000..6c2e3f29a10702029a642afe4505655c3c3de625
--- /dev/null
+++ b/htest/Test/Ganeti/Common.hs
@@ -0,0 +1,127 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{-| Unittests for the 'Ganeti.Common' module.
+
+-}
+
+{-
+
+Copyright (C) 2009, 2010, 2011, 2012 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
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.
+
+-}
+
+module Test.Ganeti.Common
+ ( testCommon
+ , checkOpt
+ , passFailOpt
+ , checkEarlyExit
+ ) where
+
+import Test.QuickCheck hiding (Result)
+import Test.HUnit
+
+import qualified System.Console.GetOpt as GetOpt
+import System.Exit
+
+import Test.Ganeti.TestHelper
+import Test.Ganeti.TestCommon
+
+import Ganeti.BasicTypes
+import Ganeti.Common
+
+-- | Helper to check for correct parsing of an option.
+checkOpt :: (StandardOptions b) =>
+ (a -> Maybe String) -- ^ Converts the value into a cmdline form
+ -> b -- ^ The default options
+ -> (String -> c) -- ^ Fail test function
+ -> (String -> d -> d -> c) -- ^ Check for equality function
+ -> (a -> d) -- ^ Transforms the value to a compare val
+ -> (a, GenericOptType b, b -> d) -- ^ Triple of value, the
+ -- option, function to
+ -- extract the set value
+ -- from the options
+ -> c
+checkOpt repr defaults failfn eqcheck valfn
+ (val, opt@(GetOpt.Option _ longs _ _), fn) =
+ case longs of
+ [] -> failfn "no long options?"
+ cmdarg:_ ->
+ case parseOptsInner defaults
+ ["--" ++ cmdarg ++ maybe "" ("=" ++) (repr val)]
+ "prog" [opt] of
+ Left e -> failfn $ "Failed to parse option '" ++ cmdarg ++ ": " ++
+ show e
+ Right (options, _) -> eqcheck ("Wrong value in option " ++
+ cmdarg ++ "?") (valfn val) (fn options)
+
+-- | Helper to check for correct and incorrect parsing of an option.
+passFailOpt :: (StandardOptions b) =>
+ b -- ^ The default options
+ -> (String -> c) -- ^ Fail test function
+ -> c -- ^ Pass function
+ -> (GenericOptType b, String, String)
+ -- ^ The list of enabled options, fail value and pass value
+ -> c
+passFailOpt defaults failfn passfn
+ (opt@(GetOpt.Option _ longs _ _), bad, good) =
+ let prefix = "--" ++ head longs ++ "="
+ good_cmd = prefix ++ good
+ bad_cmd = prefix ++ bad in
+ case (parseOptsInner defaults [bad_cmd] "prog" [opt],
+ parseOptsInner defaults [good_cmd] "prog" [opt]) of
+ (Left _, Right _) -> passfn
+ (Right _, Right _) -> failfn $ "Command line '" ++ bad_cmd ++
+ "' succeeded when it shouldn't"
+ (Left _, Left _) -> failfn $ "Command line '" ++ good_cmd ++
+ "' failed when it shouldn't"
+ (Right _, Left _) ->
+ failfn $ "Command line '" ++ bad_cmd ++
+ "' succeeded when it shouldn't, while command line '" ++
+ good_cmd ++ "' failed when it shouldn't"
+
+-- | Helper to test that a given option is accepted OK with quick exit.
+checkEarlyExit :: (StandardOptions a) =>
+ a -> String -> [GenericOptType a] -> Assertion
+checkEarlyExit defaults name options =
+ mapM_ (\param ->
+ case parseOptsInner defaults [param] name options of
+ Left (code, _) ->
+ assertEqual ("Program " ++ name ++
+ " returns invalid code " ++ show code ++
+ " for option " ++ param) ExitSuccess code
+ _ -> assertFailure $ "Program " ++ name ++
+ " doesn't consider option " ++
+ param ++ " as early exit one"
+ ) ["-h", "--help", "-V", "--version"]
+
+-- | Test parseYesNo.
+prop_parse_yes_no :: Bool -> Bool -> String -> Property
+prop_parse_yes_no def testval val =
+ forAll (elements [val, "yes", "no"]) $ \actual_val ->
+ if testval
+ then parseYesNo def Nothing ==? Ok def
+ else let result = parseYesNo def (Just actual_val)
+ in if actual_val `elem` ["yes", "no"]
+ then result ==? Ok (actual_val == "yes")
+ else property $ isBad result
+
+
+testSuite "Common"
+ [ 'prop_parse_yes_no
+ ]
diff --git a/htest/Test/Ganeti/Daemon.hs b/htest/Test/Ganeti/Daemon.hs
new file mode 100644
index 0000000000000000000000000000000000000000..fb6cc757e86d1785ba59c15f095d67d9a94bfd76
--- /dev/null
+++ b/htest/Test/Ganeti/Daemon.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{-| Unittests for ganeti-htools.
+
+-}
+
+{-
+
+Copyright (C) 2009, 2010, 2011, 2012 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
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.
+
+-}
+
+module Test.Ganeti.Daemon (testDaemon) where
+
+import Test.QuickCheck hiding (Result)
+import Test.HUnit
+
+import Test.Ganeti.TestHelper
+import Test.Ganeti.TestCommon
+import Test.Ganeti.Common
+
+import Ganeti.Common
+import Ganeti.Daemon as Daemon
+
+-- | Test a few string arguments.
+prop_string_arg :: String -> Property
+prop_string_arg argument =
+ let args = [ (argument, oBindAddress, optBindAddress)
+ ]
+ in conjoin $
+ map (checkOpt Just defaultOptions failTest (const (==?)) Just) args
+
+-- | Test a few integer arguments (only one for now).
+prop_numeric_arg :: Int -> Property
+prop_numeric_arg argument =
+ checkOpt (Just . show) defaultOptions
+ failTest (const (==?)) (Just . fromIntegral)
+ (argument, oPort 0, optPort)
+
+-- | Test a few boolean arguments.
+case_bool_arg :: Assertion
+case_bool_arg =
+ mapM_ (checkOpt (const Nothing) defaultOptions assertFailure
+ assertEqual id)
+ [ (False, oNoDaemonize, optDaemonize)
+ , (True, oDebug, optDebug)
+ , (True, oNoUserChecks, optNoUserChecks)
+ ]
+
+-- | Tests a few invalid arguments.
+case_wrong_arg :: Assertion
+case_wrong_arg = do
+ mapM_ (passFailOpt defaultOptions assertFailure (return ()))
+ [ (oSyslogUsage, "foo", "yes")
+ , (oPort 0, "x", "10")
+ ]
+
+-- | Test that the option list supports some common options.
+case_stdopts :: Assertion
+case_stdopts =
+ checkEarlyExit defaultOptions "prog" [oShowHelp, oShowVer]
+
+testSuite "Daemon"
+ [ 'prop_string_arg
+ , 'prop_numeric_arg
+ , 'case_bool_arg
+ , 'case_wrong_arg
+ , 'case_stdopts
+ ]
diff --git a/htest/Test/Ganeti/HTools/CLI.hs b/htest/Test/Ganeti/HTools/CLI.hs
index 239dae9acc85a44094a8f5581b9c8ca0de4da59e..b7493d4936845cb4321926a7df53d5648974ded6 100644
--- a/htest/Test/Ganeti/HTools/CLI.hs
+++ b/htest/Test/Ganeti/HTools/CLI.hs
@@ -28,17 +28,18 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
module Test.Ganeti.HTools.CLI (testHTools_CLI) where
+import Test.HUnit
import Test.QuickCheck
import Control.Monad
import Data.List
import Text.Printf (printf)
-import qualified System.Console.GetOpt as GetOpt
import Test.Ganeti.TestHelper
import Test.Ganeti.TestCommon
+import Test.Ganeti.Common
-import qualified Ganeti.HTools.CLI as CLI
+import Ganeti.HTools.CLI as CLI
import qualified Ganeti.HTools.Program as Program
import qualified Ganeti.HTools.Types as Types
@@ -46,7 +47,7 @@ import qualified Ganeti.HTools.Types as Types
prop_parseISpec :: String -> Int -> Int -> Int -> Property
prop_parseISpec descr dsk mem cpu =
let str = printf "%d,%d,%d" dsk mem cpu::String
- in CLI.parseISpecString descr str ==? Types.Ok (Types.RSpec cpu mem dsk)
+ in parseISpecString descr str ==? Types.Ok (Types.RSpec cpu mem dsk)
-- | Test parsing failure due to wrong section count.
prop_parseISpecFail :: String -> Property
@@ -54,71 +55,76 @@ prop_parseISpecFail descr =
forAll (choose (0,100) `suchThat` ((/=) 3)) $ \nelems ->
forAll (replicateM nelems arbitrary) $ \values ->
let str = intercalate "," $ map show (values::[Int])
- in case CLI.parseISpecString descr str of
+ in case parseISpecString descr str of
Types.Ok v -> failTest $ "Expected failure, got " ++ show v
_ -> passTest
--- | Test parseYesNo.
-prop_parseYesNo :: Bool -> Bool -> [Char] -> Property
-prop_parseYesNo def testval val =
- forAll (elements [val, "yes", "no"]) $ \actual_val ->
- if testval
- then CLI.parseYesNo def Nothing ==? Types.Ok def
- else let result = CLI.parseYesNo def (Just actual_val)
- in if actual_val `elem` ["yes", "no"]
- then result ==? Types.Ok (actual_val == "yes")
- else property $ Types.isBad result
-
--- | Helper to check for correct parsing of string arg.
-checkStringArg :: [Char]
- -> (GetOpt.OptDescr (CLI.Options -> Types.Result CLI.Options),
- CLI.Options -> Maybe [Char])
- -> Property
-checkStringArg val (opt, fn) =
- let GetOpt.Option _ longs _ _ = opt
- in case longs of
- [] -> failTest "no long options?"
- cmdarg:_ ->
- case CLI.parseOptsInner ["--" ++ cmdarg ++ "=" ++ val] "prog" [opt] of
- Left e -> failTest $ "Failed to parse option: " ++ show e
- Right (options, _) -> fn options ==? Just val
-
-- | Test a few string arguments.
-prop_StringArg :: [Char] -> Property
-prop_StringArg argument =
- let args = [ (CLI.oDataFile, CLI.optDataFile)
- , (CLI.oDynuFile, CLI.optDynuFile)
- , (CLI.oSaveCluster, CLI.optSaveCluster)
- , (CLI.oReplay, CLI.optReplay)
- , (CLI.oPrintCommands, CLI.optShowCmds)
- , (CLI.oLuxiSocket, CLI.optLuxi)
+prop_string_arg :: String -> Property
+prop_string_arg argument =
+ let args = [ (oDataFile, optDataFile)
+ , (oDynuFile, optDynuFile)
+ , (oSaveCluster, optSaveCluster)
+ , (oPrintCommands, optShowCmds)
+ , (oLuxiSocket, optLuxi)
+ , (oIAllocSrc, optIAllocSrc)
+ ]
+ in conjoin $ map (\(o, opt) ->
+ checkOpt Just defaultOptions
+ failTest (const (==?)) Just (argument, o, opt)) args
+
+-- | Test a few positive arguments.
+prop_numeric_arg :: Positive Double -> Property
+prop_numeric_arg (Positive argument) =
+ let args = [ (oMaxCpu, optMcpu)
+ , (oMinDisk, Just . optMdsk)
+ , (oMinGain, Just . optMinGain)
+ , (oMinGainLim, Just . optMinGainLim)
+ , (oMinScore, Just . optMinScore)
]
- in conjoin $ map (checkStringArg argument) args
-
--- | Helper to test that a given option is accepted OK with quick exit.
-checkEarlyExit :: String -> [CLI.OptType] -> String -> Property
-checkEarlyExit name options param =
- case CLI.parseOptsInner [param] name options of
- Left (code, _) ->
- printTestCase ("Program " ++ name ++
- " returns invalid code " ++ show code ++
- " for option " ++ param) (code == 0)
- _ -> failTest $ "Program " ++ name ++ " doesn't consider option " ++
- param ++ " as early exit one"
-
--- | Test that all binaries support some common options. There is
--- nothing actually random about this test...
-prop_stdopts :: Property
-prop_stdopts =
- let params = ["-h", "--help", "-V", "--version"]
- opts = map (\(name, (_, o)) -> (name, o)) Program.personalities
- -- apply checkEarlyExit across the cartesian product of params and opts
- in conjoin [checkEarlyExit n o p | p <- params, (n, o) <- opts]
+ in conjoin $
+ map (\(x, y) -> checkOpt (Just . show) defaultOptions
+ failTest (const (==?)) Just (argument, x, y)) args
+
+-- | Test a few boolean arguments.
+case_bool_arg :: Assertion
+case_bool_arg =
+ mapM_ (checkOpt (const Nothing) defaultOptions assertFailure
+ assertEqual id)
+ [ (False, oDiskMoves, optDiskMoves)
+ , (False, oInstMoves, optInstMoves)
+ , (True, oEvacMode, optEvacMode)
+ , (True, oExecJobs, optExecJobs)
+ , (True, oNoHeaders, optNoHeaders)
+ , (True, oNoSimulation, optNoSimulation)
+ ]
+
+-- | Tests a few invalid arguments.
+case_wrong_arg :: Assertion
+case_wrong_arg = do
+ mapM_ (passFailOpt defaultOptions assertFailure (return ()))
+ [ (oSpindleUse, "-1", "1")
+ , (oSpindleUse, "a", "1")
+ , (oMaxCpu, "-1", "1")
+ , (oMinDisk, "a", "1")
+ , (oMinGainLim, "a", "1")
+ , (oMaxSolLength, "x", "10")
+ , (oStdSpec, "no-such-spec", "1,1,1")
+ , (oTieredSpec, "no-such-spec", "1,1,1")
+ ]
+
+-- | Test that all binaries support some common options.
+case_stdopts :: Assertion
+case_stdopts =
+ mapM_ (\(name, (_, o)) -> checkEarlyExit defaultOptions name o)
+ Program.personalities
testSuite "HTools/CLI"
[ 'prop_parseISpec
, 'prop_parseISpecFail
- , 'prop_parseYesNo
- , 'prop_StringArg
- , 'prop_stdopts
+ , 'prop_string_arg
+ , 'prop_numeric_arg
+ , 'case_bool_arg
+ , 'case_wrong_arg
+ , 'case_stdopts
]
diff --git a/htest/test.hs b/htest/test.hs
index 9940dc91a64630250fd0502edc32cbd9793a3d6c..60ff088975de5ee678441d623801cfbec24ef7a9 100644
--- a/htest/test.hs
+++ b/htest/test.hs
@@ -32,6 +32,8 @@ import System.Environment (getArgs)
import Test.Ganeti.TestImports ()
import Test.Ganeti.BasicTypes
import Test.Ganeti.Confd.Utils
+import Test.Ganeti.Common
+import Test.Ganeti.Daemon
import Test.Ganeti.HTools.CLI
import Test.Ganeti.HTools.Cluster
import Test.Ganeti.HTools.Container
@@ -78,6 +80,8 @@ allTests :: [(Bool, (String, [Test]))]
allTests =
[ (True, testBasicTypes)
, (True, testConfd_Utils)
+ , (True, testCommon)
+ , (True, testDaemon)
, (True, testHTools_CLI)
, (True, testHTools_Container)
, (True, testHTools_Instance)
diff --git a/htools/Ganeti/Common.hs b/htools/Ganeti/Common.hs
new file mode 100644
index 0000000000000000000000000000000000000000..8b10230c08e1d0ab3ed14b6e1184d5d95610c50f
--- /dev/null
+++ b/htools/Ganeti/Common.hs
@@ -0,0 +1,148 @@
+{-| Base common functionality.
+
+This module holds common functionality shared across Ganeti daemons,
+HTools and any other programs.
+
+-}
+
+{-
+
+Copyright (C) 2009, 2010, 2011, 2012 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
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.
+
+-}
+
+module Ganeti.Common
+ ( GenericOptType
+ , StandardOptions(..)
+ , oShowHelp
+ , oShowVer
+ , usageHelp
+ , versionInfo
+ , reqWithConversion
+ , parseYesNo
+ , parseOpts
+ , parseOptsInner
+ ) where
+
+import Control.Monad (foldM)
+import qualified Data.Version
+import System.Console.GetOpt
+import System.Exit
+import System.Info
+import System.IO
+import Text.Printf (printf)
+
+import Ganeti.BasicTypes
+import qualified Ganeti.Version as Version (version)
+
+-- | Abrreviation for the option type.
+type GenericOptType a = OptDescr (a -> Result a)
+
+-- | Type class for options which support help and version.
+class StandardOptions a where
+ helpRequested :: a -> Bool
+ verRequested :: a -> Bool
+ requestHelp :: a -> a
+ requestVer :: a -> a
+
+-- | Options to request help output.
+oShowHelp :: (StandardOptions a) => GenericOptType a
+oShowHelp = Option "h" ["help"] (NoArg (Ok . requestHelp))
+ "show help"
+
+oShowVer :: (StandardOptions a) => GenericOptType a
+oShowVer = Option "V" ["version"] (NoArg (Ok . requestVer))
+ "show the version of the program"
+
+-- | Usage info.
+usageHelp :: String -> [GenericOptType a] -> String
+usageHelp progname =
+ usageInfo (printf "%s %s\nUsage: %s [OPTION...]"
+ progname Version.version progname)
+
+-- | Show the program version info.
+versionInfo :: String -> String
+versionInfo progname =
+ printf "%s %s\ncompiled with %s %s\nrunning on %s %s\n"
+ progname Version.version compilerName
+ (Data.Version.showVersion compilerVersion)
+ os arch
+
+-- | Helper for parsing a yes\/no command line flag.
+parseYesNo :: Bool -- ^ Default value (when we get a @Nothing@)
+ -> Maybe String -- ^ Parameter value
+ -> Result Bool -- ^ Resulting boolean value
+parseYesNo v Nothing = return v
+parseYesNo _ (Just "yes") = return True
+parseYesNo _ (Just "no") = return False
+parseYesNo _ (Just s) = fail ("Invalid choice '" ++ s ++
+ "', pass one of 'yes' or 'no'")
+
+-- | Helper function for required arguments which need to be converted
+-- as opposed to stored just as string.
+reqWithConversion :: (String -> Result a)
+ -> (a -> b -> Result b)
+ -> String
+ -> ArgDescr (b -> Result b)
+reqWithConversion conversion_fn updater_fn metavar =
+ ReqArg (\string_opt opts -> do
+ parsed_value <- conversion_fn string_opt
+ updater_fn parsed_value opts) metavar
+
+-- | Command line parser, using a generic 'Options' structure.
+parseOpts :: (StandardOptions a) =>
+ a -- ^ The default options
+ -> [String] -- ^ The command line arguments
+ -> String -- ^ The program name
+ -> [GenericOptType a] -- ^ The supported command line options
+ -> IO (a, [String]) -- ^ The resulting options and
+ -- leftover arguments
+parseOpts defaults argv progname options =
+ case parseOptsInner defaults argv progname options of
+ Left (code, msg) -> do
+ hPutStr (if code == ExitSuccess then stdout else stderr) msg
+ exitWith code
+ Right result ->
+ return result
+
+-- | Inner parse options. The arguments are similar to 'parseOpts',
+-- but it returns either a 'Left' composed of exit code and message,
+-- or a 'Right' for the success case.
+parseOptsInner :: (StandardOptions a) =>
+ a
+ -> [String]
+ -> String
+ -> [GenericOptType a]
+ -> Either (ExitCode, String) (a, [String])
+parseOptsInner defaults argv progname options =
+ case getOpt Permute options argv of
+ (opts, args, []) ->
+ case foldM (flip id) defaults opts of
+ Bad msg -> Left (ExitFailure 1,
+ "Error while parsing command line arguments:\n"
+ ++ msg ++ "\n")
+ Ok parsed ->
+ select (Right (parsed, args))
+ [ (helpRequested parsed,
+ Left (ExitSuccess, usageHelp progname options))
+ , (verRequested parsed,
+ Left (ExitSuccess, versionInfo progname))
+ ]
+ (_, _, errs) ->
+ Left (ExitFailure 2, "Command line error: " ++ concat errs ++ "\n" ++
+ usageHelp progname options)
diff --git a/htools/Ganeti/Daemon.hs b/htools/Ganeti/Daemon.hs
index 8fe3a83fc407283bb040c5f45daabe142adcc6e2..2296ef010497da01e0179df76b883fba62dc30b4 100644
--- a/htools/Ganeti/Daemon.hs
+++ b/htools/Ganeti/Daemon.hs
@@ -45,7 +45,6 @@ module Ganeti.Daemon
import Control.Exception
import Control.Monad
import Data.Maybe (fromMaybe)
-import qualified Data.Version
import Data.Word
import GHC.IO.Handle (hDuplicateTo)
import qualified Network.Socket as Socket
@@ -53,7 +52,6 @@ import Prelude hiding (catch)
import System.Console.GetOpt
import System.Exit
import System.Environment
-import System.Info
import System.IO
import System.IO.Error (isDoesNotExistError)
import System.Posix.Directory
@@ -62,13 +60,12 @@ import System.Posix.IO
import System.Posix.Process
import System.Posix.Types
import System.Posix.Signals
-import Text.Printf
+import Ganeti.Common as Common
import Ganeti.Logging
import Ganeti.Runtime
import Ganeti.BasicTypes
import Ganeti.HTools.Utils
-import qualified Ganeti.Version as Version (version)
import qualified Ganeti.Constants as C
import qualified Ganeti.Ssconf as Ssconf
@@ -105,32 +102,17 @@ defaultOptions = DaemonOptions
, optSyslogUsage = Nothing
}
+instance StandardOptions DaemonOptions where
+ helpRequested = optShowHelp
+ verRequested = optShowVer
+ requestHelp = \opts -> opts { optShowHelp = True }
+ requestVer = \opts -> opts { optShowVer = True }
+
-- | Abrreviation for the option type.
-type OptType = OptDescr (DaemonOptions -> Result DaemonOptions)
-
--- | Helper function for required arguments which need to be converted
--- as opposed to stored just as string.
-reqWithConversion :: (String -> Result a)
- -> (a -> DaemonOptions -> Result DaemonOptions)
- -> String
- -> ArgDescr (DaemonOptions -> Result DaemonOptions)
-reqWithConversion conversion_fn updater_fn metavar =
- ReqArg (\string_opt opts -> do
- parsed_value <- conversion_fn string_opt
- updater_fn parsed_value opts) metavar
+type OptType = GenericOptType DaemonOptions
-- * Command line options
-oShowHelp :: OptType
-oShowHelp = Option "h" ["help"]
- (NoArg (\ opts -> Ok opts { optShowHelp = True}))
- "Show the help message and exit"
-
-oShowVer :: OptType
-oShowVer = Option "V" ["version"]
- (NoArg (\ opts -> Ok opts { optShowVer = True}))
- "Show the version of the program and exit"
-
oNoDaemonize :: OptType
oNoDaemonize = Option "f" ["foreground"]
(NoArg (\ opts -> Ok opts { optDaemonize = False}))
@@ -167,36 +149,11 @@ oSyslogUsage = Option "" ["syslog"]
\messages); one of 'no', 'yes' or 'only' [" ++ C.syslogUsage ++
"]")
--- | Usage info.
-usageHelp :: String -> [OptType] -> String
-usageHelp progname =
- usageInfo (printf "%s %s\nUsage: %s [OPTION...]"
- progname Version.version progname)
-
--- | Command line parser, using the 'Options' structure.
-parseOpts :: [String] -- ^ The command line arguments
- -> String -- ^ The program name
- -> [OptType] -- ^ The supported command line options
- -> IO (DaemonOptions, [String]) -- ^ The resulting options
- -- and leftover arguments
-parseOpts argv progname options =
- case getOpt Permute options argv of
- (opt_list, args, []) ->
- do
- parsed_opts <-
- exitIfBad "Error while parsing command line arguments" $
- foldM (flip id) defaultOptions opt_list
- return (parsed_opts, args)
- (_, _, errs) -> do
- hPutStrLn stderr $ "Command line error: " ++ concat errs
- hPutStrLn stderr $ usageHelp progname options
- exitWith $ ExitFailure 2
-
-- | Small wrapper over getArgs and 'parseOpts'.
parseArgs :: String -> [OptType] -> IO (DaemonOptions, [String])
parseArgs cmd options = do
cmd_args <- getArgs
- parseOpts cmd_args cmd options
+ parseOpts defaultOptions cmd_args cmd options
-- * Daemon-related functions
-- | PID file mode.
@@ -321,16 +278,6 @@ genericMain daemon options main = do
let progname = daemonName daemon
(opts, args) <- parseArgs progname options
- when (optShowHelp opts) $ do
- putStr $ usageHelp progname options
- exitSuccess
- when (optShowVer opts) $ do
- printf "%s %s\ncompiled with %s %s\nrunning on %s %s\n"
- progname Version.version
- compilerName (Data.Version.showVersion compilerVersion)
- os arch :: IO ()
- exitSuccess
-
exitUnless (null args) "This program doesn't take any arguments"
unless (optNoUserChecks opts) $ do
diff --git a/htools/Ganeti/HTools/CLI.hs b/htools/Ganeti/HTools/CLI.hs
index 6f437c77fd7410a71596b81711e5c79baf1e0240..ec2a299d7d17d03d85740f576513c3b7f57a9ef8 100644
--- a/htools/Ganeti/HTools/CLI.hs
+++ b/htools/Ganeti/HTools/CLI.hs
@@ -30,7 +30,8 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
module Ganeti.HTools.CLI
( Options(..)
, OptType
- , parseOpts
+ , defaultOptions
+ , Ganeti.HTools.CLI.parseOpts
, parseOptsInner
, parseYesNo
, parseISpecString
@@ -73,13 +74,11 @@ module Ganeti.HTools.CLI
, oPrintNodes
, oQuiet
, oRapiMaster
- , oReplay
, oSaveCluster
, oSelInst
, oShowHelp
, oShowVer
, oStdSpec
- , oTestCount
, oTieredSpec
, oVerbose
) where
@@ -87,20 +86,17 @@ module Ganeti.HTools.CLI
import Control.Monad
import Data.Char (toUpper)
import Data.Maybe (fromMaybe)
-import qualified Data.Version
import System.Console.GetOpt
import System.IO
-import System.Info
-import System.Exit
import Text.Printf (printf)
-import qualified Ganeti.Version as Version (version)
import qualified Ganeti.HTools.Container as Container
import qualified Ganeti.HTools.Node as Node
import qualified Ganeti.Constants as C
import Ganeti.HTools.Types
import Ganeti.HTools.Utils
import Ganeti.BasicTypes
+import Ganeti.Common as Common
-- * Constants
@@ -198,7 +194,13 @@ defaultOptions = Options
}
-- | Abrreviation for the option type.
-type OptType = OptDescr (Options -> Result Options)
+type OptType = GenericOptType Options
+
+instance StandardOptions Options where
+ helpRequested = optShowHelp
+ verRequested = optShowVer
+ requestHelp = \opts -> opts { optShowHelp = True }
+ requestVer = \opts -> opts { optShowVer = True }
-- * Helper functions
@@ -232,19 +234,18 @@ oDiskMoves = Option "" ["no-disk-moves"]
oDiskTemplate :: OptType
oDiskTemplate = Option "" ["disk-template"]
- (ReqArg (\ t opts -> do
- dt <- diskTemplateFromRaw t
- return $ opts { optDiskTemplate = Just dt })
+ (reqWithConversion diskTemplateFromRaw
+ (\dt opts -> Ok opts { optDiskTemplate = Just dt })
"TEMPLATE") "select the desired disk template"
oSpindleUse :: OptType
oSpindleUse = Option "" ["spindle-use"]
- (ReqArg (\ n opts -> do
- su <- tryRead "parsing spindle-use" n
- when (su < 0) $
- fail "Invalid value of the spindle-use\
- \ (expected >= 0)"
- return $ opts { optSpindleUse = Just su })
+ (reqWithConversion (tryRead "parsing spindle-use")
+ (\su opts -> do
+ when (su < 0) $
+ fail "Invalid value of the spindle-use\
+ \ (expected >= 0)"
+ return $ opts { optSpindleUse = Just su })
"SPINDLES") "select how many virtual spindle instances use\
\ [default read from cluster]"
@@ -314,40 +315,45 @@ oMachineReadable = Option "" ["machine-readable"]
oMaxCpu :: OptType
oMaxCpu = Option "" ["max-cpu"]
- (ReqArg (\ n opts -> do
- mcpu <- tryRead "parsing max-cpu" n
- when (mcpu <= 0) $
- fail "Invalid value of the max-cpu ratio,\
- \ expected >0"
- return $ opts { optMcpu = Just mcpu }) "RATIO")
+ (reqWithConversion (tryRead "parsing max-cpu")
+ (\mcpu opts -> do
+ when (mcpu <= 0) $
+ fail "Invalid value of the max-cpu ratio,\
+ \ expected >0"
+ return $ opts { optMcpu = Just mcpu }) "RATIO")
"maximum virtual-to-physical cpu ratio for nodes (from 0\
\ upwards) [default read from cluster]"
oMaxSolLength :: OptType
oMaxSolLength = Option "l" ["max-length"]
- (ReqArg (\ i opts -> Ok opts { optMaxLength = read i }) "N")
+ (reqWithConversion (tryRead "max solution length")
+ (\i opts -> Ok opts { optMaxLength = i }) "N")
"cap the solution at this many balancing or allocation \
\ rounds (useful for very unbalanced clusters or empty \
\ clusters)"
oMinDisk :: OptType
oMinDisk = Option "" ["min-disk"]
- (ReqArg (\ n opts -> Ok opts { optMdsk = read n }) "RATIO")
+ (reqWithConversion (tryRead "min free disk space")
+ (\n opts -> Ok opts { optMdsk = n }) "RATIO")
"minimum free disk space for nodes (between 0 and 1) [0]"
oMinGain :: OptType
oMinGain = Option "g" ["min-gain"]
- (ReqArg (\ g opts -> Ok opts { optMinGain = read g }) "DELTA")
+ (reqWithConversion (tryRead "min gain")
+ (\g opts -> Ok opts { optMinGain = g }) "DELTA")
"minimum gain to aim for in a balancing step before giving up"
oMinGainLim :: OptType
oMinGainLim = Option "" ["min-gain-limit"]
- (ReqArg (\ g opts -> Ok opts { optMinGainLim = read g }) "SCORE")
+ (reqWithConversion (tryRead "min gain limit")
+ (\g opts -> Ok opts { optMinGainLim = g }) "SCORE")
"minimum cluster score for which we start checking the min-gain"
oMinScore :: OptType
oMinScore = Option "e" ["min-score"]
- (ReqArg (\ e opts -> Ok opts { optMinScore = read e }) "EPSILON")
+ (reqWithConversion (tryRead "min score")
+ (\e opts -> Ok opts { optMinScore = e }) "EPSILON")
"mininum score to aim for"
oNoHeaders :: OptType
@@ -416,16 +422,6 @@ oSaveCluster = Option "S" ["save"]
(ReqArg (\ f opts -> Ok opts { optSaveCluster = Just f }) "FILE")
"Save cluster state at the end of the processing to FILE"
-oShowHelp :: OptType
-oShowHelp = Option "h" ["help"]
- (NoArg (\ opts -> Ok opts { optShowHelp = True}))
- "show help"
-
-oShowVer :: OptType
-oShowVer = Option "V" ["version"]
- (NoArg (\ opts -> Ok opts { optShowVer = True}))
- "show the version of the program"
-
oStdSpec :: OptType
oStdSpec = Option "" ["standard-alloc"]
(ReqArg (\ inp opts -> do
@@ -434,14 +430,6 @@ oStdSpec = Option "" ["standard-alloc"]
"STDSPEC")
"enable standard specs allocation, given as 'disk,ram,cpu'"
-oTestCount :: OptType
-oTestCount = Option "" ["test-count"]
- (ReqArg (\ inp opts -> do
- tcount <- tryRead "parsing test count" inp
- return $ opts { optTestCount = Just tcount } )
- "COUNT")
- "override the target test count"
-
oTieredSpec :: OptType
oTieredSpec = Option "" ["tiered-alloc"]
(ReqArg (\ inp opts -> do
@@ -450,11 +438,6 @@ oTieredSpec = Option "" ["tiered-alloc"]
"TSPEC")
"enable tiered specs allocation, given as 'disk,ram,cpu'"
-oReplay :: OptType
-oReplay = Option "" ["replay"]
- (ReqArg (\ stat opts -> Ok opts { optReplay = Just stat } ) "STATE")
- "Pre-seed the random number generator with STATE"
-
oVerbose :: OptType
oVerbose = Option "v" ["verbose"]
(NoArg (\ opts -> Ok opts { optVerbose = optVerbose opts + 1 }))
@@ -462,64 +445,14 @@ oVerbose = Option "v" ["verbose"]
-- * Functions
--- | Helper for parsing a yes\/no command line flag.
-parseYesNo :: Bool -- ^ Default value (when we get a @Nothing@)
- -> Maybe String -- ^ Parameter value
- -> Result Bool -- ^ Resulting boolean value
-parseYesNo v Nothing = return v
-parseYesNo _ (Just "yes") = return True
-parseYesNo _ (Just "no") = return False
-parseYesNo _ (Just s) = fail ("Invalid choice '" ++ s ++
- "', pass one of 'yes' or 'no'")
-
--- | Usage info.
-usageHelp :: String -> [OptType] -> String
-usageHelp progname =
- usageInfo (printf "%s %s\nUsage: %s [OPTION...]"
- progname Version.version progname)
-
--- | Show the program version info.
-versionInfo :: String -> String
-versionInfo progname =
- printf "%s %s\ncompiled with %s %s\nrunning on %s %s\n"
- progname Version.version compilerName
- (Data.Version.showVersion compilerVersion)
- os arch
-
--- | Command line parser, using the 'Options' structure.
+-- | Wrapper over 'Common.parseOpts' with our custom options.
parseOpts :: [String] -- ^ The command line arguments
-> String -- ^ The program name
-> [OptType] -- ^ The supported command line options
-> IO (Options, [String]) -- ^ The resulting options and leftover
-- arguments
-parseOpts argv progname options =
- case parseOptsInner argv progname options of
- Left (code, msg) -> do
- hPutStr (if code == 0 then stdout else stderr) msg
- exitWith (if code == 0 then ExitSuccess else ExitFailure code)
- Right result ->
- return result
-
--- | Inner parse options. The arguments are similar to 'parseOpts',
--- but it returns either a 'Left' composed of exit code and message,
--- or a 'Right' for the success case.
-parseOptsInner :: [String] -> String -> [OptType]
- -> Either (Int, String) (Options, [String])
-parseOptsInner argv progname options =
- case getOpt Permute options argv of
- (o, n, []) ->
- let (pr, args) = (foldM (flip id) defaultOptions o, n)
- in case pr of
- Bad msg -> Left (1, "Error while parsing command\
- \line arguments:\n" ++ msg ++ "\n")
- Ok po ->
- select (Right (po, args))
- [ (optShowHelp po, Left (0, usageHelp progname options))
- , (optShowVer po, Left (0, versionInfo progname))
- ]
- (_, _, errs) ->
- Left (2, "Command line error: " ++ concat errs ++ "\n" ++
- usageHelp progname options)
+parseOpts = Common.parseOpts defaultOptions
+
-- | A shell script template for autogenerated scripts.
shTemplate :: String
@@ -546,7 +479,6 @@ maybePrintNodes (Just fields) msg fn = do
hPutStrLn stderr (msg ++ " status:")
hPutStrLn stderr $ fn fields
-
-- | Optionally print the instance list.
maybePrintInsts :: Bool -- ^ Whether to print the instance list
-> String -- ^ Type of the instance map (e.g. initial)
@@ -571,13 +503,14 @@ maybeShowWarnings fix_msgs =
printKeys :: String -- ^ Prefix to printed variables
-> [(String, String)] -- ^ List of (key, value) pairs to be printed
-> IO ()
-printKeys prefix = mapM_ (\(k, v) ->
- printf "%s_%s=%s\n" prefix (map toUpper k) (ensureQuoted v))
+printKeys prefix =
+ mapM_ (\(k, v) ->
+ printf "%s_%s=%s\n" prefix (map toUpper k) (ensureQuoted v))
-- | Prints the final @OK@ marker in machine readable output.
printFinal :: String -- ^ Prefix to printed variable
- -> Bool -- ^ Whether output should be machine readable
- -- Note: if not, there is nothing to print
+ -> Bool -- ^ Whether output should be machine readable;
+ -- note: if not, there is nothing to print
-> IO ()
printFinal prefix True =
-- this should be the final entry