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