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