diff --git a/htest/Test/Ganeti/Confd/Utils.hs b/htest/Test/Ganeti/Confd/Utils.hs index bc6fa83886f8497b4704e27d19265ec1e509ef7f..49713899ceffe20dcac9dbfbcda6338ca1c8ff4e 100644 --- a/htest/Test/Ganeti/Confd/Utils.hs +++ b/htest/Test/Ganeti/Confd/Utils.hs @@ -64,13 +64,13 @@ instance Arbitrary Confd.ConfdRequest where -- | Test that signing messages and checking signatures is correct. It -- also tests, indirectly the serialisation of messages so we don't -- need a separate test for that. -prop_ConfdUtils_req_sign :: Hash.HashKey -- ^ The hash key - -> NonNegative Integer -- ^ The base timestamp - -> Positive Integer -- ^ Delta for out of window - -> Bool -- ^ Whether delta should be + or - - -> Confd.ConfdRequest - -> Property -prop_ConfdUtils_req_sign key (NonNegative timestamp) (Positive bad_delta) +prop_req_sign :: Hash.HashKey -- ^ The hash key + -> NonNegative Integer -- ^ The base timestamp + -> Positive Integer -- ^ Delta for out of window + -> Bool -- ^ Whether delta should be + or - + -> Confd.ConfdRequest + -> Property +prop_req_sign key (NonNegative timestamp) (Positive bad_delta) pm crq = forAll (choose (0, fromIntegral C.confdMaxClockSkew)) $ \ good_delta -> let encoded = J.encode crq @@ -89,10 +89,10 @@ prop_ConfdUtils_req_sign key (NonNegative timestamp) (Positive bad_delta) -- | Tests that signing with a different key fails detects failure -- correctly. -prop_ConfdUtils_bad_key :: String -- ^ Salt - -> Confd.ConfdRequest -- ^ Request - -> Property -prop_ConfdUtils_bad_key salt crq = +prop_bad_key :: String -- ^ Salt + -> Confd.ConfdRequest -- ^ Request + -> Property +prop_bad_key salt crq = -- fixme: we hardcode here the expected length of a sha1 key, as -- otherwise we could have two short keys that differ only in the -- final zero elements count, and those will be expanded to be the @@ -106,6 +106,6 @@ prop_ConfdUtils_bad_key salt crq = Confd.Utils.parseRequest key_verify encoded testSuite "ConfdUtils" - [ 'prop_ConfdUtils_req_sign - , 'prop_ConfdUtils_bad_key + [ 'prop_req_sign + , 'prop_bad_key ] diff --git a/htest/Test/Ganeti/HTools/CLI.hs b/htest/Test/Ganeti/HTools/CLI.hs index a926ca3382c72cfda67f9bf3c224624ea8b2b9d5..d357a61eb56f5db1b18432d4652190a904bf94b6 100644 --- a/htest/Test/Ganeti/HTools/CLI.hs +++ b/htest/Test/Ganeti/HTools/CLI.hs @@ -43,14 +43,14 @@ import qualified Ganeti.HTools.Program as Program import qualified Ganeti.HTools.Types as Types -- | Test correct parsing. -prop_CLI_parseISpec :: String -> Int -> Int -> Int -> Property -prop_CLI_parseISpec descr dsk mem cpu = +prop_parseISpec :: String -> Int -> Int -> Int -> Property +prop_parseISpec descr dsk mem cpu = let str = printf "%d,%d,%d" dsk mem cpu::String in CLI.parseISpecString descr str ==? Types.Ok (Types.RSpec cpu mem dsk) -- | Test parsing failure due to wrong section count. -prop_CLI_parseISpecFail :: String -> Property -prop_CLI_parseISpecFail descr = +prop_parseISpecFail :: String -> Property +prop_parseISpecFail descr = forAll (choose (0,100) `suchThat` ((/=) 3)) $ \nelems -> forAll (replicateM nelems arbitrary) $ \values -> let str = intercalate "," $ map show (values::[Int]) @@ -59,8 +59,8 @@ prop_CLI_parseISpecFail descr = _ -> property True -- | Test parseYesNo. -prop_CLI_parseYesNo :: Bool -> Bool -> [Char] -> Property -prop_CLI_parseYesNo def testval val = +prop_parseYesNo :: Bool -> Bool -> [Char] -> Property +prop_parseYesNo def testval val = forAll (elements [val, "yes", "no"]) $ \actual_val -> if testval then CLI.parseYesNo def Nothing ==? Types.Ok def @@ -84,8 +84,8 @@ checkStringArg val (opt, fn) = Right (options, _) -> fn options ==? Just val -- | Test a few string arguments. -prop_CLI_StringArg :: [Char] -> Property -prop_CLI_StringArg argument = +prop_StringArg :: [Char] -> Property +prop_StringArg argument = let args = [ (CLI.oDataFile, CLI.optDataFile) , (CLI.oDynuFile, CLI.optDynuFile) , (CLI.oSaveCluster, CLI.optSaveCluster) @@ -109,17 +109,17 @@ checkEarlyExit name options param = -- | Test that all binaries support some common options. There is -- nothing actually random about this test... -prop_CLI_stdopts :: Property -prop_CLI_stdopts = +prop_stdopts :: Property +prop_stdopts = let params = ["-h", "--help", "-V", "--version"] opts = map (\(name, (_, o)) -> (name, o)) Program.personalities -- apply checkEarlyExit across the cartesian product of params and opts in conjoin [checkEarlyExit n o p | p <- params, (n, o) <- opts] testSuite "CLI" - [ 'prop_CLI_parseISpec - , 'prop_CLI_parseISpecFail - , 'prop_CLI_parseYesNo - , 'prop_CLI_StringArg - , 'prop_CLI_stdopts + [ 'prop_parseISpec + , 'prop_parseISpecFail + , 'prop_parseYesNo + , 'prop_StringArg + , 'prop_stdopts ] diff --git a/htest/Test/Ganeti/HTools/Cluster.hs b/htest/Test/Ganeti/HTools/Cluster.hs index 5dbf3d9bf88200d659a7e992ac3657315438f7c2..349bf518cb92a7909f3ef3909922477ebd14754f 100644 --- a/htest/Test/Ganeti/HTools/Cluster.hs +++ b/htest/Test/Ganeti/HTools/Cluster.hs @@ -98,8 +98,8 @@ evacModeOptions Types.MirrorExternal = [Types.ChangePrimary, Types.ChangeAll] -- | Check that the cluster score is close to zero for a homogeneous -- cluster. -prop_Cluster_Score_Zero :: Node.Node -> Property -prop_Cluster_Score_Zero node = +prop_Score_Zero :: Node.Node -> Property +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)) ==> @@ -111,8 +111,8 @@ prop_Cluster_Score_Zero node = in score <= 1e-12 -- | Check that cluster stats are sane. -prop_Cluster_CStats_sane :: Property -prop_Cluster_CStats_sane = +prop_CStats_sane :: Property +prop_CStats_sane = forAll (choose (1, 1024)) $ \count -> forAll genOnlineNode $ \node -> let fn = Node.buildPeers node Container.empty @@ -124,8 +124,8 @@ prop_Cluster_CStats_sane = -- | Check that one instance is allocated correctly, without -- rebalances needed. -prop_Cluster_Alloc_sane :: Instance.Instance -> Property -prop_Cluster_Alloc_sane inst = +prop_Alloc_sane :: Instance.Instance -> Property +prop_Alloc_sane inst = forAll (choose (5, 20)) $ \count -> forAll genOnlineNode $ \node -> let (nl, il, inst') = makeSmallEmptyCluster node count inst @@ -145,8 +145,8 @@ prop_Cluster_Alloc_sane inst = -- instance spec via tiered allocation (whatever the original instance -- spec), on either one or two nodes. Furthermore, we test that -- computed allocation statistics are correct. -prop_Cluster_CanTieredAlloc :: Instance.Instance -> Property -prop_Cluster_CanTieredAlloc inst = +prop_CanTieredAlloc :: Instance.Instance -> Property +prop_CanTieredAlloc inst = forAll (choose (2, 5)) $ \count -> forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node -> let nl = makeSmallCluster node count @@ -193,8 +193,8 @@ genClusterAlloc count node inst = -- | Checks that on a 4-8 node cluster, once we allocate an instance, -- we can also relocate it. -prop_Cluster_AllocRelocate :: Property -prop_Cluster_AllocRelocate = +prop_AllocRelocate :: Property +prop_AllocRelocate = forAll (choose (4, 8)) $ \count -> forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node -> forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst -> @@ -235,8 +235,8 @@ check_EvacMode grp inst result = -- | Checks that on a 4-8 node cluster, once we allocate an instance, -- we can also node-evacuate it. -prop_Cluster_AllocEvacuate :: Property -prop_Cluster_AllocEvacuate = +prop_AllocEvacuate :: Property +prop_AllocEvacuate = forAll (choose (4, 8)) $ \count -> forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node -> forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst -> @@ -252,8 +252,8 @@ prop_Cluster_AllocEvacuate = -- | Checks that on a 4-8 node cluster with two node groups, once we -- allocate an instance on the first node group, we can also change -- its group. -prop_Cluster_AllocChangeGroup :: Property -prop_Cluster_AllocChangeGroup = +prop_AllocChangeGroup :: Property +prop_AllocChangeGroup = forAll (choose (4, 8)) $ \count -> forAll (genOnlineNode `suchThat` (isNodeBig 4)) $ \node -> forAll (genInstanceSmallerThanNode node `suchThat` isMirrored) $ \inst -> @@ -274,8 +274,8 @@ prop_Cluster_AllocChangeGroup = -- | Check that allocating multiple instances on a cluster, then -- adding an empty node, results in a valid rebalance. -prop_Cluster_AllocBalance :: Property -prop_Cluster_AllocBalance = +prop_AllocBalance :: Property +prop_AllocBalance = forAll (genNode (Just 5) (Just 128)) $ \node -> forAll (choose (3, 5)) $ \count -> not (Node.offline node) && not (Node.failN1 node) ==> @@ -296,8 +296,8 @@ prop_Cluster_AllocBalance = canBalance tbl True True False -- | Checks consistency. -prop_Cluster_CheckConsistency :: Node.Node -> Instance.Instance -> Bool -prop_Cluster_CheckConsistency node inst = +prop_CheckConsistency :: Node.Node -> Instance.Instance -> Bool +prop_CheckConsistency node inst = let nl = makeSmallCluster node 3 [node1, node2, node3] = Container.elems nl node3' = node3 { Node.group = 1 } @@ -311,8 +311,8 @@ prop_Cluster_CheckConsistency node inst = (not . null $ ccheck [(0, inst3)]) -- | For now, we only test that we don't lose instances during the split. -prop_Cluster_SplitCluster :: Node.Node -> Instance.Instance -> Property -prop_Cluster_SplitCluster node inst = +prop_SplitCluster :: Node.Node -> Instance.Instance -> Property +prop_SplitCluster node inst = forAll (choose (0, 100)) $ \icnt -> let nl = makeSmallCluster node 2 (nl', il') = foldl (\(ns, is) _ -> assignInstance ns is inst 0 1) @@ -339,8 +339,8 @@ canAllocOn nl reqnodes inst = -- times, and generates a random instance that can be allocated on -- this mini-cluster; it then checks that after applying a policy that -- the instance doesn't fits, the allocation fails. -prop_Cluster_AllocPolicy :: Node.Node -> Property -prop_Cluster_AllocPolicy node = +prop_AllocPolicy :: Node.Node -> Property +prop_AllocPolicy node = -- rqn is the required nodes (1 or 2) forAll (choose (1, 2)) $ \rqn -> forAll (choose (5, 20)) $ \count -> @@ -353,15 +353,15 @@ prop_Cluster_AllocPolicy node = in not $ canAllocOn nl rqn inst testSuite "Cluster" - [ 'prop_Cluster_Score_Zero - , 'prop_Cluster_CStats_sane - , 'prop_Cluster_Alloc_sane - , 'prop_Cluster_CanTieredAlloc - , 'prop_Cluster_AllocRelocate - , 'prop_Cluster_AllocEvacuate - , 'prop_Cluster_AllocChangeGroup - , 'prop_Cluster_AllocBalance - , 'prop_Cluster_CheckConsistency - , 'prop_Cluster_SplitCluster - , 'prop_Cluster_AllocPolicy + [ 'prop_Score_Zero + , 'prop_CStats_sane + , 'prop_Alloc_sane + , 'prop_CanTieredAlloc + , 'prop_AllocRelocate + , 'prop_AllocEvacuate + , 'prop_AllocChangeGroup + , 'prop_AllocBalance + , 'prop_CheckConsistency + , 'prop_SplitCluster + , 'prop_AllocPolicy ] diff --git a/htest/Test/Ganeti/HTools/Container.hs b/htest/Test/Ganeti/HTools/Container.hs index 64c02d5838a75607ba992d2d89a9a062c2c75da8..d03a13e615fc03c20a35f93e6b2f96a5624101d0 100644 --- a/htest/Test/Ganeti/HTools/Container.hs +++ b/htest/Test/Ganeti/HTools/Container.hs @@ -41,16 +41,16 @@ import qualified Ganeti.HTools.Container as Container import qualified Ganeti.HTools.Node as Node -- we silence the following due to hlint bug fixed in later versions -{-# ANN prop_Container_addTwo "HLint: ignore Avoid lambda" #-} -prop_Container_addTwo :: [Container.Key] -> Int -> Int -> Bool -prop_Container_addTwo cdata i1 i2 = +{-# ANN prop_addTwo "HLint: ignore Avoid lambda" #-} +prop_addTwo :: [Container.Key] -> Int -> Int -> Bool +prop_addTwo cdata i1 i2 = fn i1 i2 cont == fn i2 i1 cont && fn i1 i2 cont == fn i1 i2 (fn i1 i2 cont) where cont = foldl (\c x -> Container.add x x c) Container.empty cdata fn x1 x2 = Container.addTwo x1 x1 x2 x2 -prop_Container_nameOf :: Node.Node -> Property -prop_Container_nameOf node = +prop_nameOf :: Node.Node -> Property +prop_nameOf node = let nl = makeSmallCluster node 1 fnode = head (Container.elems nl) in Container.nameOf nl (Node.idx fnode) ==? Node.name fnode @@ -58,8 +58,8 @@ prop_Container_nameOf node = -- | 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, -- and that we fail to find a non-existing name. -prop_Container_findByName :: Property -prop_Container_findByName = +prop_findByName :: Property +prop_findByName = forAll (genNode (Just 1) Nothing) $ \node -> forAll (choose (1, 20)) $ \ cnt -> forAll (choose (0, cnt - 1)) $ \ fidx -> @@ -80,7 +80,7 @@ prop_Container_findByName = (isNothing (Container.findByName nl' othername)) testSuite "Container" - [ 'prop_Container_addTwo - , 'prop_Container_nameOf - , 'prop_Container_findByName + [ 'prop_addTwo + , 'prop_nameOf + , 'prop_findByName ] diff --git a/htest/Test/Ganeti/HTools/Instance.hs b/htest/Test/Ganeti/HTools/Instance.hs index 071117e5f813ef4624dadf9cbcd8cfe91fd72f64..b31a16f148fbb4a20ca331276807ac1f82bd5854 100644 --- a/htest/Test/Ganeti/HTools/Instance.hs +++ b/htest/Test/Ganeti/HTools/Instance.hs @@ -72,98 +72,98 @@ instance Arbitrary Instance.Instance where -- Simple instance tests, we only have setter/getters -prop_Instance_creat :: Instance.Instance -> Property -prop_Instance_creat inst = +prop_creat :: Instance.Instance -> Property +prop_creat inst = Instance.name inst ==? Instance.alias inst -prop_Instance_setIdx :: Instance.Instance -> Types.Idx -> Property -prop_Instance_setIdx inst idx = +prop_setIdx :: Instance.Instance -> Types.Idx -> Property +prop_setIdx inst idx = Instance.idx (Instance.setIdx inst idx) ==? idx -prop_Instance_setName :: Instance.Instance -> String -> Bool -prop_Instance_setName inst name = +prop_setName :: Instance.Instance -> String -> Bool +prop_setName inst name = Instance.name newinst == name && Instance.alias newinst == name where newinst = Instance.setName inst name -prop_Instance_setAlias :: Instance.Instance -> String -> Bool -prop_Instance_setAlias inst name = +prop_setAlias :: Instance.Instance -> String -> Bool +prop_setAlias inst name = Instance.name newinst == Instance.name inst && Instance.alias newinst == name where newinst = Instance.setAlias inst name -prop_Instance_setPri :: Instance.Instance -> Types.Ndx -> Property -prop_Instance_setPri inst pdx = +prop_setPri :: Instance.Instance -> Types.Ndx -> Property +prop_setPri inst pdx = Instance.pNode (Instance.setPri inst pdx) ==? pdx -prop_Instance_setSec :: Instance.Instance -> Types.Ndx -> Property -prop_Instance_setSec inst sdx = +prop_setSec :: Instance.Instance -> Types.Ndx -> Property +prop_setSec inst sdx = Instance.sNode (Instance.setSec inst sdx) ==? sdx -prop_Instance_setBoth :: Instance.Instance -> Types.Ndx -> Types.Ndx -> Bool -prop_Instance_setBoth inst pdx sdx = +prop_setBoth :: Instance.Instance -> Types.Ndx -> Types.Ndx -> Bool +prop_setBoth inst pdx sdx = Instance.pNode si == pdx && Instance.sNode si == sdx where si = Instance.setBoth inst pdx sdx -prop_Instance_shrinkMG :: Instance.Instance -> Property -prop_Instance_shrinkMG inst = +prop_shrinkMG :: Instance.Instance -> Property +prop_shrinkMG inst = Instance.mem inst >= 2 * Types.unitMem ==> case Instance.shrinkByType inst Types.FailMem of Types.Ok inst' -> Instance.mem inst' == Instance.mem inst - Types.unitMem _ -> False -prop_Instance_shrinkMF :: Instance.Instance -> Property -prop_Instance_shrinkMF inst = +prop_shrinkMF :: Instance.Instance -> Property +prop_shrinkMF inst = forAll (choose (0, 2 * Types.unitMem - 1)) $ \mem -> let inst' = inst { Instance.mem = mem} in Types.isBad $ Instance.shrinkByType inst' Types.FailMem -prop_Instance_shrinkCG :: Instance.Instance -> Property -prop_Instance_shrinkCG inst = +prop_shrinkCG :: Instance.Instance -> Property +prop_shrinkCG inst = Instance.vcpus inst >= 2 * Types.unitCpu ==> case Instance.shrinkByType inst Types.FailCPU of Types.Ok inst' -> Instance.vcpus inst' == Instance.vcpus inst - Types.unitCpu _ -> False -prop_Instance_shrinkCF :: Instance.Instance -> Property -prop_Instance_shrinkCF inst = +prop_shrinkCF :: Instance.Instance -> Property +prop_shrinkCF inst = forAll (choose (0, 2 * Types.unitCpu - 1)) $ \vcpus -> let inst' = inst { Instance.vcpus = vcpus } in Types.isBad $ Instance.shrinkByType inst' Types.FailCPU -prop_Instance_shrinkDG :: Instance.Instance -> Property -prop_Instance_shrinkDG inst = +prop_shrinkDG :: Instance.Instance -> Property +prop_shrinkDG inst = Instance.dsk inst >= 2 * Types.unitDsk ==> case Instance.shrinkByType inst Types.FailDisk of Types.Ok inst' -> Instance.dsk inst' == Instance.dsk inst - Types.unitDsk _ -> False -prop_Instance_shrinkDF :: Instance.Instance -> Property -prop_Instance_shrinkDF inst = +prop_shrinkDF :: Instance.Instance -> Property +prop_shrinkDF inst = forAll (choose (0, 2 * Types.unitDsk - 1)) $ \dsk -> let inst' = inst { Instance.dsk = dsk } in Types.isBad $ Instance.shrinkByType inst' Types.FailDisk -prop_Instance_setMovable :: Instance.Instance -> Bool -> Property -prop_Instance_setMovable inst m = +prop_setMovable :: Instance.Instance -> Bool -> Property +prop_setMovable inst m = Instance.movable inst' ==? m where inst' = Instance.setMovable inst m testSuite "Instance" - [ 'prop_Instance_creat - , 'prop_Instance_setIdx - , 'prop_Instance_setName - , 'prop_Instance_setAlias - , 'prop_Instance_setPri - , 'prop_Instance_setSec - , 'prop_Instance_setBoth - , 'prop_Instance_shrinkMG - , 'prop_Instance_shrinkMF - , 'prop_Instance_shrinkCG - , 'prop_Instance_shrinkCF - , 'prop_Instance_shrinkDG - , 'prop_Instance_shrinkDF - , 'prop_Instance_setMovable + [ 'prop_creat + , 'prop_setIdx + , 'prop_setName + , 'prop_setAlias + , 'prop_setPri + , 'prop_setSec + , 'prop_setBoth + , 'prop_shrinkMG + , 'prop_shrinkMF + , 'prop_shrinkCG + , 'prop_shrinkCF + , 'prop_shrinkDG + , 'prop_shrinkDF + , 'prop_setMovable ] diff --git a/htest/Test/Ganeti/HTools/Loader.hs b/htest/Test/Ganeti/HTools/Loader.hs index 2699ed01e4b16c7641fcaa935115feb762a1ffa2..653744c3765c2cc5ac9f21968142985d32435bc9 100644 --- a/htest/Test/Ganeti/HTools/Loader.hs +++ b/htest/Test/Ganeti/HTools/Loader.hs @@ -44,18 +44,18 @@ import qualified Ganeti.HTools.Loader as Loader import qualified Ganeti.HTools.Node as Node import qualified Ganeti.HTools.Types as Types -prop_Loader_lookupNode :: [(String, Int)] -> String -> String -> Property -prop_Loader_lookupNode ktn inst node = +prop_lookupNode :: [(String, Int)] -> String -> String -> Property +prop_lookupNode ktn inst node = Loader.lookupNode nl inst node ==? Map.lookup node nl where nl = Map.fromList ktn -prop_Loader_lookupInstance :: [(String, Int)] -> String -> Property -prop_Loader_lookupInstance kti inst = +prop_lookupInstance :: [(String, Int)] -> String -> Property +prop_lookupInstance kti inst = Loader.lookupInstance il inst ==? Map.lookup inst il where il = Map.fromList kti -prop_Loader_assignIndices :: Property -prop_Loader_assignIndices = +prop_assignIndices :: Property +prop_assignIndices = -- generate nodes with unique names forAll (arbitrary `suchThat` (\nodes -> @@ -71,8 +71,8 @@ prop_Loader_assignIndices = -- | Checks that the number of primary instances recorded on the nodes -- is zero. -prop_Loader_mergeData :: [Node.Node] -> Bool -prop_Loader_mergeData ns = +prop_mergeData :: [Node.Node] -> Bool +prop_mergeData ns = let na = Container.fromList $ map (\n -> (Node.idx n, n)) ns in case Loader.mergeData [] [] [] [] (Loader.emptyCluster {Loader.cdNodes = na}) of @@ -84,22 +84,22 @@ prop_Loader_mergeData ns = null instances -- | Check that compareNameComponent on equal strings works. -prop_Loader_compareNameComponent_equal :: String -> Bool -prop_Loader_compareNameComponent_equal s = +prop_compareNameComponent_equal :: String -> Bool +prop_compareNameComponent_equal s = BasicTypes.compareNameComponent s s == BasicTypes.LookupResult BasicTypes.ExactMatch s -- | Check that compareNameComponent on prefix strings works. -prop_Loader_compareNameComponent_prefix :: NonEmptyList Char -> String -> Bool -prop_Loader_compareNameComponent_prefix (NonEmpty s1) s2 = +prop_compareNameComponent_prefix :: NonEmptyList Char -> String -> Bool +prop_compareNameComponent_prefix (NonEmpty s1) s2 = BasicTypes.compareNameComponent (s1 ++ "." ++ s2) s1 == BasicTypes.LookupResult BasicTypes.PartialMatch s1 testSuite "Loader" - [ 'prop_Loader_lookupNode - , 'prop_Loader_lookupInstance - , 'prop_Loader_assignIndices - , 'prop_Loader_mergeData - , 'prop_Loader_compareNameComponent_equal - , 'prop_Loader_compareNameComponent_prefix + [ 'prop_lookupNode + , 'prop_lookupInstance + , 'prop_assignIndices + , 'prop_mergeData + , 'prop_compareNameComponent_equal + , 'prop_compareNameComponent_prefix ] diff --git a/htest/Test/Ganeti/HTools/Node.hs b/htest/Test/Ganeti/HTools/Node.hs index 71397fa79d1deacde2a7366b3db1710d39330476..1e44cf22c587bb55da997cea7574cdd0e456829e 100644 --- a/htest/Test/Ganeti/HTools/Node.hs +++ b/htest/Test/Ganeti/HTools/Node.hs @@ -98,31 +98,31 @@ instance Arbitrary Node.Node where -- * Test cases -prop_Node_setAlias :: Node.Node -> String -> Bool -prop_Node_setAlias node name = +prop_setAlias :: Node.Node -> String -> Bool +prop_setAlias node name = Node.name newnode == Node.name node && Node.alias newnode == name where newnode = Node.setAlias node name -prop_Node_setOffline :: Node.Node -> Bool -> Property -prop_Node_setOffline node status = +prop_setOffline :: Node.Node -> Bool -> Property +prop_setOffline node status = Node.offline newnode ==? status where newnode = Node.setOffline node status -prop_Node_setXmem :: Node.Node -> Int -> Property -prop_Node_setXmem node xm = +prop_setXmem :: Node.Node -> Int -> Property +prop_setXmem node xm = Node.xMem newnode ==? xm where newnode = Node.setXmem node xm -prop_Node_setMcpu :: Node.Node -> Double -> Property -prop_Node_setMcpu node mc = +prop_setMcpu :: Node.Node -> Double -> Property +prop_setMcpu node mc = Types.iPolicyVcpuRatio (Node.iPolicy newnode) ==? mc where newnode = Node.setMcpu node mc -- | Check that an instance add with too high memory or disk will be -- rejected. -prop_Node_addPriFM :: Node.Node -> Instance.Instance -> Property -prop_Node_addPriFM node inst = +prop_addPriFM :: Node.Node -> Instance.Instance -> Property +prop_addPriFM node inst = Instance.mem inst >= Node.fMem node && not (Node.failN1 node) && not (Instance.isOffline inst) ==> case Node.addPri node inst'' of @@ -133,8 +133,8 @@ prop_Node_addPriFM node inst = -- | Check that adding a primary instance with too much disk fails -- with type FailDisk. -prop_Node_addPriFD :: Node.Node -> Instance.Instance -> Property -prop_Node_addPriFD node inst = +prop_addPriFD :: Node.Node -> Instance.Instance -> Property +prop_addPriFD node inst = forAll (elements Instance.localStorageTemplates) $ \dt -> Instance.dsk inst >= Node.fDsk node && not (Node.failN1 node) ==> let inst' = setInstanceSmallerThanNode node inst @@ -146,8 +146,8 @@ prop_Node_addPriFD node inst = -- | Check that adding a primary instance with too many VCPUs fails -- with type FailCPU. -prop_Node_addPriFC :: Property -prop_Node_addPriFC = +prop_addPriFC :: Property +prop_addPriFC = forAll (choose (1, maxCpu)) $ \extra -> forAll genOnlineNode $ \node -> forAll (arbitrary `suchThat` Instance.notOffline) $ \inst -> @@ -159,8 +159,8 @@ prop_Node_addPriFC = -- | Check that an instance add with too high memory or disk will be -- rejected. -prop_Node_addSec :: Node.Node -> Instance.Instance -> Int -> Property -prop_Node_addSec node inst pdx = +prop_addSec :: Node.Node -> Instance.Instance -> Int -> Property +prop_addSec node inst pdx = ((Instance.mem inst >= (Node.fMem node - Node.rMem node) && not (Instance.isOffline inst)) || Instance.dsk inst >= Node.fDsk node) && @@ -169,8 +169,8 @@ prop_Node_addSec node inst pdx = -- | Check that an offline instance with reasonable disk size but -- extra mem/cpu can always be added. -prop_Node_addOfflinePri :: NonNegative Int -> NonNegative Int -> Property -prop_Node_addOfflinePri (NonNegative extra_mem) (NonNegative extra_cpu) = +prop_addOfflinePri :: NonNegative Int -> NonNegative Int -> Property +prop_addOfflinePri (NonNegative extra_mem) (NonNegative extra_cpu) = forAll genOnlineNode $ \node -> forAll (genInstanceSmallerThanNode node) $ \inst -> let inst' = inst { Instance.runSt = Types.AdminOffline @@ -182,9 +182,9 @@ prop_Node_addOfflinePri (NonNegative extra_mem) (NonNegative extra_cpu) = -- | Check that an offline instance with reasonable disk size but -- extra mem/cpu can always be added. -prop_Node_addOfflineSec :: NonNegative Int -> NonNegative Int - -> Types.Ndx -> Property -prop_Node_addOfflineSec (NonNegative extra_mem) (NonNegative extra_cpu) pdx = +prop_addOfflineSec :: NonNegative Int -> NonNegative Int + -> Types.Ndx -> Property +prop_addOfflineSec (NonNegative extra_mem) (NonNegative extra_cpu) pdx = forAll genOnlineNode $ \node -> forAll (genInstanceSmallerThanNode node) $ \inst -> let inst' = inst { Instance.runSt = Types.AdminOffline @@ -196,8 +196,8 @@ prop_Node_addOfflineSec (NonNegative extra_mem) (NonNegative extra_cpu) pdx = v -> failTest $ "Expected OpGood/OpGood, but got: " ++ show v -- | Checks for memory reservation changes. -prop_Node_rMem :: Instance.Instance -> Property -prop_Node_rMem inst = +prop_rMem :: Instance.Instance -> Property +prop_rMem inst = not (Instance.isOffline inst) ==> forAll (genOnlineNode `suchThat` ((> Types.unitMem) . Node.fMem)) $ \node -> -- ab = auto_balance, nb = non-auto_balance @@ -230,8 +230,8 @@ prop_Node_rMem inst = x -> failTest $ "Failed to add/remove instances: " ++ show x -- | Check mdsk setting. -prop_Node_setMdsk :: Node.Node -> SmallRatio -> Bool -prop_Node_setMdsk node mx = +prop_setMdsk :: Node.Node -> SmallRatio -> Bool +prop_setMdsk node mx = Node.loDsk node' >= 0 && fromIntegral (Node.loDsk node') <= Node.tDsk node && Node.availDisk node' >= 0 && @@ -242,26 +242,26 @@ prop_Node_setMdsk node mx = SmallRatio mx' = mx -- Check tag maps -prop_Node_tagMaps_idempotent :: Property -prop_Node_tagMaps_idempotent = +prop_tagMaps_idempotent :: Property +prop_tagMaps_idempotent = forAll genTags $ \tags -> Node.delTags (Node.addTags m tags) tags ==? m where m = Map.empty -prop_Node_tagMaps_reject :: Property -prop_Node_tagMaps_reject = +prop_tagMaps_reject :: Property +prop_tagMaps_reject = forAll (genTags `suchThat` (not . null)) $ \tags -> let m = Node.addTags Map.empty tags in all (\t -> Node.rejectAddTags m [t]) tags -prop_Node_showField :: Node.Node -> Property -prop_Node_showField node = +prop_showField :: Node.Node -> Property +prop_showField node = forAll (elements Node.defaultFields) $ \ field -> fst (Node.showHeader field) /= Types.unknownField && Node.showField node field /= Types.unknownField -prop_Node_computeGroups :: [Node.Node] -> Bool -prop_Node_computeGroups nodes = +prop_computeGroups :: [Node.Node] -> Bool +prop_computeGroups nodes = let ng = Node.computeGroups nodes onlyuuid = map fst ng in length nodes == sum (map (length . snd) ng) && @@ -270,16 +270,16 @@ prop_Node_computeGroups nodes = (null nodes || not (null ng)) -- Check idempotence of add/remove operations -prop_Node_addPri_idempotent :: Property -prop_Node_addPri_idempotent = +prop_addPri_idempotent :: Property +prop_addPri_idempotent = forAll genOnlineNode $ \node -> forAll (genInstanceSmallerThanNode node) $ \inst -> case Node.addPri node inst of Types.OpGood node' -> Node.removePri node' inst ==? node _ -> failTest "Can't add instance" -prop_Node_addSec_idempotent :: Property -prop_Node_addSec_idempotent = +prop_addSec_idempotent :: Property +prop_addSec_idempotent = forAll genOnlineNode $ \node -> forAll (genInstanceSmallerThanNode node) $ \inst -> let pdx = Node.idx node + 1 @@ -290,22 +290,22 @@ prop_Node_addSec_idempotent = _ -> failTest "Can't add instance" testSuite "Node" - [ 'prop_Node_setAlias - , 'prop_Node_setOffline - , 'prop_Node_setMcpu - , 'prop_Node_setXmem - , 'prop_Node_addPriFM - , 'prop_Node_addPriFD - , 'prop_Node_addPriFC - , 'prop_Node_addSec - , 'prop_Node_addOfflinePri - , 'prop_Node_addOfflineSec - , 'prop_Node_rMem - , 'prop_Node_setMdsk - , 'prop_Node_tagMaps_idempotent - , 'prop_Node_tagMaps_reject - , 'prop_Node_showField - , 'prop_Node_computeGroups - , 'prop_Node_addPri_idempotent - , 'prop_Node_addSec_idempotent + [ 'prop_setAlias + , 'prop_setOffline + , 'prop_setMcpu + , 'prop_setXmem + , 'prop_addPriFM + , 'prop_addPriFD + , 'prop_addPriFC + , 'prop_addSec + , 'prop_addOfflinePri + , 'prop_addOfflineSec + , 'prop_rMem + , 'prop_setMdsk + , 'prop_tagMaps_idempotent + , 'prop_tagMaps_reject + , 'prop_showField + , 'prop_computeGroups + , 'prop_addPri_idempotent + , 'prop_addSec_idempotent ] diff --git a/htest/Test/Ganeti/HTools/PeerMap.hs b/htest/Test/Ganeti/HTools/PeerMap.hs index f15864a4fb681f4c22b2e14fa24d31abc63c7927..2b6f34f0d0cfc087ef852cce7d9c5a245f9f6645 100644 --- a/htest/Test/Ganeti/HTools/PeerMap.hs +++ b/htest/Test/Ganeti/HTools/PeerMap.hs @@ -36,45 +36,45 @@ import Test.Ganeti.TestCommon import qualified Ganeti.HTools.PeerMap as PeerMap -- | Make sure add is idempotent. -prop_PeerMap_addIdempotent :: PeerMap.PeerMap - -> PeerMap.Key -> PeerMap.Elem -> Property -prop_PeerMap_addIdempotent pmap key em = +prop_addIdempotent :: PeerMap.PeerMap + -> PeerMap.Key -> PeerMap.Elem -> Property +prop_addIdempotent pmap key em = fn puniq ==? fn (fn puniq) where fn = PeerMap.add key em puniq = PeerMap.accumArray const pmap -- | Make sure remove is idempotent. -prop_PeerMap_removeIdempotent :: PeerMap.PeerMap -> PeerMap.Key -> Property -prop_PeerMap_removeIdempotent pmap key = +prop_removeIdempotent :: PeerMap.PeerMap -> PeerMap.Key -> Property +prop_removeIdempotent pmap key = fn puniq ==? fn (fn puniq) where fn = PeerMap.remove key puniq = PeerMap.accumArray const pmap -- | Make sure a missing item returns 0. -prop_PeerMap_findMissing :: PeerMap.PeerMap -> PeerMap.Key -> Property -prop_PeerMap_findMissing pmap key = +prop_findMissing :: PeerMap.PeerMap -> PeerMap.Key -> Property +prop_findMissing pmap key = PeerMap.find key (PeerMap.remove key puniq) ==? 0 where puniq = PeerMap.accumArray const pmap -- | Make sure an added item is found. -prop_PeerMap_addFind :: PeerMap.PeerMap +prop_addFind :: PeerMap.PeerMap -> PeerMap.Key -> PeerMap.Elem -> Property -prop_PeerMap_addFind pmap key em = +prop_addFind pmap key em = PeerMap.find key (PeerMap.add key em puniq) ==? em where puniq = PeerMap.accumArray const pmap -- | Manual check that maxElem returns the maximum indeed, or 0 for null. -prop_PeerMap_maxElem :: PeerMap.PeerMap -> Property -prop_PeerMap_maxElem pmap = +prop_maxElem :: PeerMap.PeerMap -> Property +prop_maxElem pmap = PeerMap.maxElem puniq ==? if null puniq then 0 else (maximum . snd . unzip) puniq where puniq = PeerMap.accumArray const pmap -- | List of tests for the PeerMap module. testSuite "PeerMap" - [ 'prop_PeerMap_addIdempotent - , 'prop_PeerMap_removeIdempotent - , 'prop_PeerMap_maxElem - , 'prop_PeerMap_addFind - , 'prop_PeerMap_findMissing + [ 'prop_addIdempotent + , 'prop_removeIdempotent + , 'prop_maxElem + , 'prop_addFind + , 'prop_findMissing ] diff --git a/htest/Test/Ganeti/HTools/Simu.hs b/htest/Test/Ganeti/HTools/Simu.hs index fcab7697d9d1cbc23d4bd149d7cf3abc1ff3ec32..2960717e1d699f7b7d534ccddf14295e55c9b88b 100644 --- a/htest/Test/Ganeti/HTools/Simu.hs +++ b/htest/Test/Ganeti/HTools/Simu.hs @@ -62,8 +62,8 @@ genSimuSpec = do -- | Checks that given a set of corrects specs, we can load them -- successfully, and that at high-level the values look right. -prop_Simu_Load :: Property -prop_Simu_Load = +prop_Load :: Property +prop_Load = forAll (choose (0, 10)) $ \ngroups -> forAll (replicateM ngroups genSimuSpec) $ \specs -> let strspecs = map (\(p, n, d, m, c) -> printf "%s,%d,%d,%d,%d" @@ -93,5 +93,5 @@ prop_Simu_Load = replicate ngroups Types.defIPolicy testSuite "Simu" - [ 'prop_Simu_Load + [ 'prop_Load ] diff --git a/htest/Test/Ganeti/HTools/Text.hs b/htest/Test/Ganeti/HTools/Text.hs index 1fe768b51897b5f2ff707c32e3d561cd4ffbd603..d5ef2904647b349ae7c9cdf91b109cf8ee64338b 100644 --- a/htest/Test/Ganeti/HTools/Text.hs +++ b/htest/Test/Ganeti/HTools/Text.hs @@ -52,13 +52,13 @@ import qualified Ganeti.HTools.Utils as Utils -- * Instance text loader tests -prop_Text_Load_Instance :: String -> Int -> Int -> Int -> Types.InstanceStatus - -> NonEmptyList Char -> [Char] - -> NonNegative Int -> NonNegative Int -> Bool - -> Types.DiskTemplate -> Int -> Property -prop_Text_Load_Instance name mem dsk vcpus status - (NonEmpty pnode) snode - (NonNegative pdx) (NonNegative sdx) autobal dt su = +prop_Load_Instance :: String -> Int -> Int -> Int -> Types.InstanceStatus + -> NonEmptyList Char -> [Char] + -> NonNegative Int -> NonNegative Int -> Bool + -> Types.DiskTemplate -> Int -> Property +prop_Load_Instance name mem dsk vcpus status + (NonEmpty pnode) snode + (NonNegative pdx) (NonNegative sdx) autobal dt su = pnode /= snode && pdx /= sdx ==> let vcpus_s = show vcpus dsk_s = show dsk @@ -93,8 +93,8 @@ prop_Text_Load_Instance name mem dsk vcpus status Instance.spindleUse i == su && Types.isBad fail1 -prop_Text_Load_InstanceFail :: [(String, Int)] -> [String] -> Property -prop_Text_Load_InstanceFail ktn fields = +prop_Load_InstanceFail :: [(String, Int)] -> [String] -> Property +prop_Load_InstanceFail ktn fields = length fields /= 10 && length fields /= 11 ==> case Text.loadInst nl fields of Types.Ok _ -> failTest "Managed to load instance from invalid data" @@ -102,9 +102,9 @@ prop_Text_Load_InstanceFail ktn fields = "Invalid/incomplete instance data: '" `isPrefixOf` msg where nl = Map.fromList ktn -prop_Text_Load_Node :: String -> Int -> Int -> Int -> Int -> Int - -> Int -> Bool -> Bool -prop_Text_Load_Node name tm nm fm td fd tc fo = +prop_Load_Node :: String -> Int -> Int -> Int -> Int -> Int + -> Int -> Bool -> Bool +prop_Load_Node name tm nm fm td fd tc fo = let conv v = if v < 0 then "?" else show v @@ -134,12 +134,12 @@ prop_Text_Load_Node name tm nm fm td fd tc fo = Node.fDsk node == fd && Node.tCpu node == fromIntegral tc -prop_Text_Load_NodeFail :: [String] -> Property -prop_Text_Load_NodeFail fields = +prop_Load_NodeFail :: [String] -> Property +prop_Load_NodeFail fields = length fields /= 8 ==> isNothing $ Text.loadNode Map.empty fields -prop_Text_NodeLSIdempotent :: Property -prop_Text_NodeLSIdempotent = +prop_NodeLSIdempotent :: Property +prop_NodeLSIdempotent = forAll (genNode (Just 1) Nothing) $ \node -> -- override failN1 to what loadNode returns by default let n = Node.setPolicy Types.defIPolicy $ @@ -149,15 +149,15 @@ prop_Text_NodeLSIdempotent = Utils.sepSplit '|' . Text.serializeNode defGroupList) n ==? Just (Node.name n, n) -prop_Text_ISpecIdempotent :: Types.ISpec -> Property -prop_Text_ISpecIdempotent ispec = +prop_ISpecIdempotent :: Types.ISpec -> Property +prop_ISpecIdempotent ispec = case Text.loadISpec "dummy" . Utils.sepSplit ',' . Text.serializeISpec $ ispec of Types.Bad msg -> failTest $ "Failed to load ispec: " ++ msg Types.Ok ispec' -> ispec ==? ispec' -prop_Text_IPolicyIdempotent :: Types.IPolicy -> Property -prop_Text_IPolicyIdempotent ipol = +prop_IPolicyIdempotent :: Types.IPolicy -> Property +prop_IPolicyIdempotent ipol = case Text.loadIPolicy . Utils.sepSplit '|' $ Text.serializeIPolicy owner ipol of Types.Bad msg -> failTest $ "Failed to load ispec: " ++ msg @@ -171,8 +171,8 @@ prop_Text_IPolicyIdempotent ipol = -- allocations, not for the business logic). As such, it's a quite -- complex and slow test, and that's the reason we restrict it to -- small cluster sizes. -prop_Text_CreateSerialise :: Property -prop_Text_CreateSerialise = +prop_CreateSerialise :: Property +prop_CreateSerialise = forAll genTags $ \ctags -> forAll (choose (1, 20)) $ \maxiter -> forAll (choose (2, 10)) $ \count -> @@ -200,12 +200,12 @@ prop_Text_CreateSerialise = nl' ==? nl2 testSuite "Text" - [ 'prop_Text_Load_Instance - , 'prop_Text_Load_InstanceFail - , 'prop_Text_Load_Node - , 'prop_Text_Load_NodeFail - , 'prop_Text_NodeLSIdempotent - , 'prop_Text_ISpecIdempotent - , 'prop_Text_IPolicyIdempotent - , 'prop_Text_CreateSerialise + [ 'prop_Load_Instance + , 'prop_Load_InstanceFail + , 'prop_Load_Node + , 'prop_Load_NodeFail + , 'prop_NodeLSIdempotent + , 'prop_ISpecIdempotent + , 'prop_IPolicyIdempotent + , 'prop_CreateSerialise ] diff --git a/htest/Test/Ganeti/HTools/Types.hs b/htest/Test/Ganeti/HTools/Types.hs index 12a64cfc7841cb160ea6782096b5c16a75376c93..5eeaae2b1ff24e9a1ec389f8d6498bfa5cbd1da3 100644 --- a/htest/Test/Ganeti/HTools/Types.hs +++ b/htest/Test/Ganeti/HTools/Types.hs @@ -127,38 +127,38 @@ instance Arbitrary Types.IPolicy where -- * Test cases -prop_Types_AllocPolicy_serialisation :: Types.AllocPolicy -> Property -prop_Types_AllocPolicy_serialisation apol = +prop_AllocPolicy_serialisation :: Types.AllocPolicy -> Property +prop_AllocPolicy_serialisation apol = case J.readJSON (J.showJSON apol) of J.Ok p -> p ==? apol J.Error s -> failTest $ "Failed to deserialise: " ++ s -prop_Types_DiskTemplate_serialisation :: Types.DiskTemplate -> Property -prop_Types_DiskTemplate_serialisation dt = +prop_DiskTemplate_serialisation :: Types.DiskTemplate -> Property +prop_DiskTemplate_serialisation dt = case J.readJSON (J.showJSON dt) of J.Ok p -> p ==? dt J.Error s -> failTest $ "Failed to deserialise: " ++ s -prop_Types_ISpec_serialisation :: Types.ISpec -> Property -prop_Types_ISpec_serialisation ispec = +prop_ISpec_serialisation :: Types.ISpec -> Property +prop_ISpec_serialisation ispec = case J.readJSON (J.showJSON ispec) of J.Ok p -> p ==? ispec J.Error s -> failTest $ "Failed to deserialise: " ++ s -prop_Types_IPolicy_serialisation :: Types.IPolicy -> Property -prop_Types_IPolicy_serialisation ipol = +prop_IPolicy_serialisation :: Types.IPolicy -> Property +prop_IPolicy_serialisation ipol = case J.readJSON (J.showJSON ipol) of J.Ok p -> p ==? ipol J.Error s -> failTest $ "Failed to deserialise: " ++ s -prop_Types_EvacMode_serialisation :: Types.EvacMode -> Property -prop_Types_EvacMode_serialisation em = +prop_EvacMode_serialisation :: Types.EvacMode -> Property +prop_EvacMode_serialisation em = case J.readJSON (J.showJSON em) of J.Ok p -> p ==? em J.Error s -> failTest $ "Failed to deserialise: " ++ s -prop_Types_opToResult :: Types.OpResult Int -> Bool -prop_Types_opToResult op = +prop_opToResult :: Types.OpResult Int -> Bool +prop_opToResult op = case op of Types.OpFail _ -> Types.isBad r Types.OpGood v -> case r of @@ -166,8 +166,8 @@ prop_Types_opToResult op = Types.Ok v' -> v == v' where r = Types.opToResult op -prop_Types_eitherToResult :: Either String Int -> Bool -prop_Types_eitherToResult ei = +prop_eitherToResult :: Either String Int -> Bool +prop_eitherToResult ei = case ei of Left _ -> Types.isBad r Right v -> case r of @@ -176,11 +176,11 @@ prop_Types_eitherToResult ei = where r = Types.eitherToResult ei testSuite "Types" - [ 'prop_Types_AllocPolicy_serialisation - , 'prop_Types_DiskTemplate_serialisation - , 'prop_Types_ISpec_serialisation - , 'prop_Types_IPolicy_serialisation - , 'prop_Types_EvacMode_serialisation - , 'prop_Types_opToResult - , 'prop_Types_eitherToResult + [ 'prop_AllocPolicy_serialisation + , 'prop_DiskTemplate_serialisation + , 'prop_ISpec_serialisation + , 'prop_IPolicy_serialisation + , 'prop_EvacMode_serialisation + , 'prop_opToResult + , 'prop_eitherToResult ] diff --git a/htest/Test/Ganeti/HTools/Utils.hs b/htest/Test/Ganeti/HTools/Utils.hs index 538d8263a3cc513e1024eeade84d0652a26db2d9..eba69d1989235a3a2e65883f4bc13f231c7ef693 100644 --- a/htest/Test/Ganeti/HTools/Utils.hs +++ b/htest/Test/Ganeti/HTools/Utils.hs @@ -47,21 +47,21 @@ genNonCommaString = do -- | If the list is not just an empty element, and if the elements do -- not contain commas, then join+split should be idempotent. -prop_Utils_commaJoinSplit :: Property -prop_Utils_commaJoinSplit = +prop_commaJoinSplit :: Property +prop_commaJoinSplit = forAll (choose (0, 20)) $ \llen -> forAll (vectorOf llen genNonCommaString `suchThat` ((/=) [""])) $ \lst -> Utils.sepSplit ',' (Utils.commaJoin lst) ==? lst -- | Split and join should always be idempotent. -prop_Utils_commaSplitJoin :: [Char] -> Property -prop_Utils_commaSplitJoin s = +prop_commaSplitJoin :: [Char] -> Property +prop_commaSplitJoin s = Utils.commaJoin (Utils.sepSplit ',' s) ==? s -- | fromObjWithDefault, we test using the Maybe monad and an integer -- value. -prop_Utils_fromObjWithDefault :: Integer -> String -> Bool -prop_Utils_fromObjWithDefault def_value random_key = +prop_fromObjWithDefault :: Integer -> String -> Bool +prop_fromObjWithDefault def_value random_key = -- a missing key will be returned with the default JSON.fromObjWithDefault [] random_key def_value == Just def_value && -- a found key will be returned as is, not with default @@ -69,42 +69,42 @@ prop_Utils_fromObjWithDefault def_value random_key = random_key (def_value+1) == Just def_value -- | Test that functional if' behaves like the syntactic sugar if. -prop_Utils_if'if :: Bool -> Int -> Int -> Gen Prop -prop_Utils_if'if cnd a b = +prop_if'if :: Bool -> Int -> Int -> Gen Prop +prop_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 - -> Gen Prop -- ^ Test result -prop_Utils_select def lst1 lst2 = +prop_select :: Int -- ^ Default result + -> [Int] -- ^ List of False values + -> [Int] -- ^ List of True values + -> Gen Prop -- ^ Test result +prop_select def lst1 lst2 = Utils.select def (flist ++ tlist) ==? expectedresult where expectedresult = Utils.if' (null lst2) def (head lst2) flist = zip (repeat False) lst1 tlist = zip (repeat True) lst2 -- | Test basic select functionality with undefined default -prop_Utils_select_undefd :: [Int] -- ^ List of False values - -> NonEmptyList Int -- ^ List of True values - -> Gen Prop -- ^ Test result -prop_Utils_select_undefd lst1 (NonEmpty lst2) = +prop_select_undefd :: [Int] -- ^ List of False values + -> NonEmptyList Int -- ^ List of True values + -> Gen Prop -- ^ Test result +prop_select_undefd lst1 (NonEmpty lst2) = Utils.select undefined (flist ++ tlist) ==? head lst2 where flist = zip (repeat False) lst1 tlist = zip (repeat True) lst2 -- | Test basic select functionality with undefined list values -prop_Utils_select_undefv :: [Int] -- ^ List of False values - -> NonEmptyList Int -- ^ List of True values - -> Gen Prop -- ^ Test result -prop_Utils_select_undefv lst1 (NonEmpty lst2) = +prop_select_undefv :: [Int] -- ^ List of False values + -> NonEmptyList Int -- ^ List of True values + -> Gen Prop -- ^ Test result +prop_select_undefv lst1 (NonEmpty lst2) = Utils.select undefined cndlist ==? head lst2 where flist = zip (repeat False) lst1 tlist = zip (repeat True) lst2 cndlist = flist ++ tlist ++ [undefined] -prop_Utils_parseUnit :: NonNegative Int -> Property -prop_Utils_parseUnit (NonNegative n) = +prop_parseUnit :: NonNegative Int -> Property +prop_parseUnit (NonNegative n) = Utils.parseUnit (show n) ==? Types.Ok n .&&. Utils.parseUnit (show n ++ "m") ==? Types.Ok n .&&. Utils.parseUnit (show n ++ "M") ==? Types.Ok (truncate n_mb::Int) .&&. @@ -121,12 +121,12 @@ prop_Utils_parseUnit (NonNegative n) = -- | Test list for the Utils module. testSuite "Utils" - [ 'prop_Utils_commaJoinSplit - , 'prop_Utils_commaSplitJoin - , 'prop_Utils_fromObjWithDefault - , 'prop_Utils_if'if - , 'prop_Utils_select - , 'prop_Utils_select_undefd - , 'prop_Utils_select_undefv - , 'prop_Utils_parseUnit + [ 'prop_commaJoinSplit + , 'prop_commaSplitJoin + , 'prop_fromObjWithDefault + , 'prop_if'if + , 'prop_select + , 'prop_select_undefd + , 'prop_select_undefv + , 'prop_parseUnit ] diff --git a/htest/Test/Ganeti/JSON.hs b/htest/Test/Ganeti/JSON.hs index 6a42fd7bd44aa8f5bb551404e1277a1d6a95d2b4..0ad22ff73dfcb3107b16810e8acaa6e9e19000d4 100644 --- a/htest/Test/Ganeti/JSON.hs +++ b/htest/Test/Ganeti/JSON.hs @@ -38,15 +38,15 @@ import Test.Ganeti.TestCommon import qualified Ganeti.BasicTypes as BasicTypes import qualified Ganeti.JSON as JSON -prop_JSON_toArray :: [Int] -> Property -prop_JSON_toArray intarr = +prop_toArray :: [Int] -> Property +prop_toArray intarr = let arr = map J.showJSON intarr in case JSON.toArray (J.JSArray arr) of BasicTypes.Ok arr' -> arr ==? arr' BasicTypes.Bad err -> failTest $ "Failed to parse array: " ++ err -prop_JSON_toArrayFail :: Int -> String -> Bool -> Property -prop_JSON_toArrayFail i s b = +prop_toArrayFail :: Int -> String -> Bool -> Property +prop_toArrayFail i s b = -- poor man's instance Arbitrary JSValue forAll (elements [J.showJSON i, J.showJSON s, J.showJSON b]) $ \item -> case JSON.toArray item of @@ -54,6 +54,6 @@ prop_JSON_toArrayFail i s b = BasicTypes.Ok result -> failTest $ "Unexpected parse, got " ++ show result testSuite "JSON" - [ 'prop_JSON_toArray - , 'prop_JSON_toArrayFail + [ 'prop_toArray + , 'prop_toArrayFail ] diff --git a/htest/Test/Ganeti/Jobs.hs b/htest/Test/Ganeti/Jobs.hs index f2ada1039c52148d802990beff4849f2355f9ef6..3471c95243dc86fb8fe437ac4ab68e9c8da6020f 100644 --- a/htest/Test/Ganeti/Jobs.hs +++ b/htest/Test/Ganeti/Jobs.hs @@ -48,19 +48,19 @@ instance Arbitrary Jobs.JobStatus where -- * Test cases -- | Check that (queued) job\/opcode status serialization is idempotent. -prop_Jobs_OpStatus_serialization :: Jobs.OpStatus -> Property -prop_Jobs_OpStatus_serialization os = +prop_OpStatus_serialization :: Jobs.OpStatus -> Property +prop_OpStatus_serialization os = case J.readJSON (J.showJSON os) of J.Error e -> failTest $ "Cannot deserialise: " ++ e J.Ok os' -> os ==? os' -prop_Jobs_JobStatus_serialization :: Jobs.JobStatus -> Property -prop_Jobs_JobStatus_serialization js = +prop_JobStatus_serialization :: Jobs.JobStatus -> Property +prop_JobStatus_serialization js = case J.readJSON (J.showJSON js) of J.Error e -> failTest $ "Cannot deserialise: " ++ e J.Ok js' -> js ==? js' testSuite "Jobs" - [ 'prop_Jobs_OpStatus_serialization - , 'prop_Jobs_JobStatus_serialization + [ 'prop_OpStatus_serialization + , 'prop_JobStatus_serialization ] diff --git a/htest/Test/Ganeti/Luxi.hs b/htest/Test/Ganeti/Luxi.hs index b40cf3451eebbcb069686acffde7f0c383109a0b..e36889fe7388115a6779839828f872b17898244d 100644 --- a/htest/Test/Ganeti/Luxi.hs +++ b/htest/Test/Ganeti/Luxi.hs @@ -86,8 +86,8 @@ instance Arbitrary Luxi.LuxiOp where Luxi.ReqSetWatcherPause -> Luxi.SetWatcherPause <$> arbitrary -- | Simple check that encoding/decoding of LuxiOp works. -prop_Luxi_CallEncoding :: Luxi.LuxiOp -> Property -prop_Luxi_CallEncoding op = +prop_CallEncoding :: Luxi.LuxiOp -> Property +prop_CallEncoding op = (Luxi.validateCall (Luxi.buildCall op) >>= Luxi.decodeCall) ==? Ok op -- | Helper to a get a temporary file name. @@ -115,8 +115,8 @@ luxiClientPong c = -- | Monadic check that, given a server socket, we can connect via a -- client to it, and that we can send a list of arbitrary messages and -- get back what we sent. -prop_Luxi_ClientServer :: [[DNSChar]] -> Property -prop_Luxi_ClientServer dnschars = monadicIO $ do +prop_ClientServer :: [[DNSChar]] -> Property +prop_ClientServer dnschars = monadicIO $ do let msgs = map (map dnsGetChar) dnschars fpath <- run $ getTempFileName -- we need to create the server first, otherwise (if we do it in the @@ -137,6 +137,6 @@ prop_Luxi_ClientServer dnschars = monadicIO $ do stop $ replies ==? msgs testSuite "Luxi" - [ 'prop_Luxi_CallEncoding - , 'prop_Luxi_ClientServer + [ 'prop_CallEncoding + , 'prop_ClientServer ] diff --git a/htest/Test/Ganeti/Objects.hs b/htest/Test/Ganeti/Objects.hs index 7baaf70aac74bb56f3dc7ac163fc6865157c9158..5463aef204c63f9baa9dc3d8757f9c7cf6acf605 100644 --- a/htest/Test/Ganeti/Objects.hs +++ b/htest/Test/Ganeti/Objects.hs @@ -55,8 +55,8 @@ instance Arbitrary Objects.Node where <*> (Set.fromList <$> genTags) -- | Tests that fillDict behaves correctly -prop_Objects_fillDict :: [(Int, Int)] -> [(Int, Int)] -> Property -prop_Objects_fillDict defaults custom = +prop_fillDict :: [(Int, Int)] -> [(Int, Int)] -> Property +prop_fillDict defaults custom = let d_map = Map.fromList defaults d_keys = map fst defaults c_map = Map.fromList custom @@ -69,5 +69,5 @@ prop_Objects_fillDict defaults custom = (Objects.fillDict d_map c_map (d_keys++c_keys) == Map.empty) testSuite "Objects" - [ 'prop_Objects_fillDict + [ 'prop_fillDict ] diff --git a/htest/Test/Ganeti/OpCodes.hs b/htest/Test/Ganeti/OpCodes.hs index f4878d3bfbccd421af1b66401ff95a003b8b768b..d184d2104d42cbbc3346c458a9ee3ddb6dba9f6b 100644 --- a/htest/Test/Ganeti/OpCodes.hs +++ b/htest/Test/Ganeti/OpCodes.hs @@ -73,15 +73,15 @@ instance Arbitrary OpCodes.OpCode where -- * Test cases -- | Check that opcode serialization is idempotent. -prop_OpCodes_serialization :: OpCodes.OpCode -> Property -prop_OpCodes_serialization op = +prop_serialization :: OpCodes.OpCode -> Property +prop_serialization op = case J.readJSON (J.showJSON op) of J.Error e -> failTest $ "Cannot deserialise: " ++ e J.Ok op' -> op ==? op' -- | Check that Python and Haskell defined the same opcode list. -case_OpCodes_AllDefined :: HUnit.Assertion -case_OpCodes_AllDefined = do +case_AllDefined :: HUnit.Assertion +case_AllDefined = do py_stdout <- runPython "from ganeti import opcodes\n\ \print '\\n'.join(opcodes.OP_MAPPING.keys())" "" >>= checkPythonResult @@ -111,8 +111,8 @@ case_OpCodes_AllDefined = do -- a better way to do this, for example by having a -- separately-launched Python process (if not running the tests would -- be skipped). -case_OpCodes_py_compat :: HUnit.Assertion -case_OpCodes_py_compat = do +case_py_compat :: HUnit.Assertion +case_py_compat = do let num_opcodes = length OpCodes.allOpIDs * 500 sample_opcodes <- sample' (vectorOf num_opcodes (arbitrary::Gen OpCodes.OpCode)) @@ -143,7 +143,7 @@ case_OpCodes_py_compat = do ) $ zip opcodes decoded testSuite "OpCodes" - [ 'prop_OpCodes_serialization - , 'case_OpCodes_AllDefined - , 'case_OpCodes_py_compat + [ 'prop_serialization + , 'case_AllDefined + , 'case_py_compat ] diff --git a/htest/Test/Ganeti/Query/Language.hs b/htest/Test/Ganeti/Query/Language.hs index 8c33e24a04c6eb6680eaa26e90aee560fb77d7a8..e2be6796c0f691a49fd15d1dea0fa44f4b77d2e9 100644 --- a/htest/Test/Ganeti/Query/Language.hs +++ b/htest/Test/Ganeti/Query/Language.hs @@ -81,18 +81,18 @@ instance Arbitrary Qlang.FilterRegex where -- | Tests that serialisation/deserialisation of filters is -- idempotent. -prop_Qlang_Serialisation :: Property -prop_Qlang_Serialisation = +prop_Serialisation :: Property +prop_Serialisation = forAll genFilter $ \flt -> J.readJSON (J.showJSON flt) ==? J.Ok flt -prop_Qlang_FilterRegex_instances :: Qlang.FilterRegex -> Property -prop_Qlang_FilterRegex_instances rex = +prop_FilterRegex_instances :: Qlang.FilterRegex -> Property +prop_FilterRegex_instances rex = printTestCase "failed JSON encoding" (J.readJSON (J.showJSON rex) ==? J.Ok rex) .&&. printTestCase "failed read/show instances" (read (show rex) ==? rex) testSuite "Qlang" - [ 'prop_Qlang_Serialisation - , 'prop_Qlang_FilterRegex_instances + [ 'prop_Serialisation + , 'prop_FilterRegex_instances ] diff --git a/htest/Test/Ganeti/Rpc.hs b/htest/Test/Ganeti/Rpc.hs index 618ea9cf41023e53c7f3bffbcd73991fbdd27388..34e8e6142fae75afbddea45f15c4a108911233b4 100644 --- a/htest/Test/Ganeti/Rpc.hs +++ b/htest/Test/Ganeti/Rpc.hs @@ -53,26 +53,26 @@ instance Arbitrary Rpc.RpcCallNodeInfo where -- offline nodes, we get a OfflineNodeError response. -- FIXME: We need a way of generalizing this, running it for -- every call manually will soon get problematic -prop_Rpc_noffl_request_allinstinfo :: Rpc.RpcCallAllInstancesInfo -> Property -prop_Rpc_noffl_request_allinstinfo call = +prop_noffl_request_allinstinfo :: Rpc.RpcCallAllInstancesInfo -> Property +prop_noffl_request_allinstinfo call = forAll (arbitrary `suchThat` Objects.nodeOffline) $ \node -> monadicIO $ do res <- run $ Rpc.executeRpcCall [node] call stop $ res ==? [(node, Left (Rpc.OfflineNodeError node))] -prop_Rpc_noffl_request_instlist :: Rpc.RpcCallInstanceList -> Property -prop_Rpc_noffl_request_instlist call = +prop_noffl_request_instlist :: Rpc.RpcCallInstanceList -> Property +prop_noffl_request_instlist call = forAll (arbitrary `suchThat` Objects.nodeOffline) $ \node -> monadicIO $ do res <- run $ Rpc.executeRpcCall [node] call stop $ res ==? [(node, Left (Rpc.OfflineNodeError node))] -prop_Rpc_noffl_request_nodeinfo :: Rpc.RpcCallNodeInfo -> Property -prop_Rpc_noffl_request_nodeinfo call = +prop_noffl_request_nodeinfo :: Rpc.RpcCallNodeInfo -> Property +prop_noffl_request_nodeinfo call = forAll (arbitrary `suchThat` Objects.nodeOffline) $ \node -> monadicIO $ do res <- run $ Rpc.executeRpcCall [node] call stop $ res ==? [(node, Left (Rpc.OfflineNodeError node))] testSuite "Rpc" - [ 'prop_Rpc_noffl_request_allinstinfo - , 'prop_Rpc_noffl_request_instlist - , 'prop_Rpc_noffl_request_nodeinfo + [ 'prop_noffl_request_allinstinfo + , 'prop_noffl_request_instlist + , 'prop_noffl_request_nodeinfo ] diff --git a/htest/Test/Ganeti/Ssconf.hs b/htest/Test/Ganeti/Ssconf.hs index 8139e2dd8dfd41c35cc9759044979defb7281969..0b8695026ed3b2c8d4c8528aa8bfae308d7f83b4 100644 --- a/htest/Test/Ganeti/Ssconf.hs +++ b/htest/Test/Ganeti/Ssconf.hs @@ -41,11 +41,11 @@ import qualified Ganeti.Ssconf as Ssconf instance Arbitrary Ssconf.SSKey where arbitrary = elements [minBound..maxBound] -prop_Ssconf_filename :: Ssconf.SSKey -> Property -prop_Ssconf_filename key = +prop_filename :: Ssconf.SSKey -> Property +prop_filename key = printTestCase "Key doesn't start with correct prefix" $ Ssconf.sSFilePrefix `isPrefixOf` Ssconf.keyToFilename (Just "") key testSuite "Ssconf" - [ 'prop_Ssconf_filename + [ 'prop_filename ] diff --git a/htest/Test/Ganeti/TestHelper.hs b/htest/Test/Ganeti/TestHelper.hs index ad0aaa2d2125422804263cdea64292440b01c3be..6b524c8a21781bc8ad5b16b4b270fcc05e3d0fc0 100644 --- a/htest/Test/Ganeti/TestHelper.hs +++ b/htest/Test/Ganeti/TestHelper.hs @@ -38,35 +38,43 @@ import Test.HUnit (Assertion) import Test.QuickCheck import Language.Haskell.TH +-- | Test property prefix. +propPrefix :: String +propPrefix = "prop_" + +-- | Test case prefix. +casePrefix :: String +casePrefix = "case_" + -- | Tries to drop a prefix from a string. simplifyName :: String -> String -> String simplifyName pfx string = fromMaybe string (stripPrefix pfx string) -- | Builds a test from a QuickCheck property. -runQC :: Testable prop => String -> String -> prop -> Test -runQC pfx name = testProperty (simplifyName ("prop_" ++ pfx ++ "_") name) +runProp :: Testable prop => String -> prop -> Test +runProp = testProperty . simplifyName propPrefix -- | Builds a test for a HUnit test case. -runHUnit :: String -> String -> Assertion -> Test -runHUnit pfx name = testCase (simplifyName ("case_" ++ pfx ++ "_") name) +runCase :: String -> Assertion -> Test +runCase = testCase . simplifyName casePrefix -- | Runs the correct test provider for a given test, based on its -- name (not very nice, but...). -run :: String -> Name -> Q Exp -run tsname name = +run :: Name -> Q Exp +run name = let str = nameBase name nameE = varE name strE = litE (StringL str) in case () of - _ | "prop_" `isPrefixOf` str -> [| runQC tsname $strE $nameE |] - | "case_" `isPrefixOf` str -> [| runHUnit tsname $strE $nameE |] + _ | propPrefix `isPrefixOf` str -> [| runProp $strE $nameE |] + | casePrefix `isPrefixOf` str -> [| runCase $strE $nameE |] | otherwise -> fail $ "Unsupported test function name '" ++ str ++ "'" -- | Builds a test suite. testSuite :: String -> [Name] -> Q [Dec] testSuite tsname tdef = do let fullname = mkName $ "test" ++ tsname - tests <- mapM (run tsname) tdef + tests <- mapM run tdef sigtype <- [t| (String, [Test]) |] return [ SigD fullname sigtype , ValD (VarP fullname) (NormalB (TupE [LitE (StringL tsname),