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