| 25 |
25 |
|
| 26 |
26 |
module Main(main) where
|
| 27 |
27 |
|
| 28 |
|
import Data.Char
|
| 29 |
|
import Data.IORef
|
| 30 |
|
import Data.List
|
| 31 |
|
import Data.Maybe (fromMaybe)
|
| 32 |
|
import System.Console.GetOpt ()
|
|
28 |
import Data.Monoid (mappend)
|
|
29 |
import Test.Framework
|
| 33 |
30 |
import System.Environment (getArgs)
|
| 34 |
|
import System.Exit
|
| 35 |
|
import System.IO
|
| 36 |
|
import Test.QuickCheck
|
| 37 |
|
import Text.Printf
|
| 38 |
31 |
|
| 39 |
32 |
import Ganeti.HTools.QC
|
| 40 |
|
import Ganeti.HTools.CLI
|
| 41 |
|
import Ganeti.HTools.Utils (sepSplit)
|
| 42 |
33 |
|
| 43 |
|
-- | Options list and functions.
|
| 44 |
|
options :: [OptType]
|
| 45 |
|
options =
|
| 46 |
|
[ oReplay
|
| 47 |
|
, oVerbose
|
| 48 |
|
, oShowVer
|
| 49 |
|
, oShowHelp
|
| 50 |
|
, oTestCount
|
| 51 |
|
]
|
| 52 |
|
|
| 53 |
|
fast :: Args
|
| 54 |
|
fast = stdArgs
|
| 55 |
|
{ maxSuccess = 500
|
| 56 |
|
, chatty = False
|
|
34 |
-- | Our default test options, overring the built-in test-framework
|
|
35 |
-- ones.
|
|
36 |
fast :: TestOptions
|
|
37 |
fast = TestOptions
|
|
38 |
{ topt_seed = Nothing
|
|
39 |
, topt_maximum_generated_tests = Just 500
|
|
40 |
, topt_maximum_unsuitable_generated_tests = Just 5000
|
|
41 |
, topt_maximum_test_size = Nothing
|
|
42 |
, topt_maximum_test_depth = Nothing
|
|
43 |
, topt_timeout = Nothing
|
| 57 |
44 |
}
|
| 58 |
45 |
|
| 59 |
|
slow :: Args
|
| 60 |
|
slow = stdArgs
|
| 61 |
|
{ maxSuccess = 50
|
| 62 |
|
, chatty = False
|
|
46 |
-- | Our slow test options.
|
|
47 |
slow :: TestOptions
|
|
48 |
slow = fast
|
|
49 |
{ topt_maximum_generated_tests = Just 50
|
|
50 |
, topt_maximum_unsuitable_generated_tests = Just 500
|
| 63 |
51 |
}
|
| 64 |
52 |
|
| 65 |
|
incIORef :: IORef Int -> IO ()
|
| 66 |
|
incIORef ir = atomicModifyIORef ir (\x -> (x + 1, ()))
|
| 67 |
|
|
| 68 |
|
-- | Wrapper over a test runner with error counting.
|
| 69 |
|
wrapTest :: IORef Int
|
| 70 |
|
-> (Args -> IO Result, String)
|
| 71 |
|
-> Args
|
| 72 |
|
-> IO (Result, Char, String)
|
| 73 |
|
wrapTest ir (test, desc) opts = do
|
| 74 |
|
r <- test opts
|
| 75 |
|
c <- case r of
|
| 76 |
|
Success {} -> return '.'
|
| 77 |
|
GaveUp {} -> return '?'
|
| 78 |
|
Failure {} -> incIORef ir >> return '#'
|
| 79 |
|
NoExpectedFailure {} -> incIORef ir >> return '*'
|
| 80 |
|
return (r, c, desc)
|
| 81 |
|
|
| 82 |
|
runTests :: String
|
| 83 |
|
-> Args
|
| 84 |
|
-> [Args -> IO (Result, Char, String)]
|
| 85 |
|
-> Int
|
| 86 |
|
-> IO [(Result, String)]
|
| 87 |
|
|
| 88 |
|
runTests name opts tests max_count = do
|
| 89 |
|
_ <- printf "%25s : " name
|
| 90 |
|
hFlush stdout
|
| 91 |
|
results <- mapM (\t -> do
|
| 92 |
|
(r, c, desc) <- t opts
|
| 93 |
|
putChar c
|
| 94 |
|
hFlush stdout
|
| 95 |
|
return (r, desc)
|
| 96 |
|
) tests
|
| 97 |
|
let alldone = sum . map (numTests . fst) $ results
|
| 98 |
|
_ <- printf "%*s(%d)\n" (max_count - length tests + 1) " " alldone
|
| 99 |
|
mapM_ (\(r, desc) ->
|
| 100 |
|
case r of
|
| 101 |
|
Failure { output = o, usedSeed = u, usedSize = size } ->
|
| 102 |
|
printf "Test %s failed (seed was %s, test size %d): %s\n"
|
| 103 |
|
desc (show u) size o
|
| 104 |
|
GaveUp { numTests = passed } ->
|
| 105 |
|
printf "Test %s incomplete: gave up with only %d\
|
| 106 |
|
\ passes after discarding %d tests\n"
|
| 107 |
|
desc passed (maxDiscard opts)
|
| 108 |
|
_ -> return ()
|
| 109 |
|
) results
|
| 110 |
|
return results
|
| 111 |
|
|
| 112 |
|
allTests :: [(Args, (String, [(Args -> IO Result, String)]))]
|
|
53 |
-- | All our defined tests.
|
|
54 |
allTests :: [(Bool, (String, [Test]))]
|
| 113 |
55 |
allTests =
|
| 114 |
|
[ (fast, testUtils)
|
| 115 |
|
, (fast, testPeerMap)
|
| 116 |
|
, (fast, testContainer)
|
| 117 |
|
, (fast, testInstance)
|
| 118 |
|
, (fast, testNode)
|
| 119 |
|
, (fast, testText)
|
| 120 |
|
, (fast, testSimu)
|
| 121 |
|
, (fast, testOpCodes)
|
| 122 |
|
, (fast, testJobs)
|
| 123 |
|
, (fast, testLoader)
|
| 124 |
|
, (fast, testTypes)
|
| 125 |
|
, (fast, testCLI)
|
| 126 |
|
, (fast, testJSON)
|
| 127 |
|
, (fast, testLUXI)
|
| 128 |
|
, (fast, testSsconf)
|
| 129 |
|
, (fast, testQlang)
|
| 130 |
|
, (slow, testCluster)
|
| 131 |
|
, (fast, testRpc)
|
|
56 |
[ (True, testUtils)
|
|
57 |
, (True, testPeerMap)
|
|
58 |
, (True, testContainer)
|
|
59 |
, (True, testInstance)
|
|
60 |
, (True, testNode)
|
|
61 |
, (True, testText)
|
|
62 |
, (True, testSimu)
|
|
63 |
, (True, testOpCodes)
|
|
64 |
, (True, testJobs)
|
|
65 |
, (True, testLoader)
|
|
66 |
, (True, testTypes)
|
|
67 |
, (True, testCLI)
|
|
68 |
, (True, testJSON)
|
|
69 |
, (True, testLUXI)
|
|
70 |
, (True, testSsconf)
|
|
71 |
, (True, testQlang)
|
|
72 |
, (True, testRpc)
|
|
73 |
, (False, testCluster)
|
| 132 |
74 |
]
|
| 133 |
75 |
|
| 134 |
|
-- | Extracts the name of a test group.
|
| 135 |
|
extractName :: (Args, (String, [(Args -> IO Result, String)])) -> String
|
| 136 |
|
extractName (_, (name, _)) = name
|
| 137 |
|
|
| 138 |
|
-- | Lowercase a string.
|
| 139 |
|
lower :: String -> String
|
| 140 |
|
lower = map toLower
|
| 141 |
|
|
| 142 |
|
transformTestOpts :: Args -> Options -> IO Args
|
| 143 |
|
transformTestOpts args opts = do
|
| 144 |
|
r <- case optReplay opts of
|
| 145 |
|
Nothing -> return Nothing
|
| 146 |
|
Just str -> do
|
| 147 |
|
let vs = sepSplit ',' str
|
| 148 |
|
case vs of
|
| 149 |
|
[rng, size] -> return $ Just (read rng, read size)
|
| 150 |
|
_ -> fail "Invalid state given"
|
| 151 |
|
return args { chatty = optVerbose opts > 1
|
| 152 |
|
, replay = r
|
| 153 |
|
, maxSuccess = fromMaybe (maxSuccess args) (optTestCount opts)
|
| 154 |
|
, maxDiscard = fromMaybe (maxDiscard args) (optTestCount opts)
|
| 155 |
|
}
|
| 156 |
|
|
|
76 |
-- | Slow a test's max tests, if provided as such.
|
|
77 |
makeSlowOrFast :: Bool -> TestOptions -> TestOptions
|
|
78 |
makeSlowOrFast is_fast opts =
|
|
79 |
let template = if is_fast then fast else slow
|
|
80 |
fn_val v = if is_fast then v else v `div` 10
|
|
81 |
in case topt_maximum_generated_tests opts of
|
|
82 |
-- user didn't override the max_tests, so we'll do it here
|
|
83 |
Nothing -> opts `mappend` template
|
|
84 |
-- user did override, so we ignore the template and just directly
|
|
85 |
-- decrease the max_tests, if needed
|
|
86 |
Just max_tests -> opts { topt_maximum_generated_tests =
|
|
87 |
Just (fn_val max_tests)
|
|
88 |
}
|
|
89 |
|
|
90 |
-- | Main function. Note we don't use defaultMain since we want to
|
|
91 |
-- control explicitly our test sizes (and override the default).
|
| 157 |
92 |
main :: IO ()
|
| 158 |
93 |
main = do
|
| 159 |
|
errs <- newIORef 0
|
| 160 |
|
let wrap = map (wrapTest errs)
|
| 161 |
|
cmd_args <- getArgs
|
| 162 |
|
(opts, args) <- parseOpts cmd_args "test" options
|
| 163 |
|
tests <- if null args
|
| 164 |
|
then return allTests
|
| 165 |
|
else let args' = map lower args
|
| 166 |
|
selected = filter ((`elem` args') . lower .
|
| 167 |
|
extractName) allTests
|
| 168 |
|
in if null selected
|
| 169 |
|
then do
|
| 170 |
|
hPutStrLn stderr $ "No tests matching '"
|
| 171 |
|
++ unwords args ++ "', available tests: "
|
| 172 |
|
++ intercalate ", " (map extractName allTests)
|
| 173 |
|
exitWith $ ExitFailure 1
|
| 174 |
|
else return selected
|
| 175 |
|
|
| 176 |
|
let max_count = maximum $ map (\(_, (_, t)) -> length t) tests
|
| 177 |
|
mapM_ (\(targs, (name, tl)) ->
|
| 178 |
|
transformTestOpts targs opts >>= \newargs ->
|
| 179 |
|
runTests name newargs (wrap tl) max_count) tests
|
| 180 |
|
terr <- readIORef errs
|
| 181 |
|
if terr > 0
|
| 182 |
|
then do
|
| 183 |
|
hPutStrLn stderr $ "A total of " ++ show terr ++ " tests failed."
|
| 184 |
|
exitWith $ ExitFailure 1
|
| 185 |
|
else putStrLn "All tests succeeded."
|
|
94 |
ropts <- getArgs >>= interpretArgsOrExit
|
|
95 |
-- note: we do this overriding here since we need some groups to
|
|
96 |
-- have a smaller test count; so in effect we're basically
|
|
97 |
-- overriding t-f's inheritance here, but only for max_tests
|
|
98 |
let (act_fast, act_slow) =
|
|
99 |
case ropt_test_options ropts of
|
|
100 |
Nothing -> (fast, slow)
|
|
101 |
Just topts -> (makeSlowOrFast True topts, makeSlowOrFast False topts)
|
|
102 |
actual_opts is_fast = if is_fast then act_fast else act_slow
|
|
103 |
let tests = map (\(is_fast, (group_name, group_tests)) ->
|
|
104 |
plusTestOptions (actual_opts is_fast) $
|
|
105 |
testGroup group_name group_tests) allTests
|
|
106 |
defaultMainWithOpts tests ropts
|