Revision aed2325f htools/Ganeti/HTools/QC.hs
b/htools/Ganeti/HTools/QC.hs | ||
---|---|---|
39 | 39 |
, testNode |
40 | 40 |
, testText |
41 | 41 |
, testSimu |
42 |
, testOpCodes |
|
43 | 42 |
, testJobs |
44 | 43 |
, testCluster |
45 | 44 |
, testLoader |
46 | 45 |
, testTypes |
47 | 46 |
, testCLI |
48 | 47 |
, testJSON |
49 |
, testLuxi |
|
50 |
, testSsconf |
|
51 |
, testQlang |
|
52 | 48 |
) where |
53 | 49 |
|
54 | 50 |
import qualified Test.HUnit as HUnit |
... | ... | |
87 | 83 |
import qualified Ganeti.OpCodes as OpCodes |
88 | 84 |
import qualified Ganeti.Query.Language as Qlang |
89 | 85 |
import qualified Ganeti.Runtime as Runtime |
90 |
import qualified Ganeti.Ssconf as Ssconf |
|
91 | 86 |
import qualified Ganeti.HTools.CLI as CLI |
92 | 87 |
import qualified Ganeti.HTools.Cluster as Cluster |
93 | 88 |
import qualified Ganeti.HTools.Container as Container |
... | ... | |
170 | 165 |
isFailure (Types.OpFail _) = True |
171 | 166 |
isFailure _ = False |
172 | 167 |
|
173 |
-- | Return the python binary to use. If the PYTHON environment |
|
174 |
-- variable is defined, use its value, otherwise use just \"python\". |
|
175 |
pythonCmd :: IO String |
|
176 |
pythonCmd = catchJust (guard . isDoesNotExistError) |
|
177 |
(getEnv "PYTHON") (const (return "python")) |
|
178 |
|
|
179 |
-- | Run Python with an expression, returning the exit code, standard |
|
180 |
-- output and error. |
|
181 |
runPython :: String -> String -> IO (ExitCode, String, String) |
|
182 |
runPython expr stdin = do |
|
183 |
py_binary <- pythonCmd |
|
184 |
readProcessWithExitCode py_binary ["-c", expr] stdin |
|
185 |
|
|
186 |
-- | Check python exit code, and fail via HUnit assertions if |
|
187 |
-- non-zero. Otherwise, return the standard output. |
|
188 |
checkPythonResult :: (ExitCode, String, String) -> IO String |
|
189 |
checkPythonResult (py_code, py_stdout, py_stderr) = do |
|
190 |
HUnit.assertEqual ("python exited with error: " ++ py_stderr) |
|
191 |
ExitSuccess py_code |
|
192 |
return py_stdout |
|
193 |
|
|
194 | 168 |
-- | Update an instance to be smaller than a node. |
195 | 169 |
setInstanceSmallerThanNode :: Node.Node |
196 | 170 |
-> Instance.Instance -> Instance.Instance |
... | ... | |
271 | 245 |
evacModeOptions Types.MirrorInternal = [minBound..maxBound] -- DRBD can do all |
272 | 246 |
evacModeOptions Types.MirrorExternal = [Types.ChangePrimary, Types.ChangeAll] |
273 | 247 |
|
274 |
-- | Generates a fields list. This uses the same character set as a |
|
275 |
-- DNS name (just for simplicity). |
|
276 |
getFields :: Gen [String] |
|
277 |
getFields = do |
|
278 |
n <- choose (1, 32) |
|
279 |
vectorOf n getName |
|
280 |
|
|
281 | 248 |
instance Arbitrary Types.InstanceStatus where |
282 | 249 |
arbitrary = elements [minBound..maxBound] |
283 | 250 |
|
... | ... | |
349 | 316 |
instance Arbitrary Node.Node where |
350 | 317 |
arbitrary = genNode Nothing Nothing |
351 | 318 |
|
352 |
-- replace disks |
|
353 |
instance Arbitrary OpCodes.ReplaceDisksMode where |
|
354 |
arbitrary = elements [minBound..maxBound] |
|
355 |
|
|
356 |
instance Arbitrary OpCodes.DiskIndex where |
|
357 |
arbitrary = choose (0, C.maxDisks - 1) >>= OpCodes.mkDiskIndex |
|
358 |
|
|
359 |
instance Arbitrary OpCodes.OpCode where |
|
360 |
arbitrary = do |
|
361 |
op_id <- elements OpCodes.allOpIDs |
|
362 |
case op_id of |
|
363 |
"OP_TEST_DELAY" -> |
|
364 |
OpCodes.OpTestDelay <$> arbitrary <*> arbitrary |
|
365 |
<*> resize maxNodes (listOf getFQDN) |
|
366 |
"OP_INSTANCE_REPLACE_DISKS" -> |
|
367 |
OpCodes.OpInstanceReplaceDisks <$> getFQDN <*> getMaybe getFQDN <*> |
|
368 |
arbitrary <*> resize C.maxDisks arbitrary <*> getMaybe getName |
|
369 |
"OP_INSTANCE_FAILOVER" -> |
|
370 |
OpCodes.OpInstanceFailover <$> getFQDN <*> arbitrary <*> |
|
371 |
getMaybe getFQDN |
|
372 |
"OP_INSTANCE_MIGRATE" -> |
|
373 |
OpCodes.OpInstanceMigrate <$> getFQDN <*> arbitrary <*> |
|
374 |
arbitrary <*> arbitrary <*> getMaybe getFQDN |
|
375 |
_ -> fail "Wrong opcode" |
|
376 |
|
|
377 | 319 |
instance Arbitrary Jobs.OpStatus where |
378 | 320 |
arbitrary = elements [minBound..maxBound] |
379 | 321 |
|
... | ... | |
454 | 396 |
, Types.iPolicySpindleRatio = spindle_ratio |
455 | 397 |
} |
456 | 398 |
|
457 |
-- | Custom 'Qlang.Filter' generator (top-level), which enforces a |
|
458 |
-- (sane) limit on the depth of the generated filters. |
|
459 |
genFilter :: Gen (Qlang.Filter Qlang.FilterField) |
|
460 |
genFilter = choose (0, 10) >>= genFilter' |
|
461 |
|
|
462 |
-- | Custom generator for filters that correctly halves the state of |
|
463 |
-- the generators at each recursive step, per the QuickCheck |
|
464 |
-- documentation, in order not to run out of memory. |
|
465 |
genFilter' :: Int -> Gen (Qlang.Filter Qlang.FilterField) |
|
466 |
genFilter' 0 = |
|
467 |
oneof [ return Qlang.EmptyFilter |
|
468 |
, Qlang.TrueFilter <$> getName |
|
469 |
, Qlang.EQFilter <$> getName <*> value |
|
470 |
, Qlang.LTFilter <$> getName <*> value |
|
471 |
, Qlang.GTFilter <$> getName <*> value |
|
472 |
, Qlang.LEFilter <$> getName <*> value |
|
473 |
, Qlang.GEFilter <$> getName <*> value |
|
474 |
, Qlang.RegexpFilter <$> getName <*> arbitrary |
|
475 |
, Qlang.ContainsFilter <$> getName <*> value |
|
476 |
] |
|
477 |
where value = oneof [ Qlang.QuotedString <$> getName |
|
478 |
, Qlang.NumericValue <$> arbitrary |
|
479 |
] |
|
480 |
genFilter' n = do |
|
481 |
oneof [ Qlang.AndFilter <$> vectorOf n'' (genFilter' n') |
|
482 |
, Qlang.OrFilter <$> vectorOf n'' (genFilter' n') |
|
483 |
, Qlang.NotFilter <$> genFilter' n' |
|
484 |
] |
|
485 |
where n' = n `div` 2 -- sub-filter generator size |
|
486 |
n'' = max n' 2 -- but we don't want empty or 1-element lists, |
|
487 |
-- so use this for and/or filter list length |
|
488 |
|
|
489 |
instance Arbitrary Qlang.ItemType where |
|
490 |
arbitrary = elements [minBound..maxBound] |
|
491 |
|
|
492 |
instance Arbitrary Qlang.FilterRegex where |
|
493 |
arbitrary = getName >>= Qlang.mkRegex -- a name should be a good regex |
|
494 |
|
|
495 | 399 |
-- * Actual tests |
496 | 400 |
|
497 | 401 |
-- ** Utils tests |
... | ... | |
1484 | 1388 |
, 'prop_Cluster_AllocPolicy |
1485 | 1389 |
] |
1486 | 1390 |
|
1487 |
-- ** OpCodes tests |
|
1488 |
|
|
1489 |
-- | Check that opcode serialization is idempotent. |
|
1490 |
prop_OpCodes_serialization :: OpCodes.OpCode -> Property |
|
1491 |
prop_OpCodes_serialization op = |
|
1492 |
case J.readJSON (J.showJSON op) of |
|
1493 |
J.Error e -> failTest $ "Cannot deserialise: " ++ e |
|
1494 |
J.Ok op' -> op ==? op' |
|
1495 |
|
|
1496 |
-- | Check that Python and Haskell defined the same opcode list. |
|
1497 |
case_OpCodes_AllDefined :: HUnit.Assertion |
|
1498 |
case_OpCodes_AllDefined = do |
|
1499 |
py_stdout <- runPython "from ganeti import opcodes\n\ |
|
1500 |
\print '\\n'.join(opcodes.OP_MAPPING.keys())" "" >>= |
|
1501 |
checkPythonResult |
|
1502 |
let py_ops = sort $ lines py_stdout |
|
1503 |
hs_ops = OpCodes.allOpIDs |
|
1504 |
-- extra_py = py_ops \\ hs_ops |
|
1505 |
extra_hs = hs_ops \\ py_ops |
|
1506 |
-- FIXME: uncomment when we have parity |
|
1507 |
-- HUnit.assertBool ("OpCodes missing from Haskell code:\n" ++ |
|
1508 |
-- unlines extra_py) (null extra_py) |
|
1509 |
HUnit.assertBool ("Extra OpCodes in the Haskell code code:\n" ++ |
|
1510 |
unlines extra_hs) (null extra_hs) |
|
1511 |
|
|
1512 |
-- | Custom HUnit test case that forks a Python process and checks |
|
1513 |
-- correspondence between Haskell-generated OpCodes and their Python |
|
1514 |
-- decoded, validated and re-encoded version. |
|
1515 |
-- |
|
1516 |
-- Note that we have a strange beast here: since launching Python is |
|
1517 |
-- expensive, we don't do this via a usual QuickProperty, since that's |
|
1518 |
-- slow (I've tested it, and it's indeed quite slow). Rather, we use a |
|
1519 |
-- single HUnit assertion, and in it we manually use QuickCheck to |
|
1520 |
-- generate 500 opcodes times the number of defined opcodes, which |
|
1521 |
-- then we pass in bulk to Python. The drawbacks to this method are |
|
1522 |
-- two fold: we cannot control the number of generated opcodes, since |
|
1523 |
-- HUnit assertions don't get access to the test options, and for the |
|
1524 |
-- same reason we can't run a repeatable seed. We should probably find |
|
1525 |
-- a better way to do this, for example by having a |
|
1526 |
-- separately-launched Python process (if not running the tests would |
|
1527 |
-- be skipped). |
|
1528 |
case_OpCodes_py_compat :: HUnit.Assertion |
|
1529 |
case_OpCodes_py_compat = do |
|
1530 |
let num_opcodes = length OpCodes.allOpIDs * 500 |
|
1531 |
sample_opcodes <- sample' (vectorOf num_opcodes |
|
1532 |
(arbitrary::Gen OpCodes.OpCode)) |
|
1533 |
let opcodes = head sample_opcodes |
|
1534 |
serialized = J.encode opcodes |
|
1535 |
py_stdout <- |
|
1536 |
runPython "from ganeti import opcodes\n\ |
|
1537 |
\import sys\n\ |
|
1538 |
\from ganeti import serializer\n\ |
|
1539 |
\op_data = serializer.Load(sys.stdin.read())\n\ |
|
1540 |
\decoded = [opcodes.OpCode.LoadOpCode(o) for o in op_data]\n\ |
|
1541 |
\for op in decoded:\n\ |
|
1542 |
\ op.Validate(True)\n\ |
|
1543 |
\encoded = [op.__getstate__() for op in decoded]\n\ |
|
1544 |
\print serializer.Dump(encoded)" serialized |
|
1545 |
>>= checkPythonResult |
|
1546 |
let deserialised = (J.decode py_stdout::J.Result [OpCodes.OpCode]) |
|
1547 |
decoded <- case deserialised of |
|
1548 |
J.Ok ops -> return ops |
|
1549 |
J.Error msg -> |
|
1550 |
HUnit.assertFailure ("Unable to decode opcodes: " ++ msg) |
|
1551 |
-- this already raised an expection, but we need it |
|
1552 |
-- for proper types |
|
1553 |
>> fail "Unable to decode opcodes" |
|
1554 |
HUnit.assertEqual "Mismatch in number of returned opcodes" |
|
1555 |
(length opcodes) (length decoded) |
|
1556 |
mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding") |
|
1557 |
) $ zip opcodes decoded |
|
1558 |
|
|
1559 |
testSuite "OpCodes" |
|
1560 |
[ 'prop_OpCodes_serialization |
|
1561 |
, 'case_OpCodes_AllDefined |
|
1562 |
, 'case_OpCodes_py_compat |
|
1563 |
] |
|
1564 |
|
|
1565 | 1391 |
-- ** Jobs tests |
1566 | 1392 |
|
1567 | 1393 |
-- | Check that (queued) job\/opcode status serialization is idempotent. |
... | ... | |
1809 | 1635 |
[ 'prop_JSON_toArray |
1810 | 1636 |
, 'prop_JSON_toArrayFail |
1811 | 1637 |
] |
1812 |
|
|
1813 |
-- * Luxi tests |
|
1814 |
|
|
1815 |
instance Arbitrary Luxi.TagObject where |
|
1816 |
arbitrary = elements [minBound..maxBound] |
|
1817 |
|
|
1818 |
instance Arbitrary Luxi.LuxiReq where |
|
1819 |
arbitrary = elements [minBound..maxBound] |
|
1820 |
|
|
1821 |
instance Arbitrary Luxi.LuxiOp where |
|
1822 |
arbitrary = do |
|
1823 |
lreq <- arbitrary |
|
1824 |
case lreq of |
|
1825 |
Luxi.ReqQuery -> Luxi.Query <$> arbitrary <*> getFields <*> genFilter |
|
1826 |
Luxi.ReqQueryFields -> Luxi.QueryFields <$> arbitrary <*> getFields |
|
1827 |
Luxi.ReqQueryNodes -> Luxi.QueryNodes <$> (listOf getFQDN) <*> |
|
1828 |
getFields <*> arbitrary |
|
1829 |
Luxi.ReqQueryGroups -> Luxi.QueryGroups <$> arbitrary <*> |
|
1830 |
arbitrary <*> arbitrary |
|
1831 |
Luxi.ReqQueryInstances -> Luxi.QueryInstances <$> (listOf getFQDN) <*> |
|
1832 |
getFields <*> arbitrary |
|
1833 |
Luxi.ReqQueryJobs -> Luxi.QueryJobs <$> arbitrary <*> getFields |
|
1834 |
Luxi.ReqQueryExports -> Luxi.QueryExports <$> |
|
1835 |
(listOf getFQDN) <*> arbitrary |
|
1836 |
Luxi.ReqQueryConfigValues -> Luxi.QueryConfigValues <$> getFields |
|
1837 |
Luxi.ReqQueryClusterInfo -> pure Luxi.QueryClusterInfo |
|
1838 |
Luxi.ReqQueryTags -> Luxi.QueryTags <$> arbitrary <*> getFQDN |
|
1839 |
Luxi.ReqSubmitJob -> Luxi.SubmitJob <$> (resize maxOpCodes arbitrary) |
|
1840 |
Luxi.ReqSubmitManyJobs -> Luxi.SubmitManyJobs <$> |
|
1841 |
(resize maxOpCodes arbitrary) |
|
1842 |
Luxi.ReqWaitForJobChange -> Luxi.WaitForJobChange <$> arbitrary <*> |
|
1843 |
getFields <*> pure J.JSNull <*> |
|
1844 |
pure J.JSNull <*> arbitrary |
|
1845 |
Luxi.ReqArchiveJob -> Luxi.ArchiveJob <$> arbitrary |
|
1846 |
Luxi.ReqAutoArchiveJobs -> Luxi.AutoArchiveJobs <$> arbitrary <*> |
|
1847 |
arbitrary |
|
1848 |
Luxi.ReqCancelJob -> Luxi.CancelJob <$> arbitrary |
|
1849 |
Luxi.ReqSetDrainFlag -> Luxi.SetDrainFlag <$> arbitrary |
|
1850 |
Luxi.ReqSetWatcherPause -> Luxi.SetWatcherPause <$> arbitrary |
|
1851 |
|
|
1852 |
-- | Simple check that encoding/decoding of LuxiOp works. |
|
1853 |
prop_Luxi_CallEncoding :: Luxi.LuxiOp -> Property |
|
1854 |
prop_Luxi_CallEncoding op = |
|
1855 |
(Luxi.validateCall (Luxi.buildCall op) >>= Luxi.decodeCall) ==? Types.Ok op |
|
1856 |
|
|
1857 |
-- | Helper to a get a temporary file name. |
|
1858 |
getTempFileName :: IO FilePath |
|
1859 |
getTempFileName = do |
|
1860 |
tempdir <- getTemporaryDirectory |
|
1861 |
(fpath, handle) <- openTempFile tempdir "luxitest" |
|
1862 |
_ <- hClose handle |
|
1863 |
removeFile fpath |
|
1864 |
return fpath |
|
1865 |
|
|
1866 |
-- | Server ping-pong helper. |
|
1867 |
luxiServerPong :: Luxi.Client -> IO () |
|
1868 |
luxiServerPong c = do |
|
1869 |
msg <- Luxi.recvMsgExt c |
|
1870 |
case msg of |
|
1871 |
Luxi.RecvOk m -> Luxi.sendMsg c m >> luxiServerPong c |
|
1872 |
_ -> return () |
|
1873 |
|
|
1874 |
-- | Client ping-pong helper. |
|
1875 |
luxiClientPong :: Luxi.Client -> [String] -> IO [String] |
|
1876 |
luxiClientPong c = |
|
1877 |
mapM (\m -> Luxi.sendMsg c m >> Luxi.recvMsg c) |
|
1878 |
|
|
1879 |
-- | Monadic check that, given a server socket, we can connect via a |
|
1880 |
-- client to it, and that we can send a list of arbitrary messages and |
|
1881 |
-- get back what we sent. |
|
1882 |
prop_Luxi_ClientServer :: [[DNSChar]] -> Property |
|
1883 |
prop_Luxi_ClientServer dnschars = monadicIO $ do |
|
1884 |
let msgs = map (map dnsGetChar) dnschars |
|
1885 |
fpath <- run $ getTempFileName |
|
1886 |
-- we need to create the server first, otherwise (if we do it in the |
|
1887 |
-- forked thread) the client could try to connect to it before it's |
|
1888 |
-- ready |
|
1889 |
server <- run $ Luxi.getServer fpath |
|
1890 |
-- fork the server responder |
|
1891 |
_ <- run . forkIO $ |
|
1892 |
bracket |
|
1893 |
(Luxi.acceptClient server) |
|
1894 |
(\c -> Luxi.closeClient c >> Luxi.closeServer fpath server) |
|
1895 |
luxiServerPong |
|
1896 |
replies <- run $ |
|
1897 |
bracket |
|
1898 |
(Luxi.getClient fpath) |
|
1899 |
Luxi.closeClient |
|
1900 |
(\c -> luxiClientPong c msgs) |
|
1901 |
assert $ replies == msgs |
|
1902 |
|
|
1903 |
testSuite "Luxi" |
|
1904 |
[ 'prop_Luxi_CallEncoding |
|
1905 |
, 'prop_Luxi_ClientServer |
|
1906 |
] |
|
1907 |
|
|
1908 |
-- * Ssconf tests |
|
1909 |
|
|
1910 |
instance Arbitrary Ssconf.SSKey where |
|
1911 |
arbitrary = elements [minBound..maxBound] |
|
1912 |
|
|
1913 |
prop_Ssconf_filename :: Ssconf.SSKey -> Property |
|
1914 |
prop_Ssconf_filename key = |
|
1915 |
printTestCase "Key doesn't start with correct prefix" $ |
|
1916 |
Ssconf.sSFilePrefix `isPrefixOf` Ssconf.keyToFilename (Just "") key |
|
1917 |
|
|
1918 |
testSuite "Ssconf" |
|
1919 |
[ 'prop_Ssconf_filename |
|
1920 |
] |
|
1921 |
|
|
1922 |
-- * Qlang tests |
|
1923 |
|
|
1924 |
-- | Tests that serialisation/deserialisation of filters is |
|
1925 |
-- idempotent. |
|
1926 |
prop_Qlang_Serialisation :: Property |
|
1927 |
prop_Qlang_Serialisation = |
|
1928 |
forAll genFilter $ \flt -> |
|
1929 |
J.readJSON (J.showJSON flt) ==? J.Ok flt |
|
1930 |
|
|
1931 |
prop_Qlang_FilterRegex_instances :: Qlang.FilterRegex -> Property |
|
1932 |
prop_Qlang_FilterRegex_instances rex = |
|
1933 |
printTestCase "failed JSON encoding" |
|
1934 |
(J.readJSON (J.showJSON rex) ==? J.Ok rex) .&&. |
|
1935 |
printTestCase "failed read/show instances" (read (show rex) ==? rex) |
|
1936 |
|
|
1937 |
testSuite "Qlang" |
|
1938 |
[ 'prop_Qlang_Serialisation |
|
1939 |
, 'prop_Qlang_FilterRegex_instances |
|
1940 |
] |
Also available in: Unified diff