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   ]