Merge branch 'stable-2.12' into stable-2.13
[ganeti-github.git] / test / hs / Test / Ganeti / Objects.hs
1 {-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances,
2 OverloadedStrings #-}
3 {-# OPTIONS_GHC -fno-warn-orphans #-}
4
5 {-| Unittests for ganeti-htools.
6
7 -}
8
9 {-
10
11 Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
12 All rights reserved.
13
14 Redistribution and use in source and binary forms, with or without
15 modification, are permitted provided that the following conditions are
16 met:
17
18 1. Redistributions of source code must retain the above copyright notice,
19 this list of conditions and the following disclaimer.
20
21 2. Redistributions in binary form must reproduce the above copyright
22 notice, this list of conditions and the following disclaimer in the
23 documentation and/or other materials provided with the distribution.
24
25 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
26 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
27 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
28 PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
29 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
30 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
31 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
32 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
33 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
34 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
35 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
36
37 -}
38
39 module Test.Ganeti.Objects
40 ( testObjects
41 , Node(..)
42 , genConfigDataWithNetworks
43 , genDisk
44 , genDiskWithChildren
45 , genEmptyCluster
46 , genInst
47 , genInstWithNets
48 , genValidNetwork
49 , genBitStringMaxLen
50 ) where
51
52 import Test.QuickCheck
53 import qualified Test.HUnit as HUnit
54
55 import Control.Applicative
56 import Control.Monad
57 import Data.Char
58 import qualified Data.List as List
59 import qualified Data.Map as Map
60 import Data.Maybe (fromMaybe)
61 import qualified Data.Set as Set
62 import Data.Word (Word32)
63 import GHC.Exts (IsString(..))
64 import System.Time (ClockTime(..))
65 import qualified Text.JSON as J
66
67 import Test.Ganeti.Query.Language ()
68 import Test.Ganeti.SlotMap (genSlotLimit)
69 import Test.Ganeti.TestHelper
70 import Test.Ganeti.TestCommon
71 import Test.Ganeti.Types ()
72
73 import qualified Ganeti.Constants as C
74 import qualified Ganeti.ConstantUtils as CU
75 import Ganeti.Network
76 import Ganeti.Objects as Objects
77 import qualified Ganeti.Objects.BitArray as BA
78 import Ganeti.JSON
79 import Ganeti.Types
80
81 -- * Arbitrary instances
82
83 instance Arbitrary (Container DataCollectorConfig) where
84 arbitrary = do
85 let names = CU.toList C.dataCollectorNames
86 activations <- vector $ length names
87 timeouts <- vector $ length names
88 let configs = zipWith DataCollectorConfig activations timeouts
89 return GenericContainer {
90 fromContainer = Map.fromList $ zip names configs }
91
92 $(genArbitrary ''PartialNDParams)
93
94 instance Arbitrary Node where
95 arbitrary = Node <$> genFQDN <*> genFQDN <*> genFQDN
96 <*> arbitrary <*> arbitrary <*> arbitrary <*> genFQDN
97 <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
98 <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
99 <*> genFQDN <*> arbitrary <*> (Set.fromList <$> genTags)
100
101 $(genArbitrary ''BlockDriver)
102
103 $(genArbitrary ''DiskMode)
104
105 instance Arbitrary LogicalVolume where
106 arbitrary = LogicalVolume <$> validName <*> validName
107 where
108 validName = -- we intentionally omit '.' and '-' to avoid forbidden names
109 listOf1 $ elements (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "+_")
110
111 instance Arbitrary DiskLogicalId where
112 arbitrary = oneof [ LIDPlain <$> arbitrary
113 , LIDDrbd8 <$> genFQDN <*> genFQDN <*> arbitrary
114 <*> arbitrary <*> arbitrary <*> arbitrary
115 , LIDFile <$> arbitrary <*> arbitrary
116 , LIDBlockDev <$> arbitrary <*> arbitrary
117 , LIDRados <$> arbitrary <*> arbitrary
118 ]
119
120 -- | 'Disk' 'arbitrary' instance. Since we don't test disk hierarchy
121 -- properties, we only generate disks with no children (FIXME), as
122 -- generating recursive datastructures is a bit more work.
123 instance Arbitrary Disk where
124 arbitrary = Disk <$> arbitrary <*> pure [] <*> arbitrary
125 <*> arbitrary <*> arbitrary <*> arbitrary
126 <*> arbitrary <*> arbitrary <*> arbitrary
127 <*> arbitrary <*> arbitrary <*> arbitrary
128
129 -- FIXME: we should generate proper values, >=0, etc., but this is
130 -- hard for partial ones, where all must be wrapped in a 'Maybe'
131 $(genArbitrary ''PartialBeParams)
132
133 $(genArbitrary ''AdminState)
134
135 $(genArbitrary ''AdminStateSource)
136
137 $(genArbitrary ''PartialNicParams)
138
139 $(genArbitrary ''PartialNic)
140
141 instance Arbitrary Instance where
142 arbitrary =
143 Instance
144 -- name
145 <$> genFQDN
146 -- primary node
147 <*> genFQDN
148 -- OS
149 <*> genFQDN
150 -- hypervisor
151 <*> arbitrary
152 -- hvparams
153 -- FIXME: add non-empty hvparams when they're a proper type
154 <*> pure (GenericContainer Map.empty)
155 -- beparams
156 <*> arbitrary
157 -- osparams
158 <*> pure (GenericContainer Map.empty)
159 -- osparams_private
160 <*> pure (GenericContainer Map.empty)
161 -- admin_state
162 <*> arbitrary
163 -- admin_state_source
164 <*> arbitrary
165 -- nics
166 <*> arbitrary
167 -- disks
168 <*> vectorOf 5 arbitrary
169 -- disk template
170 <*> arbitrary
171 -- disks active
172 <*> arbitrary
173 -- network port
174 <*> arbitrary
175 -- ts
176 <*> arbitrary <*> arbitrary
177 -- uuid
178 <*> arbitrary
179 -- serial
180 <*> arbitrary
181 -- tags
182 <*> (Set.fromList <$> genTags)
183
184 -- | Generates an instance that is connected to the given networks
185 -- and possibly some other networks
186 genInstWithNets :: [String] -> Gen Instance
187 genInstWithNets nets = do
188 plain_inst <- arbitrary
189 enhanceInstWithNets plain_inst nets
190
191 -- | Generates an instance that is connected to some networks
192 genInst :: Gen Instance
193 genInst = genInstWithNets []
194
195 -- | Enhances a given instance with network information, by connecting it to the
196 -- given networks and possibly some other networks
197 enhanceInstWithNets :: Instance -> [String] -> Gen Instance
198 enhanceInstWithNets inst nets = do
199 mac <- arbitrary
200 ip <- arbitrary
201 nicparams <- arbitrary
202 name <- arbitrary
203 uuid <- arbitrary
204 -- generate some more networks than the given ones
205 num_more_nets <- choose (0,3)
206 more_nets <- vectorOf num_more_nets genUUID
207 let genNic net = PartialNic mac ip nicparams net name uuid
208 partial_nics = map (genNic . Just)
209 (List.nub (nets ++ more_nets))
210 new_inst = inst { instNics = partial_nics }
211 return new_inst
212
213 genDiskWithChildren :: Int -> Gen Disk
214 genDiskWithChildren num_children = do
215 logicalid <- arbitrary
216 children <- vectorOf num_children (genDiskWithChildren 0)
217 ivname <- genName
218 size <- arbitrary
219 mode <- arbitrary
220 name <- genMaybe genName
221 spindles <- arbitrary
222 params <- arbitrary
223 uuid <- genName
224 serial <- arbitrary
225 time <- arbitrary
226 return $
227 Disk logicalid children ivname size mode name
228 spindles params uuid serial time time
229
230 genDisk :: Gen Disk
231 genDisk = genDiskWithChildren 3
232
233 -- | FIXME: This generates completely random data, without normal
234 -- validation rules.
235 $(genArbitrary ''PartialISpecParams)
236
237 -- | FIXME: This generates completely random data, without normal
238 -- validation rules.
239 $(genArbitrary ''PartialIPolicy)
240
241 $(genArbitrary ''FilledISpecParams)
242 $(genArbitrary ''MinMaxISpecs)
243 $(genArbitrary ''FilledIPolicy)
244 $(genArbitrary ''IpFamily)
245 $(genArbitrary ''FilledNDParams)
246 $(genArbitrary ''FilledNicParams)
247 $(genArbitrary ''FilledBeParams)
248
249 -- | No real arbitrary instance for 'ClusterHvParams' yet.
250 instance Arbitrary ClusterHvParams where
251 arbitrary = return $ GenericContainer Map.empty
252
253 -- | No real arbitrary instance for 'OsHvParams' yet.
254 instance Arbitrary OsHvParams where
255 arbitrary = return $ GenericContainer Map.empty
256
257 -- | No real arbitrary instance for 'GroupDiskParams' yet.
258 instance Arbitrary GroupDiskParams where
259 arbitrary = return $ GenericContainer Map.empty
260
261 instance Arbitrary ClusterNicParams where
262 arbitrary = (GenericContainer . Map.singleton C.ppDefault) <$> arbitrary
263
264 instance Arbitrary OsParams where
265 arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
266
267 instance Arbitrary Objects.ClusterOsParamsPrivate where
268 arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
269
270 instance Arbitrary a => Arbitrary (Private a) where
271 arbitrary = Private <$> arbitrary
272
273 instance Arbitrary ClusterOsParams where
274 arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
275
276 instance Arbitrary ClusterBeParams where
277 arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
278
279 instance Arbitrary TagSet where
280 arbitrary = Set.fromList <$> genTags
281
282 instance Arbitrary IAllocatorParams where
283 arbitrary = return $ GenericContainer Map.empty
284
285 $(genArbitrary ''Cluster)
286
287 instance Arbitrary AddressPool where
288 arbitrary = AddressPool . BA.fromList <$> arbitrary
289
290 instance Arbitrary Network where
291 arbitrary = genValidNetwork
292
293 instance Arbitrary FilterAction where
294 arbitrary = oneof
295 [ pure Accept
296 , pure Pause
297 , pure Reject
298 , pure Continue
299 , RateLimit <$> genSlotLimit
300 ]
301
302 instance Arbitrary FilterPredicate where
303 arbitrary = oneof
304 [ FPJobId <$> arbitrary
305 , FPOpCode <$> arbitrary
306 , FPReason <$> arbitrary
307 ]
308
309 instance Arbitrary FilterRule where
310 arbitrary = FilterRule <$> arbitrary
311 <*> arbitrary
312 <*> arbitrary
313 <*> arbitrary
314 <*> arbitrary
315 <*> genUUID
316
317 -- | Generates a network instance with minimum netmasks of /24. Generating
318 -- bigger networks slows down the tests, because long bit strings are generated
319 -- for the reservations.
320 genValidNetwork :: Gen Objects.Network
321 genValidNetwork = do
322 -- generate netmask for the IPv4 network
323 netmask <- fromIntegral <$> choose (24::Int, 30)
324 name <- genName >>= mkNonEmpty
325 mac_prefix <- genMaybe genName
326 net <- arbitrary
327 net6 <- genMaybe genIp6Net
328 gateway <- genMaybe arbitrary
329 gateway6 <- genMaybe genIp6Addr
330 res <- liftM Just (genBitString $ netmask2NumHosts netmask)
331 ext_res <- liftM Just (genBitString $ netmask2NumHosts netmask)
332 uuid <- arbitrary
333 ctime <- arbitrary
334 mtime <- arbitrary
335 let n = Network name mac_prefix (mkIp4Network net netmask) net6 gateway
336 gateway6 res ext_res uuid ctime mtime 0 Set.empty
337 return n
338
339 -- | Generate an arbitrary string consisting of '0' and '1' of the given length.
340 genBitString :: Int -> Gen AddressPool
341 genBitString len =
342 (AddressPool . BA.fromList) `liftM` vectorOf len (elements [False, True])
343
344 -- | Generate an arbitrary string consisting of '0' and '1' of the maximum given
345 -- length.
346 genBitStringMaxLen :: Int -> Gen AddressPool
347 genBitStringMaxLen maxLen = choose (0, maxLen) >>= genBitString
348
349 -- | Generator for config data with an empty cluster (no instances),
350 -- with N defined nodes.
351 genEmptyCluster :: Int -> Gen ConfigData
352 genEmptyCluster ncount = do
353 nodes <- vector ncount
354 version <- arbitrary
355 grp <- arbitrary
356 let guuid = groupUuid grp
357 nodes' = zipWith (\n idx ->
358 let newname = takeWhile (/= '.') (nodeName n)
359 ++ "-" ++ show idx
360 in (newname, n { nodeGroup = guuid,
361 nodeName = newname}))
362 nodes [(1::Int)..]
363 nodemap = Map.fromList nodes'
364 contnodes = if Map.size nodemap /= ncount
365 then error ("Inconsistent node map, duplicates in" ++
366 " node name list? Names: " ++
367 show (map fst nodes'))
368 else GenericContainer nodemap
369 continsts = GenericContainer Map.empty
370 networks = GenericContainer Map.empty
371 disks = GenericContainer Map.empty
372 filters = GenericContainer Map.empty
373 let contgroups = GenericContainer $ Map.singleton guuid grp
374 serial <- arbitrary
375 -- timestamp fields
376 ctime <- arbitrary
377 mtime <- arbitrary
378 cluster <- resize 8 arbitrary
379 let c = ConfigData version cluster contnodes contgroups continsts networks
380 disks filters ctime mtime serial
381 return c
382
383 -- | FIXME: make an even simpler base version of creating a cluster.
384
385 -- | Generates config data with a couple of networks.
386 genConfigDataWithNetworks :: ConfigData -> Gen ConfigData
387 genConfigDataWithNetworks old_cfg = do
388 num_nets <- choose (0, 3)
389 -- generate a list of network names (no duplicates)
390 net_names <- genUniquesList num_nets genName >>= mapM mkNonEmpty
391 -- generate a random list of networks (possibly with duplicate names)
392 nets <- vectorOf num_nets genValidNetwork
393 -- use unique names for the networks
394 let nets_unique = map ( \(name, net) -> net { networkName = name } )
395 (zip net_names nets)
396 net_map = GenericContainer $ Map.fromList
397 (map (\n -> (networkUuid n, n)) nets_unique)
398 new_cfg = old_cfg { configNetworks = net_map }
399 return new_cfg
400
401 -- * Test properties
402
403 -- | Tests that fillDict behaves correctly
404 prop_fillDict :: [(Int, Int)] -> [(Int, Int)] -> Property
405 prop_fillDict defaults custom =
406 let d_map = Map.fromList defaults
407 d_keys = map fst defaults
408 c_map = Map.fromList custom
409 c_keys = map fst custom
410 in conjoin [ counterexample "Empty custom filling"
411 (fillDict d_map Map.empty [] == d_map)
412 , counterexample "Empty defaults filling"
413 (fillDict Map.empty c_map [] == c_map)
414 , counterexample "Delete all keys"
415 (fillDict d_map c_map (d_keys++c_keys) == Map.empty)
416 ]
417
418 prop_LogicalVolume_serialisation :: LogicalVolume -> Property
419 prop_LogicalVolume_serialisation = testSerialisation
420
421 prop_LogicalVolume_deserialisationFail :: Property
422 prop_LogicalVolume_deserialisationFail =
423 conjoin . map (testDeserialisationFail (LogicalVolume "" "")) $
424 [ J.JSArray []
425 , J.JSString $ J.toJSString "/abc"
426 , J.JSString $ J.toJSString "abc/"
427 , J.JSString $ J.toJSString "../."
428 , J.JSString $ J.toJSString "g/snapshot"
429 , J.JSString $ J.toJSString "g/a_mimagex"
430 , J.JSString $ J.toJSString "g/r;3"
431 ]
432
433 -- | Test that the serialisation of 'DiskLogicalId', which is
434 -- implemented manually, is idempotent. Since we don't have a
435 -- standalone JSON instance for DiskLogicalId (it's a data type that
436 -- expands over two fields in a JSObject), we test this by actially
437 -- testing entire Disk serialisations. So this tests two things at
438 -- once, basically.
439 prop_Disk_serialisation :: Disk -> Property
440 prop_Disk_serialisation = testSerialisation
441
442 prop_Disk_array_serialisation :: Disk -> Property
443 prop_Disk_array_serialisation = testArraySerialisation
444
445 -- | Check that node serialisation is idempotent.
446 prop_Node_serialisation :: Node -> Property
447 prop_Node_serialisation = testSerialisation
448
449 -- | Check that instance serialisation is idempotent.
450 prop_Inst_serialisation :: Instance -> Property
451 prop_Inst_serialisation = testSerialisation
452
453 -- | Check that address pool serialisation is idempotent.
454 prop_AddressPool_serialisation :: AddressPool -> Property
455 prop_AddressPool_serialisation = testSerialisation
456
457 -- | Check that network serialisation is idempotent.
458 prop_Network_serialisation :: Network -> Property
459 prop_Network_serialisation = testSerialisation
460
461 -- | Check that filter action serialisation is idempotent.
462 prop_FilterAction_serialisation :: FilterAction -> Property
463 prop_FilterAction_serialisation = testSerialisation
464
465 -- | Check that filter predicate serialisation is idempotent.
466 prop_FilterPredicate_serialisation :: FilterPredicate -> Property
467 prop_FilterPredicate_serialisation = testSerialisation
468
469 -- | Check config serialisation.
470 prop_Config_serialisation :: Property
471 prop_Config_serialisation =
472 forAll (choose (0, maxNodes `div` 4) >>= genEmptyCluster) testSerialisation
473
474 -- | Custom HUnit test to check the correspondence between Haskell-generated
475 -- networks and their Python decoded, validated and re-encoded version.
476 -- For the technical background of this unit test, check the documentation
477 -- of "case_py_compat_types" of test/hs/Test/Ganeti/Opcodes.hs
478 casePyCompatNetworks :: HUnit.Assertion
479 casePyCompatNetworks = do
480 let num_networks = 500::Int
481 networks <- genSample (vectorOf num_networks genValidNetwork)
482 let networks_with_properties = map getNetworkProperties networks
483 serialized = J.encode networks
484 -- check for non-ASCII fields, usually due to 'arbitrary :: String'
485 mapM_ (\net -> when (any (not . isAscii) (J.encode net)) .
486 HUnit.assertFailure $
487 "Network has non-ASCII fields: " ++ show net
488 ) networks
489 py_stdout <-
490 runPython "from ganeti import network\n\
491 \from ganeti import objects\n\
492 \from ganeti import serializer\n\
493 \import sys\n\
494 \net_data = serializer.Load(sys.stdin.read())\n\
495 \decoded = [objects.Network.FromDict(n) for n in net_data]\n\
496 \encoded = []\n\
497 \for net in decoded:\n\
498 \ a = network.AddressPool(net)\n\
499 \ encoded.append((a.GetFreeCount(), a.GetReservedCount(), \\\n\
500 \ net.ToDict()))\n\
501 \print serializer.Dump(encoded)" serialized
502 >>= checkPythonResult
503 let deserialised = J.decode py_stdout::J.Result [(Int, Int, Network)]
504 decoded <- case deserialised of
505 J.Ok ops -> return ops
506 J.Error msg ->
507 HUnit.assertFailure ("Unable to decode networks: " ++ msg)
508 -- this already raised an expection, but we need it
509 -- for proper types
510 >> fail "Unable to decode networks"
511 HUnit.assertEqual "Mismatch in number of returned networks"
512 (length decoded) (length networks_with_properties)
513 mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
514 ) $ zip networks_with_properties decoded
515
516 -- | Creates a tuple of the given network combined with some of its properties
517 -- to be compared against the same properties generated by the python code.
518 getNetworkProperties :: Network -> (Int, Int, Network)
519 getNetworkProperties net =
520 (getFreeCount net, getReservedCount net, net)
521
522 -- | Tests the compatibility between Haskell-serialized node groups and their
523 -- python-decoded and encoded version.
524 casePyCompatNodegroups :: HUnit.Assertion
525 casePyCompatNodegroups = do
526 let num_groups = 500::Int
527 groups <- genSample (vectorOf num_groups genNodeGroup)
528 let serialized = J.encode groups
529 -- check for non-ASCII fields, usually due to 'arbitrary :: String'
530 mapM_ (\group -> when (any (not . isAscii) (J.encode group)) .
531 HUnit.assertFailure $
532 "Node group has non-ASCII fields: " ++ show group
533 ) groups
534 py_stdout <-
535 runPython "from ganeti import objects\n\
536 \from ganeti import serializer\n\
537 \import sys\n\
538 \group_data = serializer.Load(sys.stdin.read())\n\
539 \decoded = [objects.NodeGroup.FromDict(g) for g in group_data]\n\
540 \encoded = [g.ToDict() for g in decoded]\n\
541 \print serializer.Dump(encoded)" serialized
542 >>= checkPythonResult
543 let deserialised = J.decode py_stdout::J.Result [NodeGroup]
544 decoded <- case deserialised of
545 J.Ok ops -> return ops
546 J.Error msg ->
547 HUnit.assertFailure ("Unable to decode node groups: " ++ msg)
548 -- this already raised an expection, but we need it
549 -- for proper types
550 >> fail "Unable to decode node groups"
551 HUnit.assertEqual "Mismatch in number of returned node groups"
552 (length decoded) (length groups)
553 mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
554 ) $ zip groups decoded
555
556 -- | Generates a node group with up to 3 networks.
557 -- | FIXME: This generates still somewhat completely random data, without normal
558 -- validation rules.
559 genNodeGroup :: Gen NodeGroup
560 genNodeGroup = do
561 name <- genFQDN
562 members <- pure []
563 ndparams <- arbitrary
564 alloc_policy <- arbitrary
565 ipolicy <- arbitrary
566 diskparams <- pure (GenericContainer Map.empty)
567 num_networks <- choose (0, 3)
568 net_uuid_list <- vectorOf num_networks (arbitrary::Gen String)
569 nic_param_list <- vectorOf num_networks (arbitrary::Gen PartialNicParams)
570 net_map <- pure (GenericContainer . Map.fromList $
571 zip net_uuid_list nic_param_list)
572 hv_state <- arbitrary
573 disk_state <- arbitrary
574 -- timestamp fields
575 ctime <- arbitrary
576 mtime <- arbitrary
577 uuid <- genFQDN `suchThat` (/= name)
578 serial <- arbitrary
579 tags <- Set.fromList <$> genTags
580 let group = NodeGroup name members ndparams alloc_policy ipolicy diskparams
581 net_map hv_state disk_state ctime mtime uuid serial tags
582 return group
583
584 instance Arbitrary NodeGroup where
585 arbitrary = genNodeGroup
586
587 instance Arbitrary Ip4Address where
588 arbitrary = liftM mkIp4Address $ (,,,) <$> choose (0, 255)
589 <*> choose (0, 255)
590 <*> choose (0, 255)
591 <*> choose (0, 255)
592
593 $(genArbitrary ''Ip4Network)
594
595 -- | Tests conversions of ip addresses from/to numbers.
596 prop_ip4AddressAsNum :: Ip4Address -> Property
597 prop_ip4AddressAsNum ip4 =
598 ip4AddressFromNumber (ip4AddressToNumber ip4) ==? ip4
599
600 -- | Tests that the number produced by 'ip4AddressToNumber' has the correct
601 -- order of bytes.
602 prop_ip4AddressToNumber :: Word32 -> Property
603 prop_ip4AddressToNumber w =
604 let byte :: Int -> Word32
605 byte i = (w `div` (256^i)) `mod` 256
606 ipaddr = List.intercalate "." $ map (show . byte) [3,2..0]
607 in ip4AddressToNumber <$> readIp4Address ipaddr
608 ==? (return (toInteger w) :: Either String Integer)
609
610 -- | IsString instance for 'Ip4Address', to help write the tests.
611 instance IsString Ip4Address where
612 fromString s =
613 fromMaybe (error $ "Failed to parse address from " ++ s) (readIp4Address s)
614
615 -- | Tests a few simple cases of IPv4 next address.
616 caseNextIp4Address :: HUnit.Assertion
617 caseNextIp4Address = do
618 HUnit.assertEqual "" "0.0.0.1" $ nextIp4Address "0.0.0.0"
619 HUnit.assertEqual "" "0.0.0.0" $ nextIp4Address "255.255.255.255"
620 HUnit.assertEqual "" "1.2.3.5" $ nextIp4Address "1.2.3.4"
621 HUnit.assertEqual "" "1.3.0.0" $ nextIp4Address "1.2.255.255"
622 HUnit.assertEqual "" "1.2.255.63" $ nextIp4Address "1.2.255.62"
623
624 -- | Tests the compatibility between Haskell-serialized instances and their
625 -- python-decoded and encoded version.
626 -- Note: this can be enhanced with logical validations on the decoded objects
627 casePyCompatInstances :: HUnit.Assertion
628 casePyCompatInstances = do
629 let num_inst = 500::Int
630 instances <- genSample (vectorOf num_inst genInst)
631 let serialized = J.encode instances
632 -- check for non-ASCII fields, usually due to 'arbitrary :: String'
633 mapM_ (\inst -> when (any (not . isAscii) (J.encode inst)) .
634 HUnit.assertFailure $
635 "Instance has non-ASCII fields: " ++ show inst
636 ) instances
637 py_stdout <-
638 runPython "from ganeti import objects\n\
639 \from ganeti import serializer\n\
640 \import sys\n\
641 \inst_data = serializer.Load(sys.stdin.read())\n\
642 \decoded = [objects.Instance.FromDict(i) for i in inst_data]\n\
643 \encoded = [i.ToDict() for i in decoded]\n\
644 \print serializer.Dump(encoded)" serialized
645 >>= checkPythonResult
646 let deserialised = J.decode py_stdout::J.Result [Instance]
647 decoded <- case deserialised of
648 J.Ok ops -> return ops
649 J.Error msg ->
650 HUnit.assertFailure ("Unable to decode instance: " ++ msg)
651 -- this already raised an expection, but we need it
652 -- for proper types
653 >> fail "Unable to decode instances"
654 HUnit.assertEqual "Mismatch in number of returned instances"
655 (length decoded) (length instances)
656 mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
657 ) $ zip instances decoded
658
659 -- | A helper function for creating 'LIDPlain' values.
660 mkLIDPlain :: String -> String -> DiskLogicalId
661 mkLIDPlain = (LIDPlain .) . LogicalVolume
662
663 -- | Tests that the logical ID is correctly found in a plain disk
664 caseIncludeLogicalIdPlain :: HUnit.Assertion
665 caseIncludeLogicalIdPlain =
666 let vg_name = "xenvg" :: String
667 lv_name = "1234sdf-qwef-2134-asff-asd2-23145d.data" :: String
668 lv = LogicalVolume vg_name lv_name
669 time = TOD 0 0
670 d =
671 Disk (LIDPlain lv) [] "diskname" 1000 DiskRdWr
672 Nothing Nothing Nothing "asdfgr-1234-5123-daf3-sdfw-134f43"
673 0 time time
674 in
675 HUnit.assertBool "Unable to detect that plain Disk includes logical ID" $
676 includesLogicalId lv d
677
678 -- | Tests that the logical ID is correctly found in a DRBD disk
679 caseIncludeLogicalIdDrbd :: HUnit.Assertion
680 caseIncludeLogicalIdDrbd =
681 let vg_name = "xenvg" :: String
682 lv_name = "1234sdf-qwef-2134-asff-asd2-23145d.data" :: String
683 time = TOD 0 0
684 d =
685 Disk
686 (LIDDrbd8 "node1.example.com" "node2.example.com" 2000 1 5 "secret")
687 [ Disk (mkLIDPlain "onevg" "onelv") [] "disk1" 1000 DiskRdWr Nothing
688 Nothing Nothing "145145-asdf-sdf2-2134-asfd-534g2x" 0 time time
689 , Disk (mkLIDPlain vg_name lv_name) [] "disk2" 1000 DiskRdWr Nothing
690 Nothing Nothing "6gd3sd-423f-ag2j-563b-dg34-gj3fse" 0 time time
691 ] "diskname" 1000 DiskRdWr Nothing Nothing Nothing
692 "asdfgr-1234-5123-daf3-sdfw-134f43" 0 time time
693 in
694 HUnit.assertBool "Unable to detect that plain Disk includes logical ID" $
695 includesLogicalId (LogicalVolume vg_name lv_name) d
696
697 -- | Tests that the logical ID is correctly NOT found in a plain disk
698 caseNotIncludeLogicalIdPlain :: HUnit.Assertion
699 caseNotIncludeLogicalIdPlain =
700 let vg_name = "xenvg" :: String
701 lv_name = "1234sdf-qwef-2134-asff-asd2-23145d.data" :: String
702 time = TOD 0 0
703 d =
704 Disk (mkLIDPlain "othervg" "otherlv") [] "diskname" 1000 DiskRdWr
705 Nothing Nothing Nothing "asdfgr-1234-5123-daf3-sdfw-134f43"
706 0 time time
707 in
708 HUnit.assertBool "Unable to detect that plain Disk includes logical ID" $
709 not (includesLogicalId (LogicalVolume vg_name lv_name) d)
710
711 testSuite "Objects"
712 [ 'prop_fillDict
713 , 'prop_LogicalVolume_serialisation
714 , 'prop_LogicalVolume_deserialisationFail
715 , 'prop_Disk_serialisation
716 , 'prop_Disk_array_serialisation
717 , 'prop_Inst_serialisation
718 , 'prop_AddressPool_serialisation
719 , 'prop_Network_serialisation
720 , 'prop_Node_serialisation
721 , 'prop_Config_serialisation
722 , 'prop_FilterAction_serialisation
723 , 'prop_FilterPredicate_serialisation
724 , 'casePyCompatNetworks
725 , 'casePyCompatNodegroups
726 , 'casePyCompatInstances
727 , 'prop_ip4AddressAsNum
728 , 'prop_ip4AddressToNumber
729 , 'caseNextIp4Address
730 , 'caseIncludeLogicalIdPlain
731 , 'caseIncludeLogicalIdDrbd
732 , 'caseNotIncludeLogicalIdPlain
733 ]