code.grnet.gr Git - ganeti-local/blob - 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
  13 This program is free software; you can redistribute it and/or modify
  14 it under the terms of the GNU General Public License as published by
  15 the Free Software Foundation; either version 2 of the License, or
  16 (at your option) any later version.
  17
  18 This program is distributed in the hope that it will be useful, but
  19 WITHOUT ANY WARRANTY; without even the implied warranty of
  20 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 General Public License for more details.
  22
  23 You should have received a copy of the GNU General Public License
  24 along with this program; if not, write to the Free Software
  25 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  26 02110-1301, USA.
  27
  28 -}
  29
  30 module Test.Ganeti.Objects
  31   ( testObjects
  32   , Node(..)
  33   , genConfigDataWithNetworks
  34   , genDisk
  35   , genDiskWithChildren
  36   , genEmptyCluster
  37   , genInstWithNets
  38   , genValidNetwork
  39   , genBitStringMaxLen
  40   ) where
  41
  42 import Test.QuickCheck
  43 import qualified Test.HUnit as HUnit
  44
  45 import Control.Applicative
  46 import Control.Monad
  47 import Data.Char
  48 import qualified Data.List as List
  49 import qualified Data.Map as Map
  50 import Data.Maybe (fromMaybe)
  51 import qualified Data.Set as Set
  52 import GHC.Exts (IsString(..))
  53 import qualified Text.JSON as J
  54
  55 import Test.Ganeti.TestHelper
  56 import Test.Ganeti.TestCommon
  57 import Test.Ganeti.Types ()
  58
  59 import qualified Ganeti.Constants as C
  60 import Ganeti.Network
  61 import Ganeti.Objects as Objects
  62 import Ganeti.JSON
  63 import Ganeti.Types
  64
  65 -- * Arbitrary instances
  66
  67 $(genArbitrary ''PartialNDParams)
  68
  69 instance Arbitrary Node where
  70   arbitrary = Node <$> genFQDN <*> genFQDN <*> genFQDN
  71               <*> arbitrary <*> arbitrary <*> arbitrary <*> genFQDN
  72               <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
  73               <*> arbitrary <*> arbitrary <*> genFQDN <*> arbitrary
  74               <*> (Set.fromList <$> genTags)
  75
  76 $(genArbitrary ''BlockDriver)
  77
  78 $(genArbitrary ''DiskMode)
  79
  80 instance Arbitrary DiskLogicalId where
  81   arbitrary = oneof [ LIDPlain <$> arbitrary <*> arbitrary
  82                     , LIDDrbd8 <$> genFQDN <*> genFQDN <*> arbitrary
  83                                <*> arbitrary <*> arbitrary <*> arbitrary
  84                     , LIDFile  <$> arbitrary <*> arbitrary
  85                     , LIDBlockDev <$> arbitrary <*> arbitrary
  86                     , LIDRados <$> arbitrary <*> arbitrary
  87                     ]
  88
  89 -- | 'Disk' 'arbitrary' instance. Since we don't test disk hierarchy
  90 -- properties, we only generate disks with no children (FIXME), as
  91 -- generating recursive datastructures is a bit more work.
  92 instance Arbitrary Disk where
  93   arbitrary = Disk <$> arbitrary <*> pure [] <*> arbitrary
  94                    <*> arbitrary <*> arbitrary <*> arbitrary
  95                    <*> arbitrary
  96
  97 -- FIXME: we should generate proper values, >=0, etc., but this is
  98 -- hard for partial ones, where all must be wrapped in a 'Maybe'
  99 $(genArbitrary ''PartialBeParams)
 100
 101 $(genArbitrary ''AdminState)
 102
 103 $(genArbitrary ''PartialNicParams)
 104
 105 $(genArbitrary ''PartialNic)
 106
 107 instance Arbitrary Instance where
 108   arbitrary =
 109     Instance
 110       -- name
 111       <$> genFQDN
 112       -- primary node
 113       <*> genFQDN
 114       -- OS
 115       <*> genFQDN
 116       -- hypervisor
 117       <*> arbitrary
 118       -- hvparams
 119       -- FIXME: add non-empty hvparams when they're a proper type
 120       <*> pure (GenericContainer Map.empty)
 121       -- beparams
 122       <*> arbitrary
 123       -- osparams
 124       <*> pure (GenericContainer Map.empty)
 125       -- admin_state
 126       <*> arbitrary
 127       -- nics
 128       <*> arbitrary
 129       -- disks
 130       <*> arbitrary
 131       -- disk template
 132       <*> arbitrary
 133       -- network port
 134       <*> arbitrary
 135       -- ts
 136       <*> arbitrary <*> arbitrary
 137       -- uuid
 138       <*> arbitrary
 139       -- serial
 140       <*> arbitrary
 141       -- tags
 142       <*> (Set.fromList <$> genTags)
 143
 144 -- | Generates an instance that is connected to the given networks
 145 -- and possibly some other networks
 146 genInstWithNets :: [String] -> Gen Instance
 147 genInstWithNets nets = do
 148   plain_inst <- arbitrary
 149   mac <- arbitrary
 150   ip <- arbitrary
 151   nicparams <- arbitrary
 152   name <- arbitrary
 153   uuid <- arbitrary
 154   -- generate some more networks than the given ones
 155   num_more_nets <- choose (0,3)
 156   more_nets <- vectorOf num_more_nets genName
 157   let genNic net = PartialNic mac ip nicparams net name uuid
 158       partial_nics = map (genNic . Just)
 159                          (List.nub (nets ++ more_nets))
 160       new_inst = plain_inst { instNics = partial_nics }
 161   return new_inst
 162
 163 genDiskWithChildren :: Int -> Gen Disk
 164 genDiskWithChildren num_children = do
 165   logicalid <- arbitrary
 166   children <- vectorOf num_children (genDiskWithChildren 0)
 167   ivname <- genName
 168   size <- arbitrary
 169   mode <- arbitrary
 170   name <- genMaybe genName
 171   uuid <- genName
 172   let disk = Disk logicalid children ivname size mode name uuid
 173   return disk
 174
 175 genDisk :: Gen Disk
 176 genDisk = genDiskWithChildren 3
 177
 178 -- | FIXME: This generates completely random data, without normal
 179 -- validation rules.
 180 $(genArbitrary ''PartialISpecParams)
 181
 182 -- | FIXME: This generates completely random data, without normal
 183 -- validation rules.
 184 $(genArbitrary ''PartialIPolicy)
 185
 186 $(genArbitrary ''FilledISpecParams)
 187 $(genArbitrary ''MinMaxISpecs)
 188 $(genArbitrary ''FilledIPolicy)
 189 $(genArbitrary ''IpFamily)
 190 $(genArbitrary ''FilledNDParams)
 191 $(genArbitrary ''FilledNicParams)
 192 $(genArbitrary ''FilledBeParams)
 193
 194 -- | No real arbitrary instance for 'ClusterHvParams' yet.
 195 instance Arbitrary ClusterHvParams where
 196   arbitrary = return $ GenericContainer Map.empty
 197
 198 -- | No real arbitrary instance for 'OsHvParams' yet.
 199 instance Arbitrary OsHvParams where
 200   arbitrary = return $ GenericContainer Map.empty
 201
 202 instance Arbitrary ClusterNicParams where
 203   arbitrary = (GenericContainer . Map.singleton C.ppDefault) <$> arbitrary
 204
 205 instance Arbitrary OsParams where
 206   arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
 207
 208 instance Arbitrary ClusterOsParams where
 209   arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
 210
 211 instance Arbitrary ClusterBeParams where
 212   arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
 213
 214 instance Arbitrary TagSet where
 215   arbitrary = Set.fromList <$> genTags
 216
 217 $(genArbitrary ''Cluster)
 218
 219 instance Arbitrary Network where
 220   arbitrary = genValidNetwork
 221
 222 -- | Generates a network instance with minimum netmasks of /24. Generating
 223 -- bigger networks slows down the tests, because long bit strings are generated
 224 -- for the reservations.
 225 genValidNetwork :: Gen Objects.Network
 226 genValidNetwork = do
 227   -- generate netmask for the IPv4 network
 228   netmask <- fromIntegral <$> choose (24::Int, 30)
 229   name <- genName >>= mkNonEmpty
 230   mac_prefix <- genMaybe genName
 231   net <- arbitrary
 232   net6 <- genMaybe genIp6Net
 233   gateway <- genMaybe arbitrary
 234   gateway6 <- genMaybe genIp6Addr
 235   res <- liftM Just (genBitString $ netmask2NumHosts netmask)
 236   ext_res <- liftM Just (genBitString $ netmask2NumHosts netmask)
 237   uuid <- arbitrary
 238   let n = Network name mac_prefix (Ip4Network net netmask) net6 gateway
 239           gateway6 res ext_res uuid 0 Set.empty
 240   return n
 241
 242 -- | Generate an arbitrary string consisting of '0' and '1' of the given length.
 243 genBitString :: Int -> Gen String
 244 genBitString len = vectorOf len (elements "01")
 245
 246 -- | Generate an arbitrary string consisting of '0' and '1' of the maximum given
 247 -- length.
 248 genBitStringMaxLen :: Int -> Gen String
 249 genBitStringMaxLen maxLen = choose (0, maxLen) >>= genBitString
 250
 251 -- | Generator for config data with an empty cluster (no instances),
 252 -- with N defined nodes.
 253 genEmptyCluster :: Int -> Gen ConfigData
 254 genEmptyCluster ncount = do
 255   nodes <- vector ncount
 256   version <- arbitrary
 257   grp <- arbitrary
 258   let guuid = groupUuid grp
 259       nodes' = zipWith (\n idx ->
 260                           let newname = nodeName n ++ "-" ++ show idx
 261                           in (newname, n { nodeGroup = guuid,
 262                                            nodeName = newname}))
 263                nodes [(1::Int)..]
 264       nodemap = Map.fromList nodes'
 265       contnodes = if Map.size nodemap /= ncount
 266                     then error ("Inconsistent node map, duplicates in" ++
 267                                 " node name list? Names: " ++
 268                                 show (map fst nodes'))
 269                     else GenericContainer nodemap
 270       continsts = GenericContainer Map.empty
 271       networks = GenericContainer Map.empty
 272   let contgroups = GenericContainer $ Map.singleton guuid grp
 273   serial <- arbitrary
 274   cluster <- resize 8 arbitrary
 275   let c = ConfigData version cluster contnodes contgroups continsts networks
 276             serial
 277   return c
 278
 279 -- | FIXME: make an even simpler base version of creating a cluster.
 280
 281 -- | Generates config data with a couple of networks.
 282 genConfigDataWithNetworks :: ConfigData -> Gen ConfigData
 283 genConfigDataWithNetworks old_cfg = do
 284   num_nets <- choose (0, 3)
 285   -- generate a list of network names (no duplicates)
 286   net_names <- genUniquesList num_nets genName >>= mapM mkNonEmpty
 287   -- generate a random list of networks (possibly with duplicate names)
 288   nets <- vectorOf num_nets genValidNetwork
 289   -- use unique names for the networks
 290   let nets_unique = map ( \(name, net) -> net { networkName = name } )
 291         (zip net_names nets)
 292       net_map = GenericContainer $ Map.fromList
 293         (map (\n -> (networkUuid n, n)) nets_unique)
 294       new_cfg = old_cfg { configNetworks = net_map }
 295   return new_cfg
 296
 297 -- * Test properties
 298
 299 -- | Tests that fillDict behaves correctly
 300 prop_fillDict :: [(Int, Int)] -> [(Int, Int)] -> Property
 301 prop_fillDict defaults custom =
 302   let d_map = Map.fromList defaults
 303       d_keys = map fst defaults
 304       c_map = Map.fromList custom
 305       c_keys = map fst custom
 306   in conjoin [ printTestCase "Empty custom filling"
 307                (fillDict d_map Map.empty [] == d_map)
 308              , printTestCase "Empty defaults filling"
 309                (fillDict Map.empty c_map [] == c_map)
 310              , printTestCase "Delete all keys"
 311                (fillDict d_map c_map (d_keys++c_keys) == Map.empty)
 312              ]
 313
 314 -- | Test that the serialisation of 'DiskLogicalId', which is
 315 -- implemented manually, is idempotent. Since we don't have a
 316 -- standalone JSON instance for DiskLogicalId (it's a data type that
 317 -- expands over two fields in a JSObject), we test this by actially
 318 -- testing entire Disk serialisations. So this tests two things at
 319 -- once, basically.
 320 prop_Disk_serialisation :: Disk -> Property
 321 prop_Disk_serialisation = testSerialisation
 322
 323 -- | Check that node serialisation is idempotent.
 324 prop_Node_serialisation :: Node -> Property
 325 prop_Node_serialisation = testSerialisation
 326
 327 -- | Check that instance serialisation is idempotent.
 328 prop_Inst_serialisation :: Instance -> Property
 329 prop_Inst_serialisation = testSerialisation
 330
 331 -- | Check that network serialisation is idempotent.
 332 prop_Network_serialisation :: Network -> Property
 333 prop_Network_serialisation = testSerialisation
 334
 335 -- | Check config serialisation.
 336 prop_Config_serialisation :: Property
 337 prop_Config_serialisation =
 338   forAll (choose (0, maxNodes `div` 4) >>= genEmptyCluster) testSerialisation
 339
 340 -- | Custom HUnit test to check the correspondence between Haskell-generated
 341 -- networks and their Python decoded, validated and re-encoded version.
 342 -- For the technical background of this unit test, check the documentation
 343 -- of "case_py_compat_types" of test/hs/Test/Ganeti/Opcodes.hs
 344 casePyCompatNetworks :: HUnit.Assertion
 345 casePyCompatNetworks = do
 346   let num_networks = 500::Int
 347   networks <- genSample (vectorOf num_networks genValidNetwork)
 348   let networks_with_properties = map getNetworkProperties networks
 349       serialized = J.encode networks
 350   -- check for non-ASCII fields, usually due to 'arbitrary :: String'
 351   mapM_ (\net -> when (any (not . isAscii) (J.encode net)) .
 352                  HUnit.assertFailure $
 353                  "Network has non-ASCII fields: " ++ show net
 354         ) networks
 355   py_stdout <-
 356     runPython "from ganeti import network\n\
 357               \from ganeti import objects\n\
 358               \from ganeti import serializer\n\
 359               \import sys\n\
 360               \net_data = serializer.Load(sys.stdin.read())\n\
 361               \decoded = [objects.Network.FromDict(n) for n in net_data]\n\
 362               \encoded = []\n\
 363               \for net in decoded:\n\
 364               \  a = network.AddressPool(net)\n\
 365               \  encoded.append((a.GetFreeCount(), a.GetReservedCount(), \\\n\
 366               \    net.ToDict()))\n\
 367               \print serializer.Dump(encoded)" serialized
 368     >>= checkPythonResult
 369   let deserialised = J.decode py_stdout::J.Result [(Int, Int, Network)]
 370   decoded <- case deserialised of
 371                J.Ok ops -> return ops
 372                J.Error msg ->
 373                  HUnit.assertFailure ("Unable to decode networks: " ++ msg)
 374                  -- this already raised an expection, but we need it
 375                  -- for proper types
 376                  >> fail "Unable to decode networks"
 377   HUnit.assertEqual "Mismatch in number of returned networks"
 378     (length decoded) (length networks_with_properties)
 379   mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
 380         ) $ zip decoded networks_with_properties
 381
 382 -- | Creates a tuple of the given network combined with some of its properties
 383 -- to be compared against the same properties generated by the python code.
 384 getNetworkProperties :: Network -> (Int, Int, Network)
 385 getNetworkProperties net =
 386   let maybePool = createAddressPool net
 387   in  case maybePool of
 388            (Just pool) -> (getFreeCount pool, getReservedCount pool, net)
 389            Nothing -> (-1, -1, net)
 390
 391 -- | Tests the compatibility between Haskell-serialized node groups and their
 392 -- python-decoded and encoded version.
 393 casePyCompatNodegroups :: HUnit.Assertion
 394 casePyCompatNodegroups = do
 395   let num_groups = 500::Int
 396   groups <- genSample (vectorOf num_groups genNodeGroup)
 397   let serialized = J.encode groups
 398   -- check for non-ASCII fields, usually due to 'arbitrary :: String'
 399   mapM_ (\group -> when (any (not . isAscii) (J.encode group)) .
 400                  HUnit.assertFailure $
 401                  "Node group has non-ASCII fields: " ++ show group
 402         ) groups
 403   py_stdout <-
 404     runPython "from ganeti import objects\n\
 405               \from ganeti import serializer\n\
 406               \import sys\n\
 407               \group_data = serializer.Load(sys.stdin.read())\n\
 408               \decoded = [objects.NodeGroup.FromDict(g) for g in group_data]\n\
 409               \encoded = [g.ToDict() for g in decoded]\n\
 410               \print serializer.Dump(encoded)" serialized
 411     >>= checkPythonResult
 412   let deserialised = J.decode py_stdout::J.Result [NodeGroup]
 413   decoded <- case deserialised of
 414                J.Ok ops -> return ops
 415                J.Error msg ->
 416                  HUnit.assertFailure ("Unable to decode node groups: " ++ msg)
 417                  -- this already raised an expection, but we need it
 418                  -- for proper types
 419                  >> fail "Unable to decode node groups"
 420   HUnit.assertEqual "Mismatch in number of returned node groups"
 421     (length decoded) (length groups)
 422   mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
 423         ) $ zip decoded groups
 424
 425 -- | Generates a node group with up to 3 networks.
 426 -- | FIXME: This generates still somewhat completely random data, without normal
 427 -- validation rules.
 428 genNodeGroup :: Gen NodeGroup
 429 genNodeGroup = do
 430   name <- genFQDN
 431   members <- pure []
 432   ndparams <- arbitrary
 433   alloc_policy <- arbitrary
 434   ipolicy <- arbitrary
 435   diskparams <- pure (GenericContainer Map.empty)
 436   num_networks <- choose (0, 3)
 437   net_uuid_list <- vectorOf num_networks (arbitrary::Gen String)
 438   nic_param_list <- vectorOf num_networks (arbitrary::Gen PartialNicParams)
 439   net_map <- pure (GenericContainer . Map.fromList $
 440     zip net_uuid_list nic_param_list)
 441   -- timestamp fields
 442   ctime <- arbitrary
 443   mtime <- arbitrary
 444   uuid <- genFQDN `suchThat` (/= name)
 445   serial <- arbitrary
 446   tags <- Set.fromList <$> genTags
 447   let group = NodeGroup name members ndparams alloc_policy ipolicy diskparams
 448               net_map ctime mtime uuid serial tags
 449   return group
 450
 451 instance Arbitrary NodeGroup where
 452   arbitrary = genNodeGroup
 453
 454 $(genArbitrary ''Ip4Address)
 455
 456 $(genArbitrary ''Ip4Network)
 457
 458 -- | Helper to compute absolute value of an IPv4 address.
 459 ip4AddrValue :: Ip4Address -> Integer
 460 ip4AddrValue (Ip4Address a b c d) =
 461   fromIntegral a * (2^(24::Integer)) +
 462   fromIntegral b * (2^(16::Integer)) +
 463   fromIntegral c * (2^(8::Integer)) + fromIntegral d
 464
 465 -- | Tests that any difference between IPv4 consecutive addresses is 1.
 466 prop_nextIp4Address :: Ip4Address -> Property
 467 prop_nextIp4Address ip4 =
 468   ip4AddrValue (nextIp4Address ip4) ==? ip4AddrValue ip4 + 1
 469
 470 -- | IsString instance for 'Ip4Address', to help write the tests.
 471 instance IsString Ip4Address where
 472   fromString s =
 473     fromMaybe (error $ "Failed to parse address from " ++ s) (readIp4Address s)
 474
 475 -- | Tests a few simple cases of IPv4 next address.
 476 caseNextIp4Address :: HUnit.Assertion
 477 caseNextIp4Address = do
 478   HUnit.assertEqual "" "0.0.0.1" $ nextIp4Address "0.0.0.0"
 479   HUnit.assertEqual "" "0.0.0.0" $ nextIp4Address "255.255.255.255"
 480   HUnit.assertEqual "" "1.2.3.5" $ nextIp4Address "1.2.3.4"
 481   HUnit.assertEqual "" "1.3.0.0" $ nextIp4Address "1.2.255.255"
 482   HUnit.assertEqual "" "1.2.255.63" $ nextIp4Address "1.2.255.62"
 483
 484 testSuite "Objects"
 485   [ 'prop_fillDict
 486   , 'prop_Disk_serialisation
 487   , 'prop_Inst_serialisation
 488   , 'prop_Network_serialisation
 489   , 'prop_Node_serialisation
 490   , 'prop_Config_serialisation
 491   , 'casePyCompatNetworks
 492   , 'casePyCompatNodegroups
 493   , 'prop_nextIp4Address
 494   , 'caseNextIp4Address
 495   ]