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   , (slow, testCluster)
 129   ]
 130
 131 -- | Extracts the name of a test group.
 132 extractName :: (Args, (String, [(Args -> IO Result, String)])) -> String
 133 extractName (_, (name, _)) = name
 134
 135 -- | Lowercase a string.
 136 lower :: String -> String
 137 lower = map toLower
 138
 139 transformTestOpts :: Args -> Options -> IO Args
 140 transformTestOpts args opts = do
 141   r <- case optReplay opts of
 142          Nothing -> return Nothing
 143          Just str -> do
 144            let vs = sepSplit ',' str
 145            case vs of
 146              [rng, size] -> return $ Just (read rng, read size)
 147              _ -> fail "Invalid state given"
 148   return args { chatty = optVerbose opts > 1
 149               , replay = r
 150               , maxSuccess = fromMaybe (maxSuccess args) (optTestCount opts)
 151               , maxDiscard = fromMaybe (maxDiscard args) (optTestCount opts)
 152               }
 153
 154 main :: IO ()
 155 main = do
 156   errs <- newIORef 0
 157   let wrap = map (wrapTest errs)
 158   cmd_args <- getArgs
 159   (opts, args) <- parseOpts cmd_args "test" options
 160   tests <- if null args
 161              then return allTests
 162              else let args' = map lower args
 163                       selected = filter ((`elem` args') . lower .
 164                                          extractName) allTests
 165                   in if null selected
 166                        then do
 167                          hPutStrLn stderr $ "No tests matching '"
 168                             ++ unwords args ++ "', available tests: "
 169                             ++ intercalate ", " (map extractName allTests)
 170                          exitWith $ ExitFailure 1
 171                        else return selected
 172
 173   let max_count = maximum $ map (\(_, (_, t)) -> length t) tests
 174   mapM_ (\(targs, (name, tl)) ->
 175            transformTestOpts targs opts >>= \newargs ->
 176            runTests name newargs (wrap tl) max_count) tests
 177   terr <- readIORef errs
 178   if terr > 0
 179     then do
 180       hPutStrLn stderr $ "A total of " ++ show terr ++ " tests failed."
 181       exitWith $ ExitFailure 1
 182     else putStrLn "All tests succeeded."