Store keys 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 = map UTF8.fromString $ 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 (UTF8.fromString C.ppDefault))
327 <$> arbitrary
328
329 instance Arbitrary OsParams where
330 arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
331
332 instance Arbitrary Objects.ClusterOsParamsPrivate where
333 arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
334
335 instance Arbitrary a => Arbitrary (Private a) where
336 arbitrary = Private <$> arbitrary
337
338 instance Arbitrary ClusterOsParams where
339 arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
340
341 instance Arbitrary ClusterBeParams where
342 arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
343
344 instance Arbitrary TagSet where
345 arbitrary = Set.fromList <$> genTags
346
347 instance Arbitrary IAllocatorParams where
348 arbitrary = return $ GenericContainer Map.empty
349
350 $(genArbitrary ''Cluster)
351
352 instance Arbitrary AddressPool where
353 arbitrary = AddressPool . BA.fromList <$> arbitrary
354
355 instance Arbitrary Network where
356 arbitrary = genValidNetwork
357
358 instance Arbitrary FilterAction where
359 arbitrary = oneof
360 [ pure Accept
361 , pure Pause
362 , pure Reject
363 , pure Continue
364 , RateLimit <$> genSlotLimit
365 ]
366
367 instance Arbitrary FilterPredicate where
368 arbitrary = oneof
369 [ FPJobId <$> arbitrary
370 , FPOpCode <$> arbitrary
371 , FPReason <$> arbitrary
372 ]
373
374 instance Arbitrary FilterRule where
375 arbitrary = FilterRule <$> arbitrary
376 <*> arbitrary
377 <*> arbitrary
378 <*> arbitrary
379 <*> arbitrary
380 <*> fmap UTF8.fromString genUUID
381
382 -- | Generates a network instance with minimum netmasks of /24. Generating
383 -- bigger networks slows down the tests, because long bit strings are generated
384 -- for the reservations.
385 genValidNetwork :: Gen Objects.Network
386 genValidNetwork = do
387 -- generate netmask for the IPv4 network
388 netmask <- fromIntegral <$> choose (24::Int, 30)
389 name <- genName >>= mkNonEmpty
390 mac_prefix <- genMaybe genName
391 net <- arbitrary
392 net6 <- genMaybe genIp6Net
393 gateway <- genMaybe arbitrary
394 gateway6 <- genMaybe genIp6Addr
395 res <- liftM Just (genBitString $ netmask2NumHosts netmask)
396 ext_res <- liftM Just (genBitString $ netmask2NumHosts netmask)
397 uuid <- arbitrary
398 ctime <- arbitrary
399 mtime <- arbitrary
400 let n = Network name mac_prefix (mkIp4Network net netmask) net6 gateway
401 gateway6 res ext_res uuid ctime mtime 0 Set.empty
402 return n
403
404 -- | Generate an arbitrary string consisting of '0' and '1' of the given length.
405 genBitString :: Int -> Gen AddressPool
406 genBitString len =
407 (AddressPool . BA.fromList) `liftM` vectorOf len (elements [False, True])
408
409 -- | Generate an arbitrary string consisting of '0' and '1' of the maximum given
410 -- length.
411 genBitStringMaxLen :: Int -> Gen AddressPool
412 genBitStringMaxLen maxLen = choose (0, maxLen) >>= genBitString
413
414 -- | Generator for config data with an empty cluster (no instances),
415 -- with N defined nodes.
416 genEmptyCluster :: Int -> Gen ConfigData
417 genEmptyCluster ncount = do
418 nodes <- vector ncount
419 version <- arbitrary
420 grp <- arbitrary
421 let guuid = uuidOf grp
422 nodes' = zipWith (\n idx ->
423 let newname = takeWhile (/= '.') (nodeName n)
424 ++ "-" ++ show idx
425 in ( UTF8.fromString newname
426 , n { nodeGroup = guuid, nodeName = newname}))
427 nodes [(1::Int)..]
428 nodemap = Map.fromList nodes'
429 contnodes = if Map.size nodemap /= ncount
430 then error ("Inconsistent node map, duplicates in" ++
431 " node name list? Names: " ++
432 show (map fst nodes'))
433 else GenericContainer nodemap
434 continsts = GenericContainer Map.empty
435 networks = GenericContainer Map.empty
436 disks = GenericContainer Map.empty
437 filters = GenericContainer Map.empty
438 let contgroups = GenericContainer $ Map.singleton (UTF8.fromString guuid) grp
439 serial <- arbitrary
440 -- timestamp fields
441 ctime <- arbitrary
442 mtime <- arbitrary
443 cluster <- resize 8 arbitrary
444 let c = ConfigData version cluster contnodes contgroups continsts networks
445 disks filters ctime mtime serial
446 return c
447
448 -- | FIXME: make an even simpler base version of creating a cluster.
449
450 -- | Generates config data with a couple of networks.
451 genConfigDataWithNetworks :: ConfigData -> Gen ConfigData
452 genConfigDataWithNetworks old_cfg = do
453 num_nets <- choose (0, 3)
454 -- generate a list of network names (no duplicates)
455 net_names <- genUniquesList num_nets genName >>= mapM mkNonEmpty
456 -- generate a random list of networks (possibly with duplicate names)
457 nets <- vectorOf num_nets genValidNetwork
458 -- use unique names for the networks
459 let nets_unique = map ( \(name, net) -> net { networkName = name } )
460 (zip net_names nets)
461 net_map = GenericContainer $ Map.fromList
462 (map (\n -> (UTF8.fromString $ uuidOf n, n)) nets_unique)
463 new_cfg = old_cfg { configNetworks = net_map }
464 return new_cfg
465
466 -- * Test properties
467
468 -- | Tests that fillDict behaves correctly
469 prop_fillDict :: [(Int, Int)] -> [(Int, Int)] -> Property
470 prop_fillDict defaults custom =
471 let d_map = Map.fromList defaults
472 d_keys = map fst defaults
473 c_map = Map.fromList custom
474 c_keys = map fst custom
475 in conjoin [ counterexample "Empty custom filling"
476 (fillDict d_map Map.empty [] == d_map)
477 , counterexample "Empty defaults filling"
478 (fillDict Map.empty c_map [] == c_map)
479 , counterexample "Delete all keys"
480 (fillDict d_map c_map (d_keys++c_keys) == Map.empty)
481 ]
482
483 prop_LogicalVolume_serialisation :: LogicalVolume -> Property
484 prop_LogicalVolume_serialisation = testSerialisation
485
486 prop_LogicalVolume_deserialisationFail :: Property
487 prop_LogicalVolume_deserialisationFail =
488 conjoin . map (testDeserialisationFail (LogicalVolume "" "")) $
489 [ J.JSArray []
490 , J.JSString $ J.toJSString "/abc"
491 , J.JSString $ J.toJSString "abc/"
492 , J.JSString $ J.toJSString "../."
493 , J.JSString $ J.toJSString "g/snapshot"
494 , J.JSString $ J.toJSString "g/a_mimagex"
495 , J.JSString $ J.toJSString "g/r;3"
496 ]
497
498 -- | Test that the serialisation of 'DiskLogicalId', which is
499 -- implemented manually, is idempotent. Since we don't have a
500 -- standalone JSON instance for DiskLogicalId (it's a data type that
501 -- expands over two fields in a JSObject), we test this by actially
502 -- testing entire Disk serialisations. So this tests two things at
503 -- once, basically.
504 prop_Disk_serialisation :: Disk -> Property
505 prop_Disk_serialisation = testSerialisation
506
507 prop_Disk_array_serialisation :: Disk -> Property
508 prop_Disk_array_serialisation = testArraySerialisation
509
510 -- | Check that node serialisation is idempotent.
511 prop_Node_serialisation :: Node -> Property
512 prop_Node_serialisation = testSerialisation
513
514 -- | Check that instance serialisation is idempotent.
515 prop_Inst_serialisation :: Instance -> Property
516 prop_Inst_serialisation = testSerialisation
517
518 -- | Check that address pool serialisation is idempotent.
519 prop_AddressPool_serialisation :: AddressPool -> Property
520 prop_AddressPool_serialisation = testSerialisation
521
522 -- | Check that network serialisation is idempotent.
523 prop_Network_serialisation :: Network -> Property
524 prop_Network_serialisation = testSerialisation
525
526 -- | Check that filter action serialisation is idempotent.
527 prop_FilterAction_serialisation :: FilterAction -> Property
528 prop_FilterAction_serialisation = testSerialisation
529
530 -- | Check that filter predicate serialisation is idempotent.
531 prop_FilterPredicate_serialisation :: FilterPredicate -> Property
532 prop_FilterPredicate_serialisation = testSerialisation
533
534 -- | Check config serialisation.
535 prop_Config_serialisation :: Property
536 prop_Config_serialisation =
537 forAll (choose (0, maxNodes `div` 4) >>= genEmptyCluster) testSerialisation
538
539 -- | Custom HUnit test to check the correspondence between Haskell-generated
540 -- networks and their Python decoded, validated and re-encoded version.
541 -- For the technical background of this unit test, check the documentation
542 -- of "case_py_compat_types" of test/hs/Test/Ganeti/Opcodes.hs
543 casePyCompatNetworks :: HUnit.Assertion
544 casePyCompatNetworks = do
545 let num_networks = 500::Int
546 networks <- genSample (vectorOf num_networks genValidNetwork)
547 let networks_with_properties = map getNetworkProperties networks
548 serialized = J.encode networks
549 -- check for non-ASCII fields, usually due to 'arbitrary :: String'
550 mapM_ (\net -> when (any (not . isAscii) (J.encode net)) .
551 HUnit.assertFailure $
552 "Network has non-ASCII fields: " ++ show net
553 ) networks
554 py_stdout <-
555 runPython "from ganeti import network\n\
556 \from ganeti import objects\n\
557 \from ganeti import serializer\n\
558 \import sys\n\
559 \net_data = serializer.Load(sys.stdin.read())\n\
560 \decoded = [objects.Network.FromDict(n) for n in net_data]\n\
561 \encoded = []\n\
562 \for net in decoded:\n\
563 \ a = network.AddressPool(net)\n\
564 \ encoded.append((a.GetFreeCount(), a.GetReservedCount(), \\\n\
565 \ net.ToDict()))\n\
566 \print serializer.Dump(encoded)" serialized
567 >>= checkPythonResult
568 let deserialised = J.decode py_stdout::J.Result [(Int, Int, Network)]
569 decoded <- case deserialised of
570 J.Ok ops -> return ops
571 J.Error msg ->
572 HUnit.assertFailure ("Unable to decode networks: " ++ msg)
573 -- this already raised an expection, but we need it
574 -- for proper types
575 >> fail "Unable to decode networks"
576 HUnit.assertEqual "Mismatch in number of returned networks"
577 (length decoded) (length networks_with_properties)
578 mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
579 ) $ zip networks_with_properties decoded
580
581 -- | Creates a tuple of the given network combined with some of its properties
582 -- to be compared against the same properties generated by the python code.
583 getNetworkProperties :: Network -> (Int, Int, Network)
584 getNetworkProperties net =
585 (getFreeCount net, getReservedCount net, net)
586
587 -- | Tests the compatibility between Haskell-serialized node groups and their
588 -- python-decoded and encoded version.
589 casePyCompatNodegroups :: HUnit.Assertion
590 casePyCompatNodegroups = do
591 let num_groups = 500::Int
592 groups <- genSample (vectorOf num_groups genNodeGroup)
593 let serialized = J.encode groups
594 -- check for non-ASCII fields, usually due to 'arbitrary :: String'
595 mapM_ (\group -> when (any (not . isAscii) (J.encode group)) .
596 HUnit.assertFailure $
597 "Node group has non-ASCII fields: " ++ show group
598 ) groups
599 py_stdout <-
600 runPython "from ganeti import objects\n\
601 \from ganeti import serializer\n\
602 \import sys\n\
603 \group_data = serializer.Load(sys.stdin.read())\n\
604 \decoded = [objects.NodeGroup.FromDict(g) for g in group_data]\n\
605 \encoded = [g.ToDict() for g in decoded]\n\
606 \print serializer.Dump(encoded)" serialized
607 >>= checkPythonResult
608 let deserialised = J.decode py_stdout::J.Result [NodeGroup]
609 decoded <- case deserialised of
610 J.Ok ops -> return ops
611 J.Error msg ->
612 HUnit.assertFailure ("Unable to decode node groups: " ++ msg)
613 -- this already raised an expection, but we need it
614 -- for proper types
615 >> fail "Unable to decode node groups"
616 HUnit.assertEqual "Mismatch in number of returned node groups"
617 (length decoded) (length groups)
618 mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
619 ) $ zip groups decoded
620
621 -- | Generates a node group with up to 3 networks.
622 -- | FIXME: This generates still somewhat completely random data, without normal
623 -- validation rules.
624 genNodeGroup :: Gen NodeGroup
625 genNodeGroup = do
626 name <- genFQDN
627 members <- pure []
628 ndparams <- arbitrary
629 alloc_policy <- arbitrary
630 ipolicy <- arbitrary
631 diskparams <- pure (GenericContainer Map.empty)
632 num_networks <- choose (0, 3)
633 net_uuid_list <- vectorOf num_networks (arbitrary::Gen BS.ByteString)
634 nic_param_list <- vectorOf num_networks (arbitrary::Gen PartialNicParams)
635 net_map <- pure (GenericContainer . Map.fromList $
636 zip net_uuid_list nic_param_list)
637 hv_state <- arbitrary
638 disk_state <- arbitrary
639 -- timestamp fields
640 ctime <- arbitrary
641 mtime <- arbitrary
642 uuid <- genFQDN `suchThat` (/= name)
643 serial <- arbitrary
644 tags <- Set.fromList <$> genTags
645 let group = NodeGroup name members ndparams alloc_policy ipolicy diskparams
646 net_map hv_state disk_state ctime mtime (UTF8.fromString uuid)
647 serial tags
648 return group
649
650 instance Arbitrary NodeGroup where
651 arbitrary = genNodeGroup
652
653 instance Arbitrary Ip4Address where
654 arbitrary = liftM mkIp4Address $ (,,,) <$> choose (0, 255)
655 <*> choose (0, 255)
656 <*> choose (0, 255)
657 <*> choose (0, 255)
658
659 $(genArbitrary ''Ip4Network)
660
661 -- | Tests conversions of ip addresses from/to numbers.
662 prop_ip4AddressAsNum :: Ip4Address -> Property
663 prop_ip4AddressAsNum ip4 =
664 ip4AddressFromNumber (ip4AddressToNumber ip4) ==? ip4
665
666 -- | Tests that the number produced by 'ip4AddressToNumber' has the correct
667 -- order of bytes.
668 prop_ip4AddressToNumber :: Word32 -> Property
669 prop_ip4AddressToNumber w =
670 let byte :: Int -> Word32
671 byte i = (w `div` (256^i)) `mod` 256
672 ipaddr = List.intercalate "." $ map (show . byte) [3,2..0]
673 in ip4AddressToNumber <$> readIp4Address ipaddr
674 ==? (return (toInteger w) :: Either String Integer)
675
676 -- | IsString instance for 'Ip4Address', to help write the tests.
677 instance IsString Ip4Address where
678 fromString s =
679 fromMaybe (error $ "Failed to parse address from " ++ s) (readIp4Address s)
680
681 -- | Tests a few simple cases of IPv4 next address.
682 caseNextIp4Address :: HUnit.Assertion
683 caseNextIp4Address = do
684 HUnit.assertEqual "" "0.0.0.1" $ nextIp4Address "0.0.0.0"
685 HUnit.assertEqual "" "0.0.0.0" $ nextIp4Address "255.255.255.255"
686 HUnit.assertEqual "" "1.2.3.5" $ nextIp4Address "1.2.3.4"
687 HUnit.assertEqual "" "1.3.0.0" $ nextIp4Address "1.2.255.255"
688 HUnit.assertEqual "" "1.2.255.63" $ nextIp4Address "1.2.255.62"
689
690 -- | Tests the compatibility between Haskell-serialized instances and their
691 -- python-decoded and encoded version.
692 -- Note: this can be enhanced with logical validations on the decoded objects
693 casePyCompatInstances :: HUnit.Assertion
694 casePyCompatInstances = do
695 let num_inst = 500::Int
696 instances <- genSample (vectorOf num_inst genInst)
697 let serialized = J.encode instances
698 -- check for non-ASCII fields, usually due to 'arbitrary :: String'
699 mapM_ (\inst -> when (any (not . isAscii) (J.encode inst)) .
700 HUnit.assertFailure $
701 "Instance has non-ASCII fields: " ++ show inst
702 ) instances
703 py_stdout <-
704 runPython "from ganeti import objects\n\
705 \from ganeti import serializer\n\
706 \import sys\n\
707 \inst_data = serializer.Load(sys.stdin.read())\n\
708 \decoded = [objects.Instance.FromDict(i) for i in inst_data]\n\
709 \encoded = [i.ToDict() for i in decoded]\n\
710 \print serializer.Dump(encoded)" serialized
711 >>= checkPythonResult
712 let deserialised = J.decode py_stdout::J.Result [Instance]
713 decoded <- case deserialised of
714 J.Ok ops -> return ops
715 J.Error msg ->
716 HUnit.assertFailure ("Unable to decode instance: " ++ msg)
717 -- this already raised an expection, but we need it
718 -- for proper types
719 >> fail "Unable to decode instances"
720 HUnit.assertEqual "Mismatch in number of returned instances"
721 (length decoded) (length instances)
722 mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
723 ) $ zip instances decoded
724
725 -- | A helper function for creating 'LIDPlain' values.
726 mkLIDPlain :: String -> String -> DiskLogicalId
727 mkLIDPlain = (LIDPlain .) . LogicalVolume
728
729 -- | Tests that the logical ID is correctly found in a plain disk
730 caseIncludeLogicalIdPlain :: HUnit.Assertion
731 caseIncludeLogicalIdPlain =
732 let vg_name = "xenvg" :: String
733 lv_name = "1234sdf-qwef-2134-asff-asd2-23145d.data" :: String
734 lv = LogicalVolume vg_name lv_name
735 time = TOD 0 0
736 d = RealDisk $
737 RealDiskData (LIDPlain lv) [] ["node1.example.com"] "diskname"
738 1000 DiskRdWr
739 Nothing Nothing Nothing "asdfgr-1234-5123-daf3-sdfw-134f43"
740 0 time time
741 in
742 HUnit.assertBool "Unable to detect that plain Disk includes logical ID" $
743 includesLogicalId lv d
744
745 -- | Tests that the logical ID is correctly found in a DRBD disk
746 caseIncludeLogicalIdDrbd :: HUnit.Assertion
747 caseIncludeLogicalIdDrbd =
748 let vg_name = "xenvg" :: String
749 lv_name = "1234sdf-qwef-2134-asff-asd2-23145d.data" :: String
750 time = TOD 0 0
751 d = RealDisk $
752 RealDiskData
753 (LIDDrbd8 "node1.example.com" "node2.example.com" 2000 1 5 "secret")
754 [ RealDisk $ RealDiskData (mkLIDPlain "onevg" "onelv") []
755 ["node1.example.com", "node2.example.com"] "disk1" 1000 DiskRdWr
756 Nothing Nothing Nothing "145145-asdf-sdf2-2134-asfd-534g2x"
757 0 time time
758 , RealDisk $ RealDiskData (mkLIDPlain vg_name lv_name) []
759 ["node1.example.com", "node2.example.com"] "disk2" 1000 DiskRdWr
760 Nothing Nothing Nothing "6gd3sd-423f-ag2j-563b-dg34-gj3fse"
761 0 time time
762 ] ["node1.example.com", "node2.example.com"] "diskname" 1000 DiskRdWr
763 Nothing Nothing Nothing
764 "asdfgr-1234-5123-daf3-sdfw-134f43" 0 time time
765 in
766 HUnit.assertBool "Unable to detect that plain Disk includes logical ID" $
767 includesLogicalId (LogicalVolume vg_name lv_name) d
768
769 -- | Tests that the logical ID is correctly NOT found in a plain disk
770 caseNotIncludeLogicalIdPlain :: HUnit.Assertion
771 caseNotIncludeLogicalIdPlain =
772 let vg_name = "xenvg" :: String
773 lv_name = "1234sdf-qwef-2134-asff-asd2-23145d.data" :: String
774 time = TOD 0 0
775 d = RealDisk $
776 RealDiskData (mkLIDPlain "othervg" "otherlv") [] ["node1.example.com"]
777 "diskname" 1000 DiskRdWr Nothing Nothing Nothing
778 "asdfgr-1234-5123-daf3-sdfw-134f43"
779 0 time time
780 in
781 HUnit.assertBool "Unable to detect that plain Disk includes logical ID" $
782 not (includesLogicalId (LogicalVolume vg_name lv_name) d)
783
784 testSuite "Objects"
785 [ 'prop_fillDict
786 , 'prop_LogicalVolume_serialisation
787 , 'prop_LogicalVolume_deserialisationFail
788 , 'prop_Disk_serialisation
789 , 'prop_Disk_array_serialisation
790 , 'prop_Inst_serialisation
791 , 'prop_AddressPool_serialisation
792 , 'prop_Network_serialisation
793 , 'prop_Node_serialisation
794 , 'prop_Config_serialisation
795 , 'prop_FilterAction_serialisation
796 , 'prop_FilterPredicate_serialisation
797 , 'casePyCompatNetworks
798 , 'casePyCompatNodegroups
799 , 'casePyCompatInstances
800 , 'prop_ip4AddressAsNum
801 , 'prop_ip4AddressToNumber
802 , 'caseNextIp4Address
803 , 'caseIncludeLogicalIdPlain
804 , 'caseIncludeLogicalIdDrbd
805 , 'caseNotIncludeLogicalIdPlain
806 ]