Fix bug in group queries related to node/instance fields
[ganeti-github.git] / test / hs / Test / Ganeti / Objects.hs
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, 2013 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 , genBitStringMaxLen
35 ) where
36
37 import Test.QuickCheck
38 import qualified Test.HUnit as HUnit
39
40 import Control.Applicative
41 import Control.Monad
42 import Data.Char
43 import qualified Data.Map as Map
44 import qualified Data.Set as Set
45 import qualified Text.JSON as J
46
47 import Test.Ganeti.TestHelper
48 import Test.Ganeti.TestCommon
49 import Test.Ganeti.Types ()
50
51 import qualified Ganeti.Constants as C
52 import Ganeti.Network
53 import Ganeti.Objects as Objects
54 import Ganeti.JSON
55 import Ganeti.Types
56
57 {-# ANN module "HLint: ignore Use camelCase" #-}
58
59 -- * Arbitrary instances
60
61 $(genArbitrary ''PartialNDParams)
62
63 instance Arbitrary Node where
64 arbitrary = Node <$> genFQDN <*> genFQDN <*> genFQDN
65 <*> arbitrary <*> arbitrary <*> arbitrary <*> genFQDN
66 <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
67 <*> arbitrary <*> arbitrary <*> genFQDN <*> arbitrary
68 <*> (Set.fromList <$> genTags)
69
70 $(genArbitrary ''BlockDriver)
71
72 $(genArbitrary ''DiskMode)
73
74 instance Arbitrary DiskLogicalId where
75 arbitrary = oneof [ LIDPlain <$> arbitrary <*> arbitrary
76 , LIDDrbd8 <$> genFQDN <*> genFQDN <*> arbitrary
77 <*> arbitrary <*> arbitrary <*> arbitrary
78 , LIDFile <$> arbitrary <*> arbitrary
79 , LIDBlockDev <$> arbitrary <*> arbitrary
80 , LIDRados <$> arbitrary <*> arbitrary
81 ]
82
83 -- | 'Disk' 'arbitrary' instance. Since we don't test disk hierarchy
84 -- properties, we only generate disks with no children (FIXME), as
85 -- generating recursive datastructures is a bit more work.
86 instance Arbitrary Disk where
87 arbitrary = Disk <$> arbitrary <*> pure [] <*> arbitrary
88 <*> arbitrary <*> arbitrary
89
90 -- FIXME: we should generate proper values, >=0, etc., but this is
91 -- hard for partial ones, where all must be wrapped in a 'Maybe'
92 $(genArbitrary ''PartialBeParams)
93
94 $(genArbitrary ''AdminState)
95
96 $(genArbitrary ''PartialNicParams)
97
98 $(genArbitrary ''PartialNic)
99
100 instance Arbitrary Instance where
101 arbitrary =
102 Instance
103 <$> genFQDN <*> genFQDN <*> genFQDN -- OS name, but...
104 <*> arbitrary
105 -- FIXME: add non-empty hvparams when they're a proper type
106 <*> pure (GenericContainer Map.empty) <*> arbitrary
107 -- ... and for OSParams
108 <*> pure (GenericContainer Map.empty) <*> arbitrary <*> arbitrary
109 <*> arbitrary <*> arbitrary <*> arbitrary
110 -- ts
111 <*> arbitrary <*> arbitrary
112 -- uuid
113 <*> arbitrary
114 -- serial
115 <*> arbitrary
116 -- tags
117 <*> (Set.fromList <$> genTags)
118
119 -- | FIXME: This generates completely random data, without normal
120 -- validation rules.
121 $(genArbitrary ''PartialISpecParams)
122
123 -- | FIXME: This generates completely random data, without normal
124 -- validation rules.
125 $(genArbitrary ''PartialIPolicy)
126
127 $(genArbitrary ''FilledISpecParams)
128 $(genArbitrary ''FilledIPolicy)
129 $(genArbitrary ''IpFamily)
130 $(genArbitrary ''FilledNDParams)
131 $(genArbitrary ''FilledNicParams)
132 $(genArbitrary ''FilledBeParams)
133
134 -- | No real arbitrary instance for 'ClusterHvParams' yet.
135 instance Arbitrary ClusterHvParams where
136 arbitrary = return $ GenericContainer Map.empty
137
138 -- | No real arbitrary instance for 'OsHvParams' yet.
139 instance Arbitrary OsHvParams where
140 arbitrary = return $ GenericContainer Map.empty
141
142 instance Arbitrary ClusterNicParams where
143 arbitrary = (GenericContainer . Map.singleton C.ppDefault) <$> arbitrary
144
145 instance Arbitrary OsParams where
146 arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
147
148 instance Arbitrary ClusterOsParams where
149 arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
150
151 instance Arbitrary ClusterBeParams where
152 arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
153
154 instance Arbitrary TagSet where
155 arbitrary = Set.fromList <$> genTags
156
157 $(genArbitrary ''Cluster)
158
159 instance Arbitrary Network where
160 arbitrary = genValidNetwork
161
162 -- | Generates a network instance with minimum netmasks of /24. Generating
163 -- bigger networks slows down the tests, because long bit strings are generated
164 -- for the reservations.
165 genValidNetwork :: Gen Objects.Network
166 genValidNetwork = do
167 -- generate netmask for the IPv4 network
168 netmask <- choose (24::Int, 30)
169 name <- genName >>= mkNonEmpty
170 mac_prefix <- genMaybe genName
171 net <- genIp4NetWithNetmask netmask
172 net6 <- genMaybe genIp6Net
173 gateway <- genMaybe genIp4AddrStr
174 gateway6 <- genMaybe genIp6Addr
175 res <- liftM Just (genBitString $ netmask2NumHosts netmask)
176 ext_res <- liftM Just (genBitString $ netmask2NumHosts netmask)
177 let n = Network name mac_prefix net net6 gateway
178 gateway6 res ext_res 0 Set.empty
179 return n
180
181 -- | Generate an arbitrary string consisting of '0' and '1' of the given length.
182 genBitString :: Int -> Gen String
183 genBitString len = vectorOf len (elements "01")
184
185 -- | Generate an arbitrary string consisting of '0' and '1' of the maximum given
186 -- length.
187 genBitStringMaxLen :: Int -> Gen String
188 genBitStringMaxLen maxLen = choose (0, maxLen) >>= genBitString
189
190 -- | Generator for config data with an empty cluster (no instances),
191 -- with N defined nodes.
192 genEmptyCluster :: Int -> Gen ConfigData
193 genEmptyCluster ncount = do
194 nodes <- vector ncount
195 version <- arbitrary
196 grp <- arbitrary
197 let guuid = groupUuid grp
198 nodes' = zipWith (\n idx ->
199 let newname = nodeName n ++ "-" ++ show idx
200 in (newname, n { nodeGroup = guuid,
201 nodeName = newname}))
202 nodes [(1::Int)..]
203 nodemap = Map.fromList nodes'
204 contnodes = if Map.size nodemap /= ncount
205 then error ("Inconsistent node map, duplicates in" ++
206 " node name list? Names: " ++
207 show (map fst nodes'))
208 else GenericContainer nodemap
209 continsts = GenericContainer Map.empty
210 let contgroups = GenericContainer $ Map.singleton guuid grp
211 serial <- arbitrary
212 cluster <- resize 8 arbitrary
213 let c = ConfigData version cluster contnodes contgroups continsts serial
214 return c
215
216 -- * Test properties
217
218 -- | Tests that fillDict behaves correctly
219 prop_fillDict :: [(Int, Int)] -> [(Int, Int)] -> Property
220 prop_fillDict defaults custom =
221 let d_map = Map.fromList defaults
222 d_keys = map fst defaults
223 c_map = Map.fromList custom
224 c_keys = map fst custom
225 in conjoin [ printTestCase "Empty custom filling"
226 (fillDict d_map Map.empty [] == d_map)
227 , printTestCase "Empty defaults filling"
228 (fillDict Map.empty c_map [] == c_map)
229 , printTestCase "Delete all keys"
230 (fillDict d_map c_map (d_keys++c_keys) == Map.empty)
231 ]
232
233 -- | Test that the serialisation of 'DiskLogicalId', which is
234 -- implemented manually, is idempotent. Since we don't have a
235 -- standalone JSON instance for DiskLogicalId (it's a data type that
236 -- expands over two fields in a JSObject), we test this by actially
237 -- testing entire Disk serialisations. So this tests two things at
238 -- once, basically.
239 prop_Disk_serialisation :: Disk -> Property
240 prop_Disk_serialisation = testSerialisation
241
242 -- | Check that node serialisation is idempotent.
243 prop_Node_serialisation :: Node -> Property
244 prop_Node_serialisation = testSerialisation
245
246 -- | Check that instance serialisation is idempotent.
247 prop_Inst_serialisation :: Instance -> Property
248 prop_Inst_serialisation = testSerialisation
249
250 -- | Check that network serialisation is idempotent.
251 prop_Network_serialisation :: Network -> Property
252 prop_Network_serialisation = testSerialisation
253
254 -- | Check config serialisation.
255 prop_Config_serialisation :: Property
256 prop_Config_serialisation =
257 forAll (choose (0, maxNodes `div` 4) >>= genEmptyCluster) testSerialisation
258
259 -- | Custom HUnit test to check the correspondence between Haskell-generated
260 -- networks and their Python decoded, validated and re-encoded version.
261 -- For the technical background of this unit test, check the documentation
262 -- of "case_py_compat_types" of test/hs/Test/Ganeti/Opcodes.hs
263 case_py_compat_networks :: HUnit.Assertion
264 case_py_compat_networks = do
265 let num_networks = 500::Int
266 networks <- genSample (vectorOf num_networks genValidNetwork)
267 let networks_with_properties = map getNetworkProperties networks
268 serialized = J.encode networks
269 -- check for non-ASCII fields, usually due to 'arbitrary :: String'
270 mapM_ (\net -> when (any (not . isAscii) (J.encode net)) .
271 HUnit.assertFailure $
272 "Network has non-ASCII fields: " ++ show net
273 ) networks
274 py_stdout <-
275 runPython "from ganeti import network\n\
276 \from ganeti import objects\n\
277 \from ganeti import serializer\n\
278 \import sys\n\
279 \net_data = serializer.Load(sys.stdin.read())\n\
280 \decoded = [objects.Network.FromDict(n) for n in net_data]\n\
281 \encoded = []\n\
282 \for net in decoded:\n\
283 \ a = network.AddressPool(net)\n\
284 \ encoded.append((a.GetFreeCount(), a.GetReservedCount(), \\\n\
285 \ net.ToDict()))\n\
286 \print serializer.Dump(encoded)" serialized
287 >>= checkPythonResult
288 let deserialised = J.decode py_stdout::J.Result [(Int, Int, Network)]
289 decoded <- case deserialised of
290 J.Ok ops -> return ops
291 J.Error msg ->
292 HUnit.assertFailure ("Unable to decode networks: " ++ msg)
293 -- this already raised an expection, but we need it
294 -- for proper types
295 >> fail "Unable to decode networks"
296 HUnit.assertEqual "Mismatch in number of returned networks"
297 (length decoded) (length networks_with_properties)
298 mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
299 ) $ zip decoded networks_with_properties
300
301 -- | Creates a tuple of the given network combined with some of its properties
302 -- to be compared against the same properties generated by the python code.
303 getNetworkProperties :: Network -> (Int, Int, Network)
304 getNetworkProperties net =
305 let maybePool = createAddressPool net
306 in case maybePool of
307 (Just pool) -> (getFreeCount pool, getReservedCount pool, net)
308 Nothing -> (-1, -1, net)
309
310 -- | Tests the compatibility between Haskell-serialized node groups and their
311 -- python-decoded and encoded version.
312 case_py_compat_nodegroups :: HUnit.Assertion
313 case_py_compat_nodegroups = do
314 let num_groups = 500::Int
315 groups <- genSample (vectorOf num_groups genNodeGroup)
316 let serialized = J.encode groups
317 -- check for non-ASCII fields, usually due to 'arbitrary :: String'
318 mapM_ (\group -> when (any (not . isAscii) (J.encode group)) .
319 HUnit.assertFailure $
320 "Node group has non-ASCII fields: " ++ show group
321 ) groups
322 py_stdout <-
323 runPython "from ganeti import objects\n\
324 \from ganeti import serializer\n\
325 \import sys\n\
326 \group_data = serializer.Load(sys.stdin.read())\n\
327 \decoded = [objects.NodeGroup.FromDict(g) for g in group_data]\n\
328 \encoded = [g.ToDict() for g in decoded]\n\
329 \print serializer.Dump(encoded)" serialized
330 >>= checkPythonResult
331 let deserialised = J.decode py_stdout::J.Result [NodeGroup]
332 decoded <- case deserialised of
333 J.Ok ops -> return ops
334 J.Error msg ->
335 HUnit.assertFailure ("Unable to decode node groups: " ++ msg)
336 -- this already raised an expection, but we need it
337 -- for proper types
338 >> fail "Unable to decode node groups"
339 HUnit.assertEqual "Mismatch in number of returned node groups"
340 (length decoded) (length groups)
341 mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
342 ) $ zip decoded groups
343
344 -- | Generates a node group with up to 3 networks.
345 -- | FIXME: This generates still somewhat completely random data, without normal
346 -- validation rules.
347 genNodeGroup :: Gen NodeGroup
348 genNodeGroup = do
349 name <- genFQDN
350 members <- pure []
351 ndparams <- arbitrary
352 alloc_policy <- arbitrary
353 ipolicy <- arbitrary
354 diskparams <- pure (GenericContainer Map.empty)
355 num_networks <- choose (0, 3)
356 net_uuid_list <- vectorOf num_networks (arbitrary::Gen String)
357 nic_param_list <- vectorOf num_networks (arbitrary::Gen PartialNicParams)
358 net_map <- pure (GenericContainer . Map.fromList $
359 zip net_uuid_list nic_param_list)
360 -- timestamp fields
361 ctime <- arbitrary
362 mtime <- arbitrary
363 uuid <- genFQDN `suchThat` (/= name)
364 serial <- arbitrary
365 tags <- Set.fromList <$> genTags
366 let group = NodeGroup name members ndparams alloc_policy ipolicy diskparams
367 net_map ctime mtime uuid serial tags
368 return group
369
370 instance Arbitrary NodeGroup where
371 arbitrary = genNodeGroup
372
373 testSuite "Objects"
374 [ 'prop_fillDict
375 , 'prop_Disk_serialisation
376 , 'prop_Inst_serialisation
377 , 'prop_Network_serialisation
378 , 'prop_Node_serialisation
379 , 'prop_Config_serialisation
380 , 'case_py_compat_networks
381 , 'case_py_compat_nodegroups
382 ]