diff --git a/htools/Ganeti/HTools/QC.hs b/htools/Ganeti/HTools/QC.hs index 8f16e9f52df134013995a06ad7dea55ee4a5a8f5..53fd48b47abdff049b5af9aaf1a278704088df6b 100644 --- a/htools/Ganeti/HTools/QC.hs +++ b/htools/Ganeti/HTools/QC.hs @@ -107,6 +107,13 @@ isFailure :: Types.OpResult a -> Bool isFailure (Types.OpFail _) = True isFailure _ = False +-- | Checks for equality with proper annotation. +(==?) :: (Show a, Eq a) => a -> a -> Property +(==?) x y = printTestCase + ("Expected equality, but '" ++ + show x ++ "' /= '" ++ show y ++ "'") (x == y) +infix 3 ==? + -- | Update an instance to be smaller than a node. setInstanceSmallerThanNode node inst = inst { Instance.mem = Node.availMem node `div` 2 @@ -300,10 +307,11 @@ instance Arbitrary a => Arbitrary (Types.OpResult a) where prop_Utils_commaJoinSplit = forAll (arbitrary `suchThat` (\l -> l /= [""] && all (not . elem ',') l )) $ \lst -> - Utils.sepSplit ',' (Utils.commaJoin lst) == lst + Utils.sepSplit ',' (Utils.commaJoin lst) ==? lst -- | Split and join should always be idempotent. -prop_Utils_commaSplitJoin s = Utils.commaJoin (Utils.sepSplit ',' s) == s +prop_Utils_commaSplitJoin s = + Utils.commaJoin (Utils.sepSplit ',' s) ==? s -- | fromObjWithDefault, we test using the Maybe monad and an integer -- value. @@ -316,37 +324,38 @@ prop_Utils_fromObjWithDefault def_value random_key = where _types = def_value :: Integer -- | Test that functional if' behaves like the syntactic sugar if. -prop_Utils_if'if :: Bool -> Int -> Int -> Bool -prop_Utils_if'if cnd a b = Utils.if' cnd a b == if cnd then a else b +prop_Utils_if'if :: Bool -> Int -> Int -> Gen Prop +prop_Utils_if'if cnd a b = + Utils.if' cnd a b ==? if cnd then a else b -- | Test basic select functionality -prop_Utils_select :: Int -- ^ Default result - -> [Int] -- ^ List of False values - -> [Int] -- ^ List of True values - -> Bool -- ^ Test result +prop_Utils_select :: Int -- ^ Default result + -> [Int] -- ^ List of False values + -> [Int] -- ^ List of True values + -> Gen Prop -- ^ Test result prop_Utils_select def lst1 lst2 = - Utils.select def cndlist == expectedresult + Utils.select def cndlist ==? expectedresult where expectedresult = Utils.if' (null lst2) def (head lst2) flist = map (\e -> (False, e)) lst1 tlist = map (\e -> (True, e)) lst2 cndlist = flist ++ tlist -- | Test basic select functionality with undefined default -prop_Utils_select_undefd :: [Int] -- ^ List of False values +prop_Utils_select_undefd :: [Int] -- ^ List of False values -> NonEmptyList Int -- ^ List of True values - -> Bool -- ^ Test result + -> Gen Prop -- ^ Test result prop_Utils_select_undefd lst1 (NonEmpty lst2) = - Utils.select undefined cndlist == head lst2 + Utils.select undefined cndlist ==? head lst2 where flist = map (\e -> (False, e)) lst1 tlist = map (\e -> (True, e)) lst2 cndlist = flist ++ tlist -- | Test basic select functionality with undefined list values -prop_Utils_select_undefv :: [Int] -- ^ List of False values +prop_Utils_select_undefv :: [Int] -- ^ List of False values -> NonEmptyList Int -- ^ List of True values - -> Bool -- ^ Test result + -> Gen Prop -- ^ Test result prop_Utils_select_undefv lst1 (NonEmpty lst2) = - Utils.select undefined cndlist == head lst2 + Utils.select undefined cndlist ==? head lst2 where flist = map (\e -> (False, e)) lst1 tlist = map (\e -> (True, e)) lst2 cndlist = flist ++ tlist ++ [undefined] @@ -380,7 +389,7 @@ testSuite "Utils" -- | Make sure add is idempotent. prop_PeerMap_addIdempotent pmap key em = - fn puniq == fn (fn puniq) + fn puniq ==? fn (fn puniq) where _types = (pmap::PeerMap.PeerMap, key::PeerMap.Key, em::PeerMap.Elem) fn = PeerMap.add key em @@ -388,28 +397,28 @@ prop_PeerMap_addIdempotent pmap key em = -- | Make sure remove is idempotent. prop_PeerMap_removeIdempotent pmap key = - fn puniq == fn (fn puniq) + fn puniq ==? fn (fn puniq) where _types = (pmap::PeerMap.PeerMap, key::PeerMap.Key) fn = PeerMap.remove key puniq = PeerMap.accumArray const pmap -- | Make sure a missing item returns 0. prop_PeerMap_findMissing pmap key = - PeerMap.find key (PeerMap.remove key puniq) == 0 + PeerMap.find key (PeerMap.remove key puniq) ==? 0 where _types = (pmap::PeerMap.PeerMap, key::PeerMap.Key) puniq = PeerMap.accumArray const pmap -- | Make sure an added item is found. prop_PeerMap_addFind pmap key em = - PeerMap.find key (PeerMap.add key em puniq) == em + PeerMap.find key (PeerMap.add key em puniq) ==? em where _types = (pmap::PeerMap.PeerMap, key::PeerMap.Key, em::PeerMap.Elem) puniq = PeerMap.accumArray const pmap -- | Manual check that maxElem returns the maximum indeed, or 0 for null. prop_PeerMap_maxElem pmap = - PeerMap.maxElem puniq == if null puniq then 0 - else (maximum . snd . unzip) puniq + PeerMap.maxElem puniq ==? if null puniq then 0 + else (maximum . snd . unzip) puniq where _types = pmap::PeerMap.PeerMap puniq = PeerMap.accumArray const pmap @@ -435,7 +444,7 @@ prop_Container_addTwo cdata i1 i2 = prop_Container_nameOf node = let nl = makeSmallCluster node 1 fnode = head (Container.elems nl) - in Container.nameOf nl (Node.idx fnode) == Node.name fnode + in Container.nameOf nl (Node.idx fnode) ==? Node.name fnode -- | We test that in a cluster, given a random node, we can find it by -- its name and alias, as long as all names and aliases are unique, @@ -470,10 +479,10 @@ testSuite "Container" -- Simple instance tests, we only have setter/getters prop_Instance_creat inst = - Instance.name inst == Instance.alias inst + Instance.name inst ==? Instance.alias inst prop_Instance_setIdx inst idx = - Instance.idx (Instance.setIdx inst idx) == idx + Instance.idx (Instance.setIdx inst idx) ==? idx where _types = (inst::Instance.Instance, idx::Types.Idx) prop_Instance_setName inst name = @@ -489,11 +498,11 @@ prop_Instance_setAlias inst name = newinst = Instance.setAlias inst name prop_Instance_setPri inst pdx = - Instance.pNode (Instance.setPri inst pdx) == pdx + Instance.pNode (Instance.setPri inst pdx) ==? pdx where _types = (inst::Instance.Instance, pdx::Types.Ndx) prop_Instance_setSec inst sdx = - Instance.sNode (Instance.setSec inst sdx) == sdx + Instance.sNode (Instance.setSec inst sdx) ==? sdx where _types = (inst::Instance.Instance, sdx::Types.Ndx) prop_Instance_setBoth inst pdx sdx = @@ -549,7 +558,7 @@ prop_Instance_shrinkDF inst = in Types.isBad $ Instance.shrinkByType inst' Types.FailDisk prop_Instance_setMovable inst m = - Instance.movable inst' == m + Instance.movable inst' ==? m where inst' = Instance.setMovable inst m testSuite "Instance" @@ -681,15 +690,15 @@ prop_Node_setAlias node name = newnode = Node.setAlias node name prop_Node_setOffline node status = - Node.offline newnode == status + Node.offline newnode ==? status where newnode = Node.setOffline node status prop_Node_setXmem node xm = - Node.xMem newnode == xm + Node.xMem newnode ==? xm where newnode = Node.setXmem node xm prop_Node_setMcpu node mc = - Node.mCpu newnode == mc + Node.mCpu newnode ==? mc where newnode = Node.setMcpu node mc -- | Check that an instance add with too high memory or disk will be @@ -778,12 +787,12 @@ prop_Node_setMdsk node mx = -- Check tag maps prop_Node_tagMaps_idempotent tags = - Node.delTags (Node.addTags m tags) tags == m + Node.delTags (Node.addTags m tags) tags ==? m where m = Data.Map.empty prop_Node_tagMaps_reject tags = not (null tags) ==> - any (\t -> Node.rejectAddTags m [t]) tags + all (\t -> Node.rejectAddTags m [t]) tags where m = Node.addTags Data.Map.empty tags prop_Node_showField node = @@ -972,8 +981,8 @@ testSuite "Cluster" -- | Check that opcode serialization is idempotent. prop_OpCodes_serialization op = case J.readJSON (J.showJSON op) of - J.Error _ -> False - J.Ok op' -> op == op' + J.Error e -> printTestCase ("Cannot deserialise: " ++ e) False + J.Ok op' -> op ==? op' where _types = op::OpCodes.OpCode testSuite "OpCodes" @@ -984,14 +993,14 @@ testSuite "OpCodes" -- | Check that (queued) job\/opcode status serialization is idempotent. prop_OpStatus_serialization os = case J.readJSON (J.showJSON os) of - J.Error _ -> False - J.Ok os' -> os == os' + J.Error e -> printTestCase ("Cannot deserialise: " ++ e) False + J.Ok os' -> os ==? os' where _types = os::Jobs.OpStatus prop_JobStatus_serialization js = case J.readJSON (J.showJSON js) of - J.Error _ -> False - J.Ok js' -> js == js' + J.Error e -> printTestCase ("Cannot deserialise: " ++ e) False + J.Ok js' -> js ==? js' where _types = js::Jobs.JobStatus testSuite "Jobs" @@ -1002,11 +1011,11 @@ testSuite "Jobs" -- ** Loader tests prop_Loader_lookupNode ktn inst node = - Loader.lookupNode nl inst node == Data.Map.lookup node nl + Loader.lookupNode nl inst node ==? Data.Map.lookup node nl where nl = Data.Map.fromList ktn prop_Loader_lookupInstance kti inst = - Loader.lookupInstance il inst == Data.Map.lookup inst il + Loader.lookupInstance il inst ==? Data.Map.lookup inst il where il = Data.Map.fromList kti prop_Loader_assignIndices nodes = diff --git a/htools/test.hs b/htools/test.hs index 4c9ddf2d8d726afa05c7226548ad7f9b99cd9a6f..1c0c9aed0dd4d3de4123af77281fe9f391bcbe4e 100644 --- a/htools/test.hs +++ b/htools/test.hs @@ -25,7 +25,9 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA module Main(main) where +import Data.Char import Data.IORef +import Data.List import Test.QuickCheck import System.Console.GetOpt () import System.IO @@ -120,6 +122,14 @@ allTests = , (slow, testCluster) ] +-- | Extracts the name of a test group. +extractName :: (Args, (String, [(Args -> IO Result, String)])) -> String +extractName (_, (name, _)) = name + +-- | Lowercase a string. +lower :: String -> String +lower = map toLower + transformTestOpts :: Args -> Options -> IO Args transformTestOpts args opts = do r <- case optReplay opts of @@ -139,10 +149,20 @@ main = do let wrap = map (wrapTest errs) cmd_args <- System.getArgs (opts, args) <- parseOpts cmd_args "test" options - let tests = if null args - then allTests - else filter (\(_, (name, _)) -> name `elem` args) allTests - max_count = maximum $ map (\(_, (_, t)) -> length t) tests + tests <- (if null args + then return allTests + else (let args' = map lower args + selected = filter ((`elem` args') . lower . extractName) + allTests + in if null selected + then do + hPutStrLn stderr $ "No tests matching '" + ++ intercalate " " args ++ "', available tests: " + ++ intercalate ", " (map extractName allTests) + exitWith $ ExitFailure 1 + else return selected)) + + let max_count = maximum $ map (\(_, (_, t)) -> length t) tests mapM_ (\(targs, (name, tl)) -> transformTestOpts targs opts >>= \newargs -> runTests name newargs (wrap tl) max_count) tests