code.grnet.gr Git - ganeti-local/blob - htools/test.hs

   1 {-| Unittest runner for ganeti-htools.
   2
   3 -}
   4
   5 {-
   6
   7 Copyright (C) 2009, 2011, 2012 Google Inc.
   8
   9 This program is free software; you can redistribute it and/or modify
  10 it under the terms of the GNU General Public License as published by
  11 the Free Software Foundation; either version 2 of the License, or
  12 (at your option) any later version.
  13
  14 This program is distributed in the hope that it will be useful, but
  15 WITHOUT ANY WARRANTY; without even the implied warranty of
  16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 General Public License for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with this program; if not, write to the Free Software
  21 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  22 02110-1301, USA.
  23
  24 -}
  25
  26 module Main(main) where
  27
  28 import Data.Char
  29 import Data.IORef
  30 import Data.List
  31 import Data.Maybe (fromMaybe)
  32 import System.Console.GetOpt ()
  33 import System.Environment (getArgs)
  34 import System.Exit
  35 import System.IO
  36 import Test.QuickCheck
  37 import Text.Printf
  38
  39 import Ganeti.HTools.QC
  40 import Ganeti.HTools.CLI
  41 import Ganeti.HTools.Utils (sepSplit)
  42
  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
  57        }
  58
  59 slow :: Args
  60 slow = stdArgs
  61        { maxSuccess = 50
  62        , chatty     = False
  63        }
  64
  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)]))]
 113 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   , (slow, testCluster)
 130   ]
 131
 132 -- | Extracts the name of a test group.
 133 extractName :: (Args, (String, [(Args -> IO Result, String)])) -> String
 134 extractName (_, (name, _)) = name
 135
 136 -- | Lowercase a string.
 137 lower :: String -> String
 138 lower = map toLower
 139
 140 transformTestOpts :: Args -> Options -> IO Args
 141 transformTestOpts args opts = do
 142   r <- case optReplay opts of
 143          Nothing -> return Nothing
 144          Just str -> do
 145            let vs = sepSplit ',' str
 146            case vs of
 147              [rng, size] -> return $ Just (read rng, read size)
 148              _ -> fail "Invalid state given"
 149   return args { chatty = optVerbose opts > 1
 150               , replay = r
 151               , maxSuccess = fromMaybe (maxSuccess args) (optTestCount opts)
 152               , maxDiscard = fromMaybe (maxDiscard args) (optTestCount opts)
 153               }
 154
 155 main :: IO ()
 156 main = do
 157   errs <- newIORef 0
 158   let wrap = map (wrapTest errs)
 159   cmd_args <- getArgs
 160   (opts, args) <- parseOpts cmd_args "test" options
 161   tests <- if null args
 162              then return allTests
 163              else let args' = map lower args
 164                       selected = filter ((`elem` args') . lower .
 165                                          extractName) allTests
 166                   in if null selected
 167                        then do
 168                          hPutStrLn stderr $ "No tests matching '"
 169                             ++ unwords args ++ "', available tests: "
 170                             ++ intercalate ", " (map extractName allTests)
 171                          exitWith $ ExitFailure 1
 172                        else return selected
 173
 174   let max_count = maximum $ map (\(_, (_, t)) -> length t) tests
 175   mapM_ (\(targs, (name, tl)) ->
 176            transformTestOpts targs opts >>= \newargs ->
 177            runTests name newargs (wrap tl) max_count) tests
 178   terr <- readIORef errs
 179   if terr > 0
 180     then do
 181       hPutStrLn stderr $ "A total of " ++ show terr ++ " tests failed."
 182       exitWith $ ExitFailure 1
 183     else putStrLn "All tests succeeded."