Statistics
| Branch: | Tag: | Revision:

root / htools / test.hs @ aa3adf35

History | View | Annotate | Download (5.3 kB)

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."