X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/3c002a132853bc4fa3fa5c434a37d906c6e394c2..43c16a8a1adfd543751fcaf60ad4c8e04cf83688:/htools/test.hs diff --git a/htools/test.hs b/htools/test.hs index d46d22a..eedefd3 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,26 +25,30 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA module Main(main) where +import Data.Char import Data.IORef -import Test.QuickCheck -import System.Console.GetOpt -import System.IO +import Data.List +import Data.Maybe (fromMaybe) +import System.Console.GetOpt () +import System.Environment (getArgs) import System.Exit -import System (getArgs) +import System.IO +import Test.QuickCheck import Text.Printf import Ganeti.HTools.QC import Ganeti.HTools.CLI import Ganeti.HTools.Utils (sepSplit) --- | Options list and functions +-- | Options list and functions. options :: [OptType] options = - [ oReplay - , oVerbose - , oShowVer - , oShowHelp - ] + [ oReplay + , oVerbose + , oShowVer + , oShowHelp + , oTestCount + ] fast :: Args fast = stdArgs @@ -61,88 +65,118 @@ slow = stdArgs incIORef :: IORef Int -> IO () incIORef ir = atomicModifyIORef ir (\x -> (x + 1, ())) --- | Wrapper over a test runner with error counting +-- | Wrapper over a test runner with error counting. wrapTest :: IORef Int - -> (Args -> IO Result) + -> (Args -> IO Result, String) -> Args - -> IO (Result, Char) -wrapTest ir test opts = do + -> IO (Result, Char, String) +wrapTest ir (test, desc) opts = do r <- test opts c <- case r of Success {} -> return '.' GaveUp {} -> return '?' Failure {} -> incIORef ir >> return '#' NoExpectedFailure {} -> incIORef ir >> return '*' - return (r, c) + return (r, c, desc) + +runTests :: String + -> Args + -> [Args -> IO (Result, Char, String)] + -> Int + -> IO [(Result, String)] runTests name opts tests max_count = do _ <- printf "%25s : " name hFlush stdout results <- mapM (\t -> do - (r, c) <- t opts + (r, c, desc) <- t opts putChar c hFlush stdout - return r + return (r, desc) ) tests - let alldone = sum . map numTests $ results + let alldone = sum . map (numTests . fst) $ results _ <- printf "%*s(%d)\n" (max_count - length tests + 1) " " alldone - mapM_ (\(idx, r) -> + mapM_ (\(r, desc) -> 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 + printf "Test %s failed (seed was %s, test size %d): %s\n" + desc (show u) size o GaveUp { numTests = passed } -> - printf "Test %d incomplete: gave up with only %d\ + printf "Test %s incomplete: gave up with only %d\ \ passes after discarding %d tests\n" - idx passed (maxDiscard opts) + desc passed (maxDiscard opts) _ -> return () - ) $ zip ([1..]::[Int]) results + ) results return results -allTests :: [(String, Args, [Args -> IO Result])] +allTests :: [(Args, (String, [(Args -> IO Result, String)]))] 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) + [ (fast, testUtils) + , (fast, testPeerMap) + , (fast, testContainer) + , (fast, testInstance) + , (fast, testNode) + , (fast, testText) + , (fast, testSimu) + , (fast, testOpCodes) + , (fast, testJobs) + , (fast, testLoader) + , (fast, testTypes) + , (fast, testCLI) + , (fast, testJSON) + , (fast, testLUXI) + , (slow, testCluster) ] +-- | Extracts the name of a test group. +extractName :: (Args, (String, [(Args -> IO Result, String)])) -> String +extractName (_, (name, _)) = name + +-- | Lowercase a string. +lower :: String -> String +lower = map toLower + 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 + case vs of + [rng, size] -> return $ Just (read rng, read size) + _ -> fail "Invalid state given" + return args { chatty = optVerbose opts > 1 + , replay = r + , maxSuccess = fromMaybe (maxSuccess args) (optTestCount opts) + , maxDiscard = fromMaybe (maxDiscard args) (optTestCount opts) } main :: IO () main = do errs <- newIORef 0 let wrap = map (wrapTest errs) - cmd_args <- System.getArgs + cmd_args <- 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 + tests <- if null args + then return allTests + else let args' = map lower args + selected = filter ((`elem` args') . lower . + extractName) allTests + in if null selected + then do + hPutStrLn stderr $ "No tests matching '" + ++ unwords args ++ "', available tests: " + ++ intercalate ", " (map extractName allTests) + exitWith $ ExitFailure 1 + else return selected + + let max_count = maximum $ map (\(_, (_, t)) -> length t) tests + mapM_ (\(targs, (name, 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.") + if terr > 0 + then do + hPutStrLn stderr $ "A total of " ++ show terr ++ " tests failed." + exitWith $ ExitFailure 1 + else putStrLn "All tests succeeded."