diff --git a/htest/Test/Ganeti/HTools/CLI.hs b/htest/Test/Ganeti/HTools/CLI.hs index b64e6ff127ce0b126ffc5542ea0c3a4cd90f988c..239dae9acc85a44094a8f5581b9c8ca0de4da59e 100644 --- a/htest/Test/Ganeti/HTools/CLI.hs +++ b/htest/Test/Ganeti/HTools/CLI.hs @@ -56,7 +56,7 @@ prop_parseISpecFail descr = let str = intercalate "," $ map show (values::[Int]) in case CLI.parseISpecString descr str of Types.Ok v -> failTest $ "Expected failure, got " ++ show v - _ -> property True + _ -> passTest -- | Test parseYesNo. prop_parseYesNo :: Bool -> Bool -> [Char] -> Property @@ -99,11 +99,10 @@ prop_StringArg argument = checkEarlyExit :: String -> [CLI.OptType] -> String -> Property checkEarlyExit name options param = case CLI.parseOptsInner [param] name options of - Left (code, _) -> if code == 0 - then property True - else failTest $ "Program " ++ name ++ - " returns invalid code " ++ show code ++ - " for option " ++ param + Left (code, _) -> + printTestCase ("Program " ++ name ++ + " returns invalid code " ++ show code ++ + " for option " ++ param) (code == 0) _ -> failTest $ "Program " ++ name ++ " doesn't consider option " ++ param ++ " as early exit one" diff --git a/htest/Test/Ganeti/HTools/Cluster.hs b/htest/Test/Ganeti/HTools/Cluster.hs index c26560ef71c5f658bdf63879d37a01137d9d103a..a779a521644a0a07ce358f41cb6926d844c4bfc8 100644 --- a/htest/Test/Ganeti/HTools/Cluster.hs +++ b/htest/Test/Ganeti/HTools/Cluster.hs @@ -206,7 +206,7 @@ prop_AllocRelocate = [(if Instance.diskTemplate inst' == Types.DTDrbd8 then Instance.sNode else Instance.pNode) inst'] of - Types.Ok _ -> property True + Types.Ok _ -> passTest Types.Bad msg -> failTest $ "Failed to relocate: " ++ msg -- | Helper property checker for the result of a nodeEvac or diff --git a/htest/Test/Ganeti/HTools/Node.hs b/htest/Test/Ganeti/HTools/Node.hs index a437e6428f2e0429d6ae83224fd80f6ef1ed9a91..ddf6a994499f2ffa591a5fb680e8b264a7ce1076 100644 --- a/htest/Test/Ganeti/HTools/Node.hs +++ b/htest/Test/Ganeti/HTools/Node.hs @@ -154,7 +154,7 @@ prop_addPriFC = let inst' = setInstanceSmallerThanNode node inst inst'' = inst' { Instance.vcpus = Node.availCpu node + extra } in case Node.addPri node inst'' of - Types.OpFail Types.FailCPU -> property True + Types.OpFail Types.FailCPU -> passTest v -> failTest $ "Expected OpFail FailCPU, but got " ++ show v -- | Check that an instance add with too high memory or disk will be @@ -177,7 +177,7 @@ prop_addOfflinePri (NonNegative extra_mem) (NonNegative extra_cpu) = , Instance.mem = Node.availMem node + extra_mem , Instance.vcpus = Node.availCpu node + extra_cpu } in case Node.addPri node inst' of - Types.OpGood _ -> property True + Types.OpGood _ -> passTest v -> failTest $ "Expected OpGood, but got: " ++ show v -- | Check that an offline instance with reasonable disk size but @@ -192,7 +192,7 @@ prop_addOfflineSec (NonNegative extra_mem) (NonNegative extra_cpu) pdx = , Instance.vcpus = Node.availCpu node + extra_cpu , Instance.diskTemplate = Types.DTDrbd8 } in case Node.addSec node inst' pdx of - Types.OpGood _ -> property True + Types.OpGood _ -> passTest v -> failTest $ "Expected OpGood/OpGood, but got: " ++ show v -- | Checks for memory reservation changes. diff --git a/htest/Test/Ganeti/JSON.hs b/htest/Test/Ganeti/JSON.hs index 0ad22ff73dfcb3107b16810e8acaa6e9e19000d4..627952072ea90941c6ecdb3b9da73d20c6d00e7e 100644 --- a/htest/Test/Ganeti/JSON.hs +++ b/htest/Test/Ganeti/JSON.hs @@ -50,7 +50,7 @@ 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 - BasicTypes.Bad _ -> property True + BasicTypes.Bad _ -> passTest BasicTypes.Ok result -> failTest $ "Unexpected parse, got " ++ show result testSuite "JSON" diff --git a/htest/Test/Ganeti/TestCommon.hs b/htest/Test/Ganeti/TestCommon.hs index 8d99d3e8885303181d0f2bce25d66c9db1357b3d..5a244e1120d42f9f3a74535c901e2941315c648b 100644 --- a/htest/Test/Ganeti/TestCommon.hs +++ b/htest/Test/Ganeti/TestCommon.hs @@ -81,6 +81,10 @@ infix 3 ==? failTest :: String -> Property failTest msg = printTestCase msg False +-- | A 'True' property. +passTest :: Property +passTest = property True + -- | Return the python binary to use. If the PYTHON environment -- variable is defined, use its value, otherwise use just \"python\". pythonCmd :: IO String