Commit 8e4f6d56 authored by Iustin Pop's avatar Iustin Pop

htools: Switch to QuickCheck 2.x

Since current distros don't package anymore QuickCheck 1.x, let's move
to 2.x.

This requires also a few changes to the code:

- Test.QuickCheck.Batch doesn't exist anymore, so we need to write some
  scaffolding code to replace it
- the way test sizes are generated has changed, and we need to restrict
  (in some tests) the cluster size, as our code is not yet ready for
  hundreds of thousands of nodes in a cluster and we run out of stack
  (which could be a bug somewhere by itself, needs investigation)
- at least with GHC 7, floating point errors make a perfect cluster
  score even bigger, so we need to bump up the max. rounding error
  allowed
Signed-off-by: default avatarIustin Pop <iustin@google.com>
Reviewed-by: default avatarGuido Trotter <ultrotter@google.com>
parent cc532bdd
......@@ -376,8 +376,8 @@ else
AC_MSG_CHECKING([network])
GHC_PKG_NETWORK=$($GHC_PKG latest network)
AC_MSG_RESULT($GHC_PKG_NETWORK)
AC_MSG_CHECKING([QuickCheck 1.x])
GHC_PKG_QUICKCHECK=$($GHC_PKG --simple-output list 'QuickCheck-1.*')
AC_MSG_CHECKING([QuickCheck 2.x])
GHC_PKG_QUICKCHECK=$($GHC_PKG --simple-output list 'QuickCheck-2.*')
AC_MSG_RESULT($GHC_PKG_QUICKCHECK)
if test -z "$GHC_PKG_PARALLEL" || test -z "$GHC_PKG_JSON" || \
test -z "$GHC_PKG_NETWORK"; then
......@@ -390,7 +390,7 @@ else
HTOOLS_MODULES="-package $GHC_PKG_PARALLEL"
fi
if test -z "$GHC_PKG_QUICKCHECK"; then
AC_MSG_WARN(m4_normalize([The QuickCheck 1.x module was not found,
AC_MSG_WARN(m4_normalize([The QuickCheck 2.x module was not found,
you won't be able to run Haskell unittests]))
fi
fi
......
......@@ -37,7 +37,7 @@ document, plus:
- `hlint <http://community.haskell.org/~ndm/hlint/>`_, a source code
linter (equivalent to pylint for Python)
- the `QuickCheck <http://hackage.haskell.org/package/QuickCheck>`_
library, version 1.x
library, version 2.x
- ``hpc``, which comes with the compiler, so you should already have
it
......
......@@ -37,7 +37,6 @@ module Ganeti.HTools.QC
) where
import Test.QuickCheck
import Test.QuickCheck.Batch
import Data.List (findIndex, intercalate, nub, isPrefixOf)
import Data.Maybe
import Control.Monad
......@@ -66,6 +65,9 @@ import qualified Ganeti.HTools.Utils as Utils
import qualified Ganeti.HTools.Version
import qualified Ganeti.Constants as C
run :: Testable prop => prop -> Args -> IO Result
run = flip quickCheckWithResult
-- * Constants
-- | Maximum memory (1TiB, somewhat random value)
......@@ -147,10 +149,6 @@ assignInstance nl il inst pdx sdx =
-- * Arbitrary instances
-- copied from the introduction to quickcheck
instance Arbitrary Char where
arbitrary = choose ('\32', '\128')
newtype DNSChar = DNSChar { dnsGetChar::Char }
instance Arbitrary DNSChar where
arbitrary = do
......@@ -500,8 +498,8 @@ prop_Text_Load_Instance name mem dsk vcpus status pnode snode pdx sdx autobal =
prop_Text_Load_InstanceFail ktn fields =
length fields /= 9 ==>
case Text.loadInst nl fields of
Right _ -> False
Left msg -> isPrefixOf "Invalid/incomplete instance data: '" msg
Types.Ok _ -> False
Types.Bad msg -> "Invalid/incomplete instance data: '" `isPrefixOf` msg
where nl = Data.Map.fromList ktn
prop_Text_Load_Node name tm nm fm td fd tc fo =
......@@ -703,7 +701,8 @@ testNode =
-- Cluster tests
-- | Check that the cluster score is close to zero for a homogeneous cluster
prop_Score_Zero node count =
prop_Score_Zero node =
forAll (choose (1, 1024)) $ \count ->
(not (Node.offline node) && not (Node.failN1 node) && (count > 0) &&
(Node.tDsk node > 0) && (Node.tMem node > 0)) ==>
let fn = Node.buildPeers node Container.empty
......@@ -712,11 +711,12 @@ prop_Score_Zero node count =
score = Cluster.compCV nl
-- we can't say == 0 here as the floating point errors accumulate;
-- this should be much lower than the default score in CLI.hs
in score <= 1e-15
in score <= 1e-12
-- | Check that cluster stats are sane
prop_CStats_sane node count =
(not (Node.offline node) && not (Node.failN1 node) && (count > 0) &&
prop_CStats_sane node =
forAll (choose (1, 1024)) $ \count ->
(not (Node.offline node) && not (Node.failN1 node) &&
(Node.availDisk node > 0) && (Node.availMem node > 0)) ==>
let fn = Node.buildPeers node Container.empty
nlst = zip [1..] $ replicate count fn::[(Types.Ndx, Node.Node)]
......
......@@ -4,7 +4,7 @@
{-
Copyright (C) 2009 Google Inc.
Copyright (C) 2009, 2011 Google Inc.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
......@@ -26,43 +26,68 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
module Main(main) where
import Data.IORef
import Test.QuickCheck.Batch
import Test.QuickCheck
import System.IO
import System.Exit
import System (getArgs)
import Text.Printf
import Ganeti.HTools.QC
fast :: TestOptions
fast = TestOptions
{ no_of_tests = 500
, length_of_tests = 10
, debug_tests = False }
fast :: Args
fast = stdArgs
{ maxSuccess = 500
, chatty = False
}
slow :: TestOptions
slow = TestOptions
{ no_of_tests = 50
, length_of_tests = 100
, debug_tests = False }
slow :: Args
slow = stdArgs
{ maxSuccess = 50
, chatty = False
}
incIORef :: IORef Int -> IO ()
incIORef ir = atomicModifyIORef ir (\x -> (x + 1, ()))
-- | Wrapper over a test runner with error counting
wrapTest :: IORef Int
-> (TestOptions -> IO TestResult)
-> TestOptions -> IO TestResult
wrapTest ir t to = do
tr <- t to
case tr of
TestFailed _ _ -> incIORef ir
TestAborted e -> do
incIORef ir
putStrLn ("Failure during test: <" ++ show e ++ ">")
_ -> return ()
return tr
allTests :: [(String, TestOptions, [TestOptions -> IO TestResult])]
-> (Args -> IO Result)
-> Args
-> IO (Result, Char)
wrapTest ir test opts = do
r <- test opts
c <- case r of
Success {} -> return '.'
GaveUp {} -> return '?'
Failure {} -> incIORef ir >> return '#'
NoExpectedFailure {} -> incIORef ir >> return '*'
return (r, c)
runTests name opts tests max_count = do
_ <- printf "%25s : " name
hFlush stdout
results <- mapM (\t -> do
(r, c) <- t opts
putChar c
hFlush stdout
return r
) tests
let alldone = sum . map numTests $ results
_ <- printf "%*s(%d)\n" (max_count - length tests + 1) " " alldone
mapM_ (\(idx, r) ->
case r of
Failure { output = o, usedSeed = u, usedSize = size } ->
printf "Test %d failed (seed was %s, test size %d): %s\n"
idx (show u) size o
GaveUp { numTests = passed } ->
printf "Test %d incomplete: gave up with only %d\
\ passes after discarding %d tests\n"
idx passed (maxDiscard opts)
_ -> return ()
) $ zip ([1..]::[Int]) results
return results
allTests :: [(String, Args, [Args -> IO Result])]
allTests =
[ ("Utils", fast, testUtils)
, ("PeerMap", fast, testPeerMap)
......@@ -84,7 +109,8 @@ main = do
let tests = if null args
then allTests
else filter (\(name, _, _) -> name `elem` args) allTests
mapM_ (\(name, opts, tl) -> runTests name opts (wrap tl)) tests
max_count = maximum $ map (\(_, _, t) -> length t) tests
mapM_ (\(name, opts, tl) -> runTests name opts (wrap tl) max_count) tests
terr <- readIORef errs
(if terr > 0
then do
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment