X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/3c002a132853bc4fa3fa5c434a37d906c6e394c2..8a65c02b3963cadb22d0d7ec67e769e5ac8b2e17:/htools/test.hs diff --git a/htools/test.hs b/htools/test.hs index d46d22a..3aecfa6 100644 --- a/htools/test.hs +++ b/htools/test.hs @@ -4,7 +4,7 @@ {- -Copyright (C) 2009, 2011 Google Inc. +Copyright (C) 2009, 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 @@ -25,124 +25,84 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA module Main(main) where -import Data.IORef -import Test.QuickCheck -import System.Console.GetOpt -import System.IO -import System.Exit -import System (getArgs) -import Text.Printf +import Data.Monoid (mappend) +import Test.Framework +import System.Environment (getArgs) import Ganeti.HTools.QC -import Ganeti.HTools.CLI -import Ganeti.HTools.Utils (sepSplit) --- | Options list and functions -options :: [OptType] -options = - [ oReplay - , oVerbose - , oShowVer - , oShowHelp - ] - -fast :: Args -fast = stdArgs - { maxSuccess = 500 - , chatty = False +-- | Our default test options, overring the built-in test-framework +-- ones. +fast :: TestOptions +fast = TestOptions + { topt_seed = Nothing + , topt_maximum_generated_tests = Just 500 + , topt_maximum_unsuitable_generated_tests = Just 5000 + , topt_maximum_test_size = Nothing + , topt_maximum_test_depth = Nothing + , topt_timeout = Nothing } -slow :: Args -slow = stdArgs - { maxSuccess = 50 - , chatty = False +-- | Our slow test options. +slow :: TestOptions +slow = fast + { topt_maximum_generated_tests = Just 50 + , topt_maximum_unsuitable_generated_tests = Just 500 } -incIORef :: IORef Int -> IO () -incIORef ir = atomicModifyIORef ir (\x -> (x + 1, ())) - --- | Wrapper over a test runner with error counting -wrapTest :: IORef Int - -> (Args -> IO Result) - -> Args - -> IO (Result, Char) -wrapTest ir test opts = do - r <- test opts - c <- case r of - Success {} -> return '.' - GaveUp {} -> return '?' - Failure {} -> incIORef ir >> return '#' - NoExpectedFailure {} -> incIORef ir >> return '*' - return (r, c) - -runTests name opts tests max_count = do - _ <- printf "%25s : " name - hFlush stdout - results <- mapM (\t -> do - (r, c) <- t opts - putChar c - hFlush stdout - return r - ) tests - let alldone = sum . map numTests $ results - _ <- printf "%*s(%d)\n" (max_count - length tests + 1) " " alldone - mapM_ (\(idx, r) -> - case r of - Failure { output = o, usedSeed = u, usedSize = size } -> - printf "Test %d failed (seed was %s, test size %d): %s\n" - idx (show u) size o - GaveUp { numTests = passed } -> - printf "Test %d incomplete: gave up with only %d\ - \ passes after discarding %d tests\n" - idx passed (maxDiscard opts) - _ -> return () - ) $ zip ([1..]::[Int]) results - return results - -allTests :: [(String, Args, [Args -> IO Result])] +-- | All our defined tests. +allTests :: [(Bool, (String, [Test]))] allTests = - [ ("Utils", fast, testUtils) - , ("PeerMap", fast, testPeerMap) - , ("Container", fast, testContainer) - , ("Instance", fast, testInstance) - , ("Node", fast, testNode) - , ("Text", fast, testText) - , ("OpCodes", fast, testOpCodes) - , ("Jobs", fast, testJobs) - , ("Loader", fast, testLoader) - , ("Types", fast, testTypes) - , ("Cluster", slow, testCluster) + [ (True, testUtils) + , (True, testPeerMap) + , (True, testContainer) + , (True, testInstance) + , (True, testNode) + , (True, testText) + , (True, testSimu) + , (True, testOpCodes) + , (True, testJobs) + , (True, testLoader) + , (True, testTypes) + , (True, testCLI) + , (True, testJSON) + , (True, testLuxi) + , (True, testSsconf) + , (True, testQlang) + , (True, testRpc) + , (True, testConfd) + , (True, testObjects) + , (False, testCluster) ] -transformTestOpts :: Args -> Options -> IO Args -transformTestOpts args opts = do - r <- case optReplay opts of - Nothing -> return Nothing - Just str -> do - let vs = sepSplit ',' str - (case vs of - [rng, size] -> return $ Just (read rng, read size) - _ -> fail "Invalid state given") - return args { chatty = optVerbose opts > 1, - replay = r - } - +-- | Slow a test's max tests, if provided as such. +makeSlowOrFast :: Bool -> TestOptions -> TestOptions +makeSlowOrFast is_fast opts = + let template = if is_fast then fast else slow + fn_val v = if is_fast then v else v `div` 10 + in case topt_maximum_generated_tests opts of + -- user didn't override the max_tests, so we'll do it here + Nothing -> opts `mappend` template + -- user did override, so we ignore the template and just directly + -- decrease the max_tests, if needed + Just max_tests -> opts { topt_maximum_generated_tests = + Just (fn_val max_tests) + } + +-- | Main function. Note we don't use defaultMain since we want to +-- control explicitly our test sizes (and override the default). main :: IO () main = do - errs <- newIORef 0 - let wrap = map (wrapTest errs) - cmd_args <- System.getArgs - (opts, args) <- parseOpts cmd_args "test" options - let tests = if null args - then allTests - else filter (\(name, _, _) -> name `elem` args) allTests - max_count = maximum $ map (\(_, _, t) -> length t) tests - mapM_ (\(name, targs, tl) -> - transformTestOpts targs opts >>= \newargs -> - runTests name newargs (wrap tl) max_count) tests - terr <- readIORef errs - (if terr > 0 - then do - hPutStrLn stderr $ "A total of " ++ show terr ++ " tests failed." - exitWith $ ExitFailure 1 - else putStrLn "All tests succeeded.") + ropts <- getArgs >>= interpretArgsOrExit + -- note: we do this overriding here since we need some groups to + -- have a smaller test count; so in effect we're basically + -- overriding t-f's inheritance here, but only for max_tests + let (act_fast, act_slow) = + case ropt_test_options ropts of + Nothing -> (fast, slow) + Just topts -> (makeSlowOrFast True topts, makeSlowOrFast False topts) + actual_opts is_fast = if is_fast then act_fast else act_slow + let tests = map (\(is_fast, (group_name, group_tests)) -> + plusTestOptions (actual_opts is_fast) $ + testGroup group_name group_tests) allTests + defaultMainWithOpts tests ropts