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 = groupUuid 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 -> (networkUuid 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
 746            (Private "secret"))
 747           [ RealDisk $ RealDiskData (mkLIDPlain "onevg" "onelv") []
 748               ["node1.example.com", "node2.example.com"] "disk1" 1000 DiskRdWr
 749               Nothing Nothing Nothing "145145-asdf-sdf2-2134-asfd-534g2x"
 750               0 time time
 751           , RealDisk $ RealDiskData (mkLIDPlain vg_name lv_name) []
 752               ["node1.example.com", "node2.example.com"] "disk2" 1000 DiskRdWr
 753               Nothing Nothing Nothing "6gd3sd-423f-ag2j-563b-dg34-gj3fse"
 754               0 time time
 755           ] ["node1.example.com", "node2.example.com"] "diskname" 1000 DiskRdWr
 756           Nothing Nothing Nothing
 757           "asdfgr-1234-5123-daf3-sdfw-134f43" 0 time time
 758   in
 759     HUnit.assertBool "Unable to detect that plain Disk includes logical ID" $
 760       includesLogicalId (LogicalVolume vg_name lv_name) d
 761
 762 -- | Tests that the logical ID is correctly NOT found in a plain disk
 763 caseNotIncludeLogicalIdPlain :: HUnit.Assertion
 764 caseNotIncludeLogicalIdPlain =
 765   let vg_name = "xenvg" :: String
 766       lv_name = "1234sdf-qwef-2134-asff-asd2-23145d.data" :: String
 767       time = TOD 0 0
 768       d = RealDisk $
 769         RealDiskData (mkLIDPlain "othervg" "otherlv") [] ["node1.example.com"]
 770           "diskname" 1000 DiskRdWr Nothing Nothing Nothing
 771           "asdfgr-1234-5123-daf3-sdfw-134f43"
 772           0 time time
 773   in
 774     HUnit.assertBool "Unable to detect that plain Disk includes logical ID" $
 775       not (includesLogicalId (LogicalVolume vg_name lv_name) d)
 776
 777 testSuite "Objects"
 778   [ 'prop_fillDict
 779   , 'prop_LogicalVolume_serialisation
 780   , 'prop_LogicalVolume_deserialisationFail
 781   , 'prop_Disk_serialisation
 782   , 'prop_Disk_array_serialisation
 783   , 'prop_Inst_serialisation
 784   , 'prop_AddressPool_serialisation
 785   , 'prop_Network_serialisation
 786   , 'prop_Node_serialisation
 787   , 'prop_Config_serialisation
 788   , 'prop_FilterAction_serialisation
 789   , 'prop_FilterPredicate_serialisation
 790   , 'casePyCompatNetworks
 791   , 'casePyCompatNodegroups
 792   , 'casePyCompatInstances
 793   , 'prop_ip4AddressAsNum
 794   , 'prop_ip4AddressToNumber
 795   , 'caseNextIp4Address
 796   , 'caseIncludeLogicalIdPlain
 797   , 'caseIncludeLogicalIdDrbd
 798   , 'caseNotIncludeLogicalIdPlain
 799   ]