Prefer the UuidObject type class over specific functions
[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 =
125 frequency [ (2, liftM RealDisk $ RealDiskData <$> arbitrary
126 <*> pure [] <*> arbitrary
127 <*> arbitrary <*> arbitrary <*> arbitrary
128 <*> arbitrary <*> arbitrary <*> arbitrary
129 <*> arbitrary <*> arbitrary <*> arbitrary
130 <*> arbitrary)
131 , (1, liftM ForthcomingDisk $ ForthcomingDiskData <$> arbitrary
132 <*> pure [] <*> arbitrary
133 <*> arbitrary <*> arbitrary <*> arbitrary
134 <*> arbitrary <*> arbitrary <*> arbitrary
135 <*> arbitrary <*> arbitrary <*> arbitrary
136 <*> arbitrary)
137 ]
138
139 -- FIXME: we should generate proper values, >=0, etc., but this is
140 -- hard for partial ones, where all must be wrapped in a 'Maybe'
141 $(genArbitrary ''PartialBeParams)
142
143 $(genArbitrary ''AdminState)
144
145 $(genArbitrary ''AdminStateSource)
146
147 $(genArbitrary ''PartialNicParams)
148
149 $(genArbitrary ''PartialNic)
150
151 instance Arbitrary ForthcomingInstanceData where
152 arbitrary =
153 ForthcomingInstanceData
154 -- name
155 <$> genMaybe genFQDN
156 -- primary node
157 <*> genMaybe genFQDN
158 -- OS
159 <*> genMaybe genFQDN
160 -- hypervisor
161 <*> arbitrary
162 -- hvparams
163 -- FIXME: add non-empty hvparams when they're a proper type
164 <*> pure (GenericContainer Map.empty)
165 -- beparams
166 <*> arbitrary
167 -- osparams
168 <*> pure (GenericContainer Map.empty)
169 -- osparams_private
170 <*> pure (GenericContainer Map.empty)
171 -- admin_state
172 <*> genMaybe arbitrary
173 -- admin_state_source
174 <*> genMaybe arbitrary
175 -- nics
176 <*> arbitrary
177 -- disks
178 <*> vectorOf 5 arbitrary
179 -- disks active
180 <*> genMaybe arbitrary
181 -- network port
182 <*> arbitrary
183 -- ts
184 <*> arbitrary <*> arbitrary
185 -- uuid
186 <*> arbitrary
187 -- serial
188 <*> arbitrary
189 -- tags
190 <*> (Set.fromList <$> genTags)
191
192 instance Arbitrary RealInstanceData where
193 arbitrary =
194 RealInstanceData
195 -- name
196 <$> genFQDN
197 -- primary node
198 <*> genFQDN
199 -- OS
200 <*> genFQDN
201 -- hypervisor
202 <*> arbitrary
203 -- hvparams
204 -- FIXME: add non-empty hvparams when they're a proper type
205 <*> pure (GenericContainer Map.empty)
206 -- beparams
207 <*> arbitrary
208 -- osparams
209 <*> pure (GenericContainer Map.empty)
210 -- osparams_private
211 <*> pure (GenericContainer Map.empty)
212 -- admin_state
213 <*> arbitrary
214 -- admin_state_source
215 <*> arbitrary
216 -- nics
217 <*> arbitrary
218 -- disks
219 <*> vectorOf 5 arbitrary
220 -- disks active
221 <*> arbitrary
222 -- network port
223 <*> arbitrary
224 -- ts
225 <*> arbitrary <*> arbitrary
226 -- uuid
227 <*> arbitrary
228 -- serial
229 <*> arbitrary
230 -- tags
231 <*> (Set.fromList <$> genTags)
232
233 instance Arbitrary Instance where
234 arbitrary = frequency [ (1, ForthcomingInstance <$> arbitrary)
235 , (3, RealInstance <$> arbitrary)
236 ]
237
238 -- | Generates an instance that is connected to the given networks
239 -- and possibly some other networks
240 genInstWithNets :: [String] -> Gen Instance
241 genInstWithNets nets = do
242 plain_inst <- RealInstance <$> arbitrary
243 enhanceInstWithNets plain_inst nets
244
245 -- | Generates an instance that is connected to some networks
246 genInst :: Gen Instance
247 genInst = genInstWithNets []
248
249 -- | Enhances a given instance with network information, by connecting it to the
250 -- given networks and possibly some other networks
251 enhanceInstWithNets :: Instance -> [String] -> Gen Instance
252 enhanceInstWithNets inst nets = do
253 mac <- arbitrary
254 ip <- arbitrary
255 nicparams <- arbitrary
256 name <- arbitrary
257 uuid <- arbitrary
258 -- generate some more networks than the given ones
259 num_more_nets <- choose (0,3)
260 more_nets <- vectorOf num_more_nets genUUID
261 let genNic net = PartialNic mac ip nicparams net name uuid
262 partial_nics = map (genNic . Just)
263 (List.nub (nets ++ more_nets))
264 new_inst = case inst of
265 RealInstance rinst ->
266 RealInstance rinst { realInstNics = partial_nics }
267 ForthcomingInstance _ -> inst
268 return new_inst
269
270 genDiskWithChildren :: Int -> Gen Disk
271 genDiskWithChildren num_children = do
272 logicalid <- arbitrary
273 children <- vectorOf num_children (genDiskWithChildren 0)
274 nodes <- arbitrary
275 ivname <- genName
276 size <- arbitrary
277 mode <- arbitrary
278 name <- genMaybe genName
279 spindles <- arbitrary
280 params <- arbitrary
281 uuid <- genName
282 serial <- arbitrary
283 time <- arbitrary
284 return . RealDisk $
285 RealDiskData logicalid children nodes ivname size mode name
286 spindles params uuid serial time time
287
288 genDisk :: Gen Disk
289 genDisk = genDiskWithChildren 3
290
291 -- | FIXME: This generates completely random data, without normal
292 -- validation rules.
293 $(genArbitrary ''PartialISpecParams)
294
295 -- | FIXME: This generates completely random data, without normal
296 -- validation rules.
297 $(genArbitrary ''PartialIPolicy)
298
299 $(genArbitrary ''FilledISpecParams)
300 $(genArbitrary ''MinMaxISpecs)
301 $(genArbitrary ''FilledIPolicy)
302 $(genArbitrary ''IpFamily)
303 $(genArbitrary ''FilledNDParams)
304 $(genArbitrary ''FilledNicParams)
305 $(genArbitrary ''FilledBeParams)
306
307 -- | No real arbitrary instance for 'ClusterHvParams' yet.
308 instance Arbitrary ClusterHvParams where
309 arbitrary = return $ GenericContainer Map.empty
310
311 -- | No real arbitrary instance for 'OsHvParams' yet.
312 instance Arbitrary OsHvParams where
313 arbitrary = return $ GenericContainer Map.empty
314
315 -- | No real arbitrary instance for 'GroupDiskParams' yet.
316 instance Arbitrary GroupDiskParams where
317 arbitrary = return $ GenericContainer Map.empty
318
319 instance Arbitrary ClusterNicParams where
320 arbitrary = (GenericContainer . Map.singleton C.ppDefault) <$> arbitrary
321
322 instance Arbitrary OsParams where
323 arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
324
325 instance Arbitrary Objects.ClusterOsParamsPrivate where
326 arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
327
328 instance Arbitrary a => Arbitrary (Private a) where
329 arbitrary = Private <$> arbitrary
330
331 instance Arbitrary ClusterOsParams where
332 arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
333
334 instance Arbitrary ClusterBeParams where
335 arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
336
337 instance Arbitrary TagSet where
338 arbitrary = Set.fromList <$> genTags
339
340 instance Arbitrary IAllocatorParams where
341 arbitrary = return $ GenericContainer Map.empty
342
343 $(genArbitrary ''Cluster)
344
345 instance Arbitrary AddressPool where
346 arbitrary = AddressPool . BA.fromList <$> arbitrary
347
348 instance Arbitrary Network where
349 arbitrary = genValidNetwork
350
351 instance Arbitrary FilterAction where
352 arbitrary = oneof
353 [ pure Accept
354 , pure Pause
355 , pure Reject
356 , pure Continue
357 , RateLimit <$> genSlotLimit
358 ]
359
360 instance Arbitrary FilterPredicate where
361 arbitrary = oneof
362 [ FPJobId <$> arbitrary
363 , FPOpCode <$> arbitrary
364 , FPReason <$> arbitrary
365 ]
366
367 instance Arbitrary FilterRule where
368 arbitrary = FilterRule <$> arbitrary
369 <*> arbitrary
370 <*> arbitrary
371 <*> arbitrary
372 <*> arbitrary
373 <*> genUUID
374
375 -- | Generates a network instance with minimum netmasks of /24. Generating
376 -- bigger networks slows down the tests, because long bit strings are generated
377 -- for the reservations.
378 genValidNetwork :: Gen Objects.Network
379 genValidNetwork = do
380 -- generate netmask for the IPv4 network
381 netmask <- fromIntegral <$> choose (24::Int, 30)
382 name <- genName >>= mkNonEmpty
383 mac_prefix <- genMaybe genName
384 net <- arbitrary
385 net6 <- genMaybe genIp6Net
386 gateway <- genMaybe arbitrary
387 gateway6 <- genMaybe genIp6Addr
388 res <- liftM Just (genBitString $ netmask2NumHosts netmask)
389 ext_res <- liftM Just (genBitString $ netmask2NumHosts netmask)
390 uuid <- arbitrary
391 ctime <- arbitrary
392 mtime <- arbitrary
393 let n = Network name mac_prefix (mkIp4Network net netmask) net6 gateway
394 gateway6 res ext_res uuid ctime mtime 0 Set.empty
395 return n
396
397 -- | Generate an arbitrary string consisting of '0' and '1' of the given length.
398 genBitString :: Int -> Gen AddressPool
399 genBitString len =
400 (AddressPool . BA.fromList) `liftM` vectorOf len (elements [False, True])
401
402 -- | Generate an arbitrary string consisting of '0' and '1' of the maximum given
403 -- length.
404 genBitStringMaxLen :: Int -> Gen AddressPool
405 genBitStringMaxLen maxLen = choose (0, maxLen) >>= genBitString
406
407 -- | Generator for config data with an empty cluster (no instances),
408 -- with N defined nodes.
409 genEmptyCluster :: Int -> Gen ConfigData
410 genEmptyCluster ncount = do
411 nodes <- vector ncount
412 version <- arbitrary
413 grp <- arbitrary
414 let guuid = uuidOf grp
415 nodes' = zipWith (\n idx ->
416 let newname = takeWhile (/= '.') (nodeName n)
417 ++ "-" ++ show idx
418 in (newname, n { nodeGroup = guuid,
419 nodeName = newname}))
420 nodes [(1::Int)..]
421 nodemap = Map.fromList nodes'
422 contnodes = if Map.size nodemap /= ncount
423 then error ("Inconsistent node map, duplicates in" ++
424 " node name list? Names: " ++
425 show (map fst nodes'))
426 else GenericContainer nodemap
427 continsts = GenericContainer Map.empty
428 networks = GenericContainer Map.empty
429 disks = GenericContainer Map.empty
430 filters = GenericContainer Map.empty
431 let contgroups = GenericContainer $ Map.singleton guuid grp
432 serial <- arbitrary
433 -- timestamp fields
434 ctime <- arbitrary
435 mtime <- arbitrary
436 cluster <- resize 8 arbitrary
437 let c = ConfigData version cluster contnodes contgroups continsts networks
438 disks filters ctime mtime serial
439 return c
440
441 -- | FIXME: make an even simpler base version of creating a cluster.
442
443 -- | Generates config data with a couple of networks.
444 genConfigDataWithNetworks :: ConfigData -> Gen ConfigData
445 genConfigDataWithNetworks old_cfg = do
446 num_nets <- choose (0, 3)
447 -- generate a list of network names (no duplicates)
448 net_names <- genUniquesList num_nets genName >>= mapM mkNonEmpty
449 -- generate a random list of networks (possibly with duplicate names)
450 nets <- vectorOf num_nets genValidNetwork
451 -- use unique names for the networks
452 let nets_unique = map ( \(name, net) -> net { networkName = name } )
453 (zip net_names nets)
454 net_map = GenericContainer $ Map.fromList
455 (map (\n -> (uuidOf n, n)) nets_unique)
456 new_cfg = old_cfg { configNetworks = net_map }
457 return new_cfg
458
459 -- * Test properties
460
461 -- | Tests that fillDict behaves correctly
462 prop_fillDict :: [(Int, Int)] -> [(Int, Int)] -> Property
463 prop_fillDict defaults custom =
464 let d_map = Map.fromList defaults
465 d_keys = map fst defaults
466 c_map = Map.fromList custom
467 c_keys = map fst custom
468 in conjoin [ counterexample "Empty custom filling"
469 (fillDict d_map Map.empty [] == d_map)
470 , counterexample "Empty defaults filling"
471 (fillDict Map.empty c_map [] == c_map)
472 , counterexample "Delete all keys"
473 (fillDict d_map c_map (d_keys++c_keys) == Map.empty)
474 ]
475
476 prop_LogicalVolume_serialisation :: LogicalVolume -> Property
477 prop_LogicalVolume_serialisation = testSerialisation
478
479 prop_LogicalVolume_deserialisationFail :: Property
480 prop_LogicalVolume_deserialisationFail =
481 conjoin . map (testDeserialisationFail (LogicalVolume "" "")) $
482 [ J.JSArray []
483 , J.JSString $ J.toJSString "/abc"
484 , J.JSString $ J.toJSString "abc/"
485 , J.JSString $ J.toJSString "../."
486 , J.JSString $ J.toJSString "g/snapshot"
487 , J.JSString $ J.toJSString "g/a_mimagex"
488 , J.JSString $ J.toJSString "g/r;3"
489 ]
490
491 -- | Test that the serialisation of 'DiskLogicalId', which is
492 -- implemented manually, is idempotent. Since we don't have a
493 -- standalone JSON instance for DiskLogicalId (it's a data type that
494 -- expands over two fields in a JSObject), we test this by actially
495 -- testing entire Disk serialisations. So this tests two things at
496 -- once, basically.
497 prop_Disk_serialisation :: Disk -> Property
498 prop_Disk_serialisation = testSerialisation
499
500 prop_Disk_array_serialisation :: Disk -> Property
501 prop_Disk_array_serialisation = testArraySerialisation
502
503 -- | Check that node serialisation is idempotent.
504 prop_Node_serialisation :: Node -> Property
505 prop_Node_serialisation = testSerialisation
506
507 -- | Check that instance serialisation is idempotent.
508 prop_Inst_serialisation :: Instance -> Property
509 prop_Inst_serialisation = testSerialisation
510
511 -- | Check that address pool serialisation is idempotent.
512 prop_AddressPool_serialisation :: AddressPool -> Property
513 prop_AddressPool_serialisation = testSerialisation
514
515 -- | Check that network serialisation is idempotent.
516 prop_Network_serialisation :: Network -> Property
517 prop_Network_serialisation = testSerialisation
518
519 -- | Check that filter action serialisation is idempotent.
520 prop_FilterAction_serialisation :: FilterAction -> Property
521 prop_FilterAction_serialisation = testSerialisation
522
523 -- | Check that filter predicate serialisation is idempotent.
524 prop_FilterPredicate_serialisation :: FilterPredicate -> Property
525 prop_FilterPredicate_serialisation = testSerialisation
526
527 -- | Check config serialisation.
528 prop_Config_serialisation :: Property
529 prop_Config_serialisation =
530 forAll (choose (0, maxNodes `div` 4) >>= genEmptyCluster) testSerialisation
531
532 -- | Custom HUnit test to check the correspondence between Haskell-generated
533 -- networks and their Python decoded, validated and re-encoded version.
534 -- For the technical background of this unit test, check the documentation
535 -- of "case_py_compat_types" of test/hs/Test/Ganeti/Opcodes.hs
536 casePyCompatNetworks :: HUnit.Assertion
537 casePyCompatNetworks = do
538 let num_networks = 500::Int
539 networks <- genSample (vectorOf num_networks genValidNetwork)
540 let networks_with_properties = map getNetworkProperties networks
541 serialized = J.encode networks
542 -- check for non-ASCII fields, usually due to 'arbitrary :: String'
543 mapM_ (\net -> when (any (not . isAscii) (J.encode net)) .
544 HUnit.assertFailure $
545 "Network has non-ASCII fields: " ++ show net
546 ) networks
547 py_stdout <-
548 runPython "from ganeti import network\n\
549 \from ganeti import objects\n\
550 \from ganeti import serializer\n\
551 \import sys\n\
552 \net_data = serializer.Load(sys.stdin.read())\n\
553 \decoded = [objects.Network.FromDict(n) for n in net_data]\n\
554 \encoded = []\n\
555 \for net in decoded:\n\
556 \ a = network.AddressPool(net)\n\
557 \ encoded.append((a.GetFreeCount(), a.GetReservedCount(), \\\n\
558 \ net.ToDict()))\n\
559 \print serializer.Dump(encoded)" serialized
560 >>= checkPythonResult
561 let deserialised = J.decode py_stdout::J.Result [(Int, Int, Network)]
562 decoded <- case deserialised of
563 J.Ok ops -> return ops
564 J.Error msg ->
565 HUnit.assertFailure ("Unable to decode networks: " ++ msg)
566 -- this already raised an expection, but we need it
567 -- for proper types
568 >> fail "Unable to decode networks"
569 HUnit.assertEqual "Mismatch in number of returned networks"
570 (length decoded) (length networks_with_properties)
571 mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
572 ) $ zip networks_with_properties decoded
573
574 -- | Creates a tuple of the given network combined with some of its properties
575 -- to be compared against the same properties generated by the python code.
576 getNetworkProperties :: Network -> (Int, Int, Network)
577 getNetworkProperties net =
578 (getFreeCount net, getReservedCount net, net)
579
580 -- | Tests the compatibility between Haskell-serialized node groups and their
581 -- python-decoded and encoded version.
582 casePyCompatNodegroups :: HUnit.Assertion
583 casePyCompatNodegroups = do
584 let num_groups = 500::Int
585 groups <- genSample (vectorOf num_groups genNodeGroup)
586 let serialized = J.encode groups
587 -- check for non-ASCII fields, usually due to 'arbitrary :: String'
588 mapM_ (\group -> when (any (not . isAscii) (J.encode group)) .
589 HUnit.assertFailure $
590 "Node group has non-ASCII fields: " ++ show group
591 ) groups
592 py_stdout <-
593 runPython "from ganeti import objects\n\
594 \from ganeti import serializer\n\
595 \import sys\n\
596 \group_data = serializer.Load(sys.stdin.read())\n\
597 \decoded = [objects.NodeGroup.FromDict(g) for g in group_data]\n\
598 \encoded = [g.ToDict() for g in decoded]\n\
599 \print serializer.Dump(encoded)" serialized
600 >>= checkPythonResult
601 let deserialised = J.decode py_stdout::J.Result [NodeGroup]
602 decoded <- case deserialised of
603 J.Ok ops -> return ops
604 J.Error msg ->
605 HUnit.assertFailure ("Unable to decode node groups: " ++ msg)
606 -- this already raised an expection, but we need it
607 -- for proper types
608 >> fail "Unable to decode node groups"
609 HUnit.assertEqual "Mismatch in number of returned node groups"
610 (length decoded) (length groups)
611 mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
612 ) $ zip groups decoded
613
614 -- | Generates a node group with up to 3 networks.
615 -- | FIXME: This generates still somewhat completely random data, without normal
616 -- validation rules.
617 genNodeGroup :: Gen NodeGroup
618 genNodeGroup = do
619 name <- genFQDN
620 members <- pure []
621 ndparams <- arbitrary
622 alloc_policy <- arbitrary
623 ipolicy <- arbitrary
624 diskparams <- pure (GenericContainer Map.empty)
625 num_networks <- choose (0, 3)
626 net_uuid_list <- vectorOf num_networks (arbitrary::Gen String)
627 nic_param_list <- vectorOf num_networks (arbitrary::Gen PartialNicParams)
628 net_map <- pure (GenericContainer . Map.fromList $
629 zip net_uuid_list nic_param_list)
630 hv_state <- arbitrary
631 disk_state <- arbitrary
632 -- timestamp fields
633 ctime <- arbitrary
634 mtime <- arbitrary
635 uuid <- genFQDN `suchThat` (/= name)
636 serial <- arbitrary
637 tags <- Set.fromList <$> genTags
638 let group = NodeGroup name members ndparams alloc_policy ipolicy diskparams
639 net_map hv_state disk_state ctime mtime uuid serial tags
640 return group
641
642 instance Arbitrary NodeGroup where
643 arbitrary = genNodeGroup
644
645 instance Arbitrary Ip4Address where
646 arbitrary = liftM mkIp4Address $ (,,,) <$> choose (0, 255)
647 <*> choose (0, 255)
648 <*> choose (0, 255)
649 <*> choose (0, 255)
650
651 $(genArbitrary ''Ip4Network)
652
653 -- | Tests conversions of ip addresses from/to numbers.
654 prop_ip4AddressAsNum :: Ip4Address -> Property
655 prop_ip4AddressAsNum ip4 =
656 ip4AddressFromNumber (ip4AddressToNumber ip4) ==? ip4
657
658 -- | Tests that the number produced by 'ip4AddressToNumber' has the correct
659 -- order of bytes.
660 prop_ip4AddressToNumber :: Word32 -> Property
661 prop_ip4AddressToNumber w =
662 let byte :: Int -> Word32
663 byte i = (w `div` (256^i)) `mod` 256
664 ipaddr = List.intercalate "." $ map (show . byte) [3,2..0]
665 in ip4AddressToNumber <$> readIp4Address ipaddr
666 ==? (return (toInteger w) :: Either String Integer)
667
668 -- | IsString instance for 'Ip4Address', to help write the tests.
669 instance IsString Ip4Address where
670 fromString s =
671 fromMaybe (error $ "Failed to parse address from " ++ s) (readIp4Address s)
672
673 -- | Tests a few simple cases of IPv4 next address.
674 caseNextIp4Address :: HUnit.Assertion
675 caseNextIp4Address = do
676 HUnit.assertEqual "" "0.0.0.1" $ nextIp4Address "0.0.0.0"
677 HUnit.assertEqual "" "0.0.0.0" $ nextIp4Address "255.255.255.255"
678 HUnit.assertEqual "" "1.2.3.5" $ nextIp4Address "1.2.3.4"
679 HUnit.assertEqual "" "1.3.0.0" $ nextIp4Address "1.2.255.255"
680 HUnit.assertEqual "" "1.2.255.63" $ nextIp4Address "1.2.255.62"
681
682 -- | Tests the compatibility between Haskell-serialized instances and their
683 -- python-decoded and encoded version.
684 -- Note: this can be enhanced with logical validations on the decoded objects
685 casePyCompatInstances :: HUnit.Assertion
686 casePyCompatInstances = do
687 let num_inst = 500::Int
688 instances <- genSample (vectorOf num_inst genInst)
689 let serialized = J.encode instances
690 -- check for non-ASCII fields, usually due to 'arbitrary :: String'
691 mapM_ (\inst -> when (any (not . isAscii) (J.encode inst)) .
692 HUnit.assertFailure $
693 "Instance has non-ASCII fields: " ++ show inst
694 ) instances
695 py_stdout <-
696 runPython "from ganeti import objects\n\
697 \from ganeti import serializer\n\
698 \import sys\n\
699 \inst_data = serializer.Load(sys.stdin.read())\n\
700 \decoded = [objects.Instance.FromDict(i) for i in inst_data]\n\
701 \encoded = [i.ToDict() for i in decoded]\n\
702 \print serializer.Dump(encoded)" serialized
703 >>= checkPythonResult
704 let deserialised = J.decode py_stdout::J.Result [Instance]
705 decoded <- case deserialised of
706 J.Ok ops -> return ops
707 J.Error msg ->
708 HUnit.assertFailure ("Unable to decode instance: " ++ msg)
709 -- this already raised an expection, but we need it
710 -- for proper types
711 >> fail "Unable to decode instances"
712 HUnit.assertEqual "Mismatch in number of returned instances"
713 (length decoded) (length instances)
714 mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
715 ) $ zip instances decoded
716
717 -- | A helper function for creating 'LIDPlain' values.
718 mkLIDPlain :: String -> String -> DiskLogicalId
719 mkLIDPlain = (LIDPlain .) . LogicalVolume
720
721 -- | Tests that the logical ID is correctly found in a plain disk
722 caseIncludeLogicalIdPlain :: HUnit.Assertion
723 caseIncludeLogicalIdPlain =
724 let vg_name = "xenvg" :: String
725 lv_name = "1234sdf-qwef-2134-asff-asd2-23145d.data" :: String
726 lv = LogicalVolume vg_name lv_name
727 time = TOD 0 0
728 d = RealDisk $
729 RealDiskData (LIDPlain lv) [] ["node1.example.com"] "diskname"
730 1000 DiskRdWr
731 Nothing Nothing Nothing "asdfgr-1234-5123-daf3-sdfw-134f43"
732 0 time time
733 in
734 HUnit.assertBool "Unable to detect that plain Disk includes logical ID" $
735 includesLogicalId lv d
736
737 -- | Tests that the logical ID is correctly found in a DRBD disk
738 caseIncludeLogicalIdDrbd :: HUnit.Assertion
739 caseIncludeLogicalIdDrbd =
740 let vg_name = "xenvg" :: String
741 lv_name = "1234sdf-qwef-2134-asff-asd2-23145d.data" :: String
742 time = TOD 0 0
743 d = RealDisk $
744 RealDiskData
745 (LIDDrbd8 "node1.example.com" "node2.example.com" 2000 1 5 "secret")
746 [ RealDisk $ RealDiskData (mkLIDPlain "onevg" "onelv") []
747 ["node1.example.com", "node2.example.com"] "disk1" 1000 DiskRdWr
748 Nothing Nothing Nothing "145145-asdf-sdf2-2134-asfd-534g2x"
749 0 time time
750 , RealDisk $ RealDiskData (mkLIDPlain vg_name lv_name) []
751 ["node1.example.com", "node2.example.com"] "disk2" 1000 DiskRdWr
752 Nothing Nothing Nothing "6gd3sd-423f-ag2j-563b-dg34-gj3fse"
753 0 time time
754 ] ["node1.example.com", "node2.example.com"] "diskname" 1000 DiskRdWr
755 Nothing Nothing Nothing
756 "asdfgr-1234-5123-daf3-sdfw-134f43" 0 time time
757 in
758 HUnit.assertBool "Unable to detect that plain Disk includes logical ID" $
759 includesLogicalId (LogicalVolume vg_name lv_name) d
760
761 -- | Tests that the logical ID is correctly NOT found in a plain disk
762 caseNotIncludeLogicalIdPlain :: HUnit.Assertion
763 caseNotIncludeLogicalIdPlain =
764 let vg_name = "xenvg" :: String
765 lv_name = "1234sdf-qwef-2134-asff-asd2-23145d.data" :: String
766 time = TOD 0 0
767 d = RealDisk $
768 RealDiskData (mkLIDPlain "othervg" "otherlv") [] ["node1.example.com"]
769 "diskname" 1000 DiskRdWr Nothing Nothing Nothing
770 "asdfgr-1234-5123-daf3-sdfw-134f43"
771 0 time time
772 in
773 HUnit.assertBool "Unable to detect that plain Disk includes logical ID" $
774 not (includesLogicalId (LogicalVolume vg_name lv_name) d)
775
776 testSuite "Objects"
777 [ 'prop_fillDict
778 , 'prop_LogicalVolume_serialisation
779 , 'prop_LogicalVolume_deserialisationFail
780 , 'prop_Disk_serialisation
781 , 'prop_Disk_array_serialisation
782 , 'prop_Inst_serialisation
783 , 'prop_AddressPool_serialisation
784 , 'prop_Network_serialisation
785 , 'prop_Node_serialisation
786 , 'prop_Config_serialisation
787 , 'prop_FilterAction_serialisation
788 , 'prop_FilterPredicate_serialisation
789 , 'casePyCompatNetworks
790 , 'casePyCompatNodegroups
791 , 'casePyCompatInstances
792 , 'prop_ip4AddressAsNum
793 , 'prop_ip4AddressToNumber
794 , 'caseNextIp4Address
795 , 'caseIncludeLogicalIdPlain
796 , 'caseIncludeLogicalIdDrbd
797 , 'caseNotIncludeLogicalIdPlain
798 ]