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