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