root / htest / Test / Ganeti / Objects.hs @ 0f0d7aba
History | View | Annotate | Download (12.2 kB)
1 |
{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-} |
---|---|
2 |
{-# OPTIONS_GHC -fno-warn-orphans #-} |
3 |
|
4 |
{-| Unittests for ganeti-htools. |
5 |
|
6 |
-} |
7 |
|
8 |
{- |
9 |
|
10 |
Copyright (C) 2009, 2010, 2011, 2012 Google Inc. |
11 |
|
12 |
This program is free software; you can redistribute it and/or modify |
13 |
it under the terms of the GNU General Public License as published by |
14 |
the Free Software Foundation; either version 2 of the License, or |
15 |
(at your option) any later version. |
16 |
|
17 |
This program is distributed in the hope that it will be useful, but |
18 |
WITHOUT ANY WARRANTY; without even the implied warranty of |
19 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
20 |
General Public License for more details. |
21 |
|
22 |
You should have received a copy of the GNU General Public License |
23 |
along with this program; if not, write to the Free Software |
24 |
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
25 |
02110-1301, USA. |
26 |
|
27 |
-} |
28 |
|
29 |
module Test.Ganeti.Objects |
30 |
( testObjects |
31 |
, Node(..) |
32 |
, genEmptyCluster |
33 |
, genValidNetwork |
34 |
, genNetworkType |
35 |
, genBitStringMaxLen |
36 |
) where |
37 |
|
38 |
import Test.QuickCheck |
39 |
import qualified Test.HUnit as HUnit |
40 |
|
41 |
import Control.Applicative |
42 |
import Control.Monad |
43 |
import Data.Char |
44 |
import qualified Data.Map as Map |
45 |
import qualified Data.Set as Set |
46 |
import qualified Text.JSON as J |
47 |
|
48 |
import Test.Ganeti.Query.Language (genJSValue) |
49 |
import Test.Ganeti.TestHelper |
50 |
import Test.Ganeti.TestCommon |
51 |
import Test.Ganeti.Types () |
52 |
|
53 |
import qualified Ganeti.Constants as C |
54 |
import Ganeti.Network |
55 |
import Ganeti.Objects as Objects |
56 |
import Ganeti.JSON |
57 |
import Ganeti.Types |
58 |
|
59 |
{-# ANN module "HLint: ignore Use camelCase" #-} |
60 |
|
61 |
-- * Arbitrary instances |
62 |
|
63 |
$(genArbitrary ''PartialNDParams) |
64 |
|
65 |
instance Arbitrary Node where |
66 |
arbitrary = Node <$> genFQDN <*> genFQDN <*> genFQDN |
67 |
<*> arbitrary <*> arbitrary <*> arbitrary <*> genFQDN |
68 |
<*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary |
69 |
<*> arbitrary <*> arbitrary <*> genFQDN <*> arbitrary |
70 |
<*> (Set.fromList <$> genTags) |
71 |
|
72 |
$(genArbitrary ''BlockDriver) |
73 |
|
74 |
$(genArbitrary ''DiskMode) |
75 |
|
76 |
instance Arbitrary DiskLogicalId where |
77 |
arbitrary = oneof [ LIDPlain <$> arbitrary <*> arbitrary |
78 |
, LIDDrbd8 <$> genFQDN <*> genFQDN <*> arbitrary |
79 |
<*> arbitrary <*> arbitrary <*> arbitrary |
80 |
, LIDFile <$> arbitrary <*> arbitrary |
81 |
, LIDBlockDev <$> arbitrary <*> arbitrary |
82 |
, LIDRados <$> arbitrary <*> arbitrary |
83 |
] |
84 |
|
85 |
-- | 'Disk' 'arbitrary' instance. Since we don't test disk hierarchy |
86 |
-- properties, we only generate disks with no children (FIXME), as |
87 |
-- generating recursive datastructures is a bit more work. |
88 |
instance Arbitrary Disk where |
89 |
arbitrary = Disk <$> arbitrary <*> pure [] <*> arbitrary |
90 |
<*> arbitrary <*> arbitrary |
91 |
|
92 |
-- FIXME: we should generate proper values, >=0, etc., but this is |
93 |
-- hard for partial ones, where all must be wrapped in a 'Maybe' |
94 |
$(genArbitrary ''PartialBeParams) |
95 |
|
96 |
$(genArbitrary ''AdminState) |
97 |
|
98 |
$(genArbitrary ''PartialNicParams) |
99 |
|
100 |
$(genArbitrary ''PartialNic) |
101 |
|
102 |
instance Arbitrary Instance where |
103 |
arbitrary = |
104 |
Instance |
105 |
<$> genFQDN <*> genFQDN <*> genFQDN -- OS name, but... |
106 |
<*> arbitrary |
107 |
-- FIXME: add non-empty hvparams when they're a proper type |
108 |
<*> pure (GenericContainer Map.empty) <*> arbitrary |
109 |
-- ... and for OSParams |
110 |
<*> pure (GenericContainer Map.empty) <*> arbitrary <*> arbitrary |
111 |
<*> arbitrary <*> arbitrary <*> arbitrary |
112 |
-- ts |
113 |
<*> arbitrary <*> arbitrary |
114 |
-- uuid |
115 |
<*> arbitrary |
116 |
-- serial |
117 |
<*> arbitrary |
118 |
-- tags |
119 |
<*> (Set.fromList <$> genTags) |
120 |
|
121 |
-- | FIXME: This generates completely random data, without normal |
122 |
-- validation rules. |
123 |
$(genArbitrary ''PartialISpecParams) |
124 |
|
125 |
-- | FIXME: This generates completely random data, without normal |
126 |
-- validation rules. |
127 |
$(genArbitrary ''PartialIPolicy) |
128 |
|
129 |
-- | FIXME: This generates completely random data, without normal |
130 |
-- validation rules. |
131 |
instance Arbitrary NodeGroup where |
132 |
arbitrary = NodeGroup <$> genFQDN <*> pure [] <*> arbitrary <*> arbitrary |
133 |
<*> arbitrary <*> pure (GenericContainer Map.empty) |
134 |
<*> arbitrary |
135 |
-- ts |
136 |
<*> arbitrary <*> arbitrary |
137 |
-- uuid |
138 |
<*> arbitrary |
139 |
-- serial |
140 |
<*> arbitrary |
141 |
-- tags |
142 |
<*> (Set.fromList <$> genTags) |
143 |
|
144 |
$(genArbitrary ''FilledISpecParams) |
145 |
$(genArbitrary ''FilledIPolicy) |
146 |
$(genArbitrary ''IpFamily) |
147 |
$(genArbitrary ''FilledNDParams) |
148 |
$(genArbitrary ''FilledNicParams) |
149 |
$(genArbitrary ''FilledBeParams) |
150 |
|
151 |
-- | No real arbitrary instance for 'ClusterHvParams' yet. |
152 |
instance Arbitrary ClusterHvParams where |
153 |
arbitrary = return $ GenericContainer Map.empty |
154 |
|
155 |
-- | No real arbitrary instance for 'OsHvParams' yet. |
156 |
instance Arbitrary OsHvParams where |
157 |
arbitrary = return $ GenericContainer Map.empty |
158 |
|
159 |
instance Arbitrary ClusterNicParams where |
160 |
arbitrary = (GenericContainer . Map.singleton C.ppDefault) <$> arbitrary |
161 |
|
162 |
instance Arbitrary OsParams where |
163 |
arbitrary = (GenericContainer . Map.fromList) <$> arbitrary |
164 |
|
165 |
instance Arbitrary ClusterOsParams where |
166 |
arbitrary = (GenericContainer . Map.fromList) <$> arbitrary |
167 |
|
168 |
instance Arbitrary ClusterBeParams where |
169 |
arbitrary = (GenericContainer . Map.fromList) <$> arbitrary |
170 |
|
171 |
instance Arbitrary TagSet where |
172 |
arbitrary = Set.fromList <$> genTags |
173 |
|
174 |
$(genArbitrary ''Cluster) |
175 |
|
176 |
instance Arbitrary Network where |
177 |
arbitrary = genValidNetwork |
178 |
|
179 |
-- | Generates a network instance with minimum netmasks of /24. Generating |
180 |
-- bigger networks slows down the tests, because long bit strings are generated |
181 |
-- for the reservations. |
182 |
genValidNetwork :: Gen Objects.Network |
183 |
genValidNetwork = do |
184 |
-- generate netmask for the IPv4 network |
185 |
netmask <- choose (24::Int, 30) |
186 |
name <- genName >>= mkNonEmpty |
187 |
network_type <- genMaybe genNetworkType |
188 |
mac_prefix <- genMaybe genName |
189 |
fam <- arbitrary |
190 |
net <- genIp4NetWithNetmask netmask |
191 |
net6 <- genMaybe genIp6Net |
192 |
gateway <- genMaybe genIp4AddrStr |
193 |
gateway6 <- genMaybe genIp6Addr |
194 |
size <- genMaybe genJSValue |
195 |
res <- liftM Just (genBitString $ netmask2NumHosts netmask) |
196 |
ext_res <- liftM Just (genBitString $ netmask2NumHosts netmask) |
197 |
let n = Network name network_type mac_prefix fam net net6 gateway |
198 |
gateway6 size res ext_res 0 Set.empty |
199 |
return n |
200 |
|
201 |
-- | Generates an arbitrary network type. |
202 |
genNetworkType :: Gen NetworkType |
203 |
genNetworkType = elements [ PrivateNetwork, PublicNetwork ] |
204 |
|
205 |
-- | Generate an arbitrary string consisting of '0' and '1' of the given length. |
206 |
genBitString :: Int -> Gen String |
207 |
genBitString len = vectorOf len (elements "01") |
208 |
|
209 |
-- | Generate an arbitrary string consisting of '0' and '1' of the maximum given |
210 |
-- length. |
211 |
genBitStringMaxLen :: Int -> Gen String |
212 |
genBitStringMaxLen maxLen = choose (0, maxLen) >>= genBitString |
213 |
|
214 |
-- | Generator for config data with an empty cluster (no instances), |
215 |
-- with N defined nodes. |
216 |
genEmptyCluster :: Int -> Gen ConfigData |
217 |
genEmptyCluster ncount = do |
218 |
nodes <- vector ncount |
219 |
version <- arbitrary |
220 |
let guuid = "00" |
221 |
nodes' = zipWith (\n idx -> |
222 |
let newname = nodeName n ++ "-" ++ show idx |
223 |
in (newname, n { nodeGroup = guuid, |
224 |
nodeName = newname})) |
225 |
nodes [(1::Int)..] |
226 |
nodemap = Map.fromList nodes' |
227 |
contnodes = if Map.size nodemap /= ncount |
228 |
then error ("Inconsistent node map, duplicates in" ++ |
229 |
" node name list? Names: " ++ |
230 |
show (map fst nodes')) |
231 |
else GenericContainer nodemap |
232 |
continsts = GenericContainer Map.empty |
233 |
grp <- arbitrary |
234 |
let contgroups = GenericContainer $ Map.singleton guuid grp |
235 |
serial <- arbitrary |
236 |
cluster <- resize 8 arbitrary |
237 |
let c = ConfigData version cluster contnodes contgroups continsts serial |
238 |
return c |
239 |
|
240 |
-- * Test properties |
241 |
|
242 |
-- | Tests that fillDict behaves correctly |
243 |
prop_fillDict :: [(Int, Int)] -> [(Int, Int)] -> Property |
244 |
prop_fillDict defaults custom = |
245 |
let d_map = Map.fromList defaults |
246 |
d_keys = map fst defaults |
247 |
c_map = Map.fromList custom |
248 |
c_keys = map fst custom |
249 |
in conjoin [ printTestCase "Empty custom filling" |
250 |
(fillDict d_map Map.empty [] == d_map) |
251 |
, printTestCase "Empty defaults filling" |
252 |
(fillDict Map.empty c_map [] == c_map) |
253 |
, printTestCase "Delete all keys" |
254 |
(fillDict d_map c_map (d_keys++c_keys) == Map.empty) |
255 |
] |
256 |
|
257 |
-- | Test that the serialisation of 'DiskLogicalId', which is |
258 |
-- implemented manually, is idempotent. Since we don't have a |
259 |
-- standalone JSON instance for DiskLogicalId (it's a data type that |
260 |
-- expands over two fields in a JSObject), we test this by actially |
261 |
-- testing entire Disk serialisations. So this tests two things at |
262 |
-- once, basically. |
263 |
prop_Disk_serialisation :: Disk -> Property |
264 |
prop_Disk_serialisation = testSerialisation |
265 |
|
266 |
-- | Check that node serialisation is idempotent. |
267 |
prop_Node_serialisation :: Node -> Property |
268 |
prop_Node_serialisation = testSerialisation |
269 |
|
270 |
-- | Check that instance serialisation is idempotent. |
271 |
prop_Inst_serialisation :: Instance -> Property |
272 |
prop_Inst_serialisation = testSerialisation |
273 |
|
274 |
-- | Check that network serialisation is idempotent. |
275 |
prop_Network_serialisation :: Network -> Property |
276 |
prop_Network_serialisation = testSerialisation |
277 |
|
278 |
-- | Check config serialisation. |
279 |
prop_Config_serialisation :: Property |
280 |
prop_Config_serialisation = |
281 |
forAll (choose (0, maxNodes `div` 4) >>= genEmptyCluster) testSerialisation |
282 |
|
283 |
-- | Custom HUnit test to check the correspondence between Haskell-generated |
284 |
-- networks and their Python decoded, validated and re-encoded version. |
285 |
-- For the technical background of this unit test, check the documentation |
286 |
-- of "case_py_compat_types" of htest/Test/Ganeti/Opcodes.hs |
287 |
case_py_compat_networks :: HUnit.Assertion |
288 |
case_py_compat_networks = do |
289 |
let num_networks = 500::Int |
290 |
sample_networks <- sample' (vectorOf num_networks genValidNetwork) |
291 |
let networks = head sample_networks |
292 |
networks_with_properties = map getNetworkProperties networks |
293 |
serialized = J.encode networks |
294 |
-- check for non-ASCII fields, usually due to 'arbitrary :: String' |
295 |
mapM_ (\net -> when (any (not . isAscii) (J.encode net)) . |
296 |
HUnit.assertFailure $ |
297 |
"Network has non-ASCII fields: " ++ show net |
298 |
) networks |
299 |
py_stdout <- |
300 |
runPython "from ganeti import network\n\ |
301 |
\from ganeti import objects\n\ |
302 |
\from ganeti import serializer\n\ |
303 |
\import sys\n\ |
304 |
\net_data = serializer.Load(sys.stdin.read())\n\ |
305 |
\decoded = [objects.Network.FromDict(n) for n in net_data]\n\ |
306 |
\encoded = []\n\ |
307 |
\for net in decoded:\n\ |
308 |
\ a = network.AddressPool(net)\n\ |
309 |
\ encoded.append((a.GetFreeCount(), a.GetReservedCount(), \\\n\ |
310 |
\ net.ToDict()))\n\ |
311 |
\print serializer.Dump(encoded)" serialized |
312 |
>>= checkPythonResult |
313 |
let deserialised = J.decode py_stdout::J.Result [(Int, Int, Network)] |
314 |
decoded <- case deserialised of |
315 |
J.Ok ops -> return ops |
316 |
J.Error msg -> |
317 |
HUnit.assertFailure ("Unable to decode networks: " ++ msg) |
318 |
-- this already raised an expection, but we need it |
319 |
-- for proper types |
320 |
>> fail "Unable to decode networks" |
321 |
HUnit.assertEqual "Mismatch in number of returned networks" |
322 |
(length decoded) (length networks_with_properties) |
323 |
mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding") |
324 |
) $ zip decoded networks_with_properties |
325 |
|
326 |
-- | Creates a tuple of the given network combined with some of its properties |
327 |
-- to be compared against the same properties generated by the python code. |
328 |
getNetworkProperties :: Network -> (Int, Int, Network) |
329 |
getNetworkProperties net = |
330 |
let maybePool = createAddressPool net |
331 |
in case maybePool of |
332 |
(Just pool) -> (getFreeCount pool, getReservedCount pool, net) |
333 |
Nothing -> (-1, -1, net) |
334 |
|
335 |
testSuite "Objects" |
336 |
[ 'prop_fillDict |
337 |
, 'prop_Disk_serialisation |
338 |
, 'prop_Inst_serialisation |
339 |
, 'prop_Network_serialisation |
340 |
, 'prop_Node_serialisation |
341 |
, 'prop_Config_serialisation |
342 |
, 'case_py_compat_networks |
343 |
] |