code.grnet.gr Git - ganeti-local/blob - htest/Test/Ganeti/Objects.hs

   1 {-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3
   4 {-| Unittests for ganeti-htools.
   5
   6 -}
   7
   8 {-
   9
  10 Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
  11
  12 This program is free software; you can redistribute it and/or modify
  13 it under the terms of the GNU General Public License as published by
  14 the Free Software Foundation; either version 2 of the License, or
  15 (at your option) any later version.
  16
  17 This program is distributed in the hope that it will be useful, but
  18 WITHOUT ANY WARRANTY; without even the implied warranty of
  19 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 General Public License for more details.
  21
  22 You should have received a copy of the GNU General Public License
  23 along with this program; if not, write to the Free Software
  24 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  25 02110-1301, USA.
  26
  27 -}
  28
  29 module Test.Ganeti.Objects
  30   ( testObjects
  31   , Node(..)
  32   , genEmptyCluster
  33   , genValidNetwork
  34   , genNetworkType
  35   , genBitStringMaxLen
  36   ) where
  37
  38 import Test.QuickCheck
  39 import qualified Test.HUnit as HUnit
  40
  41 import Control.Applicative
  42 import Control.Monad
  43 import Data.Char
  44 import qualified Data.Map as Map
  45 import qualified Data.Set as Set
  46 import qualified Text.JSON as J
  47
  48 import Test.Ganeti.Query.Language (genJSValue)
  49 import Test.Ganeti.TestHelper
  50 import Test.Ganeti.TestCommon
  51 import Test.Ganeti.Types ()
  52
  53 import qualified Ganeti.Constants as C
  54 import Ganeti.Network
  55 import Ganeti.Objects as Objects
  56 import Ganeti.JSON
  57 import Ganeti.Types
  58
  59 {-# ANN module "HLint: ignore Use camelCase" #-}
  60
  61 -- * Arbitrary instances
  62
  63 $(genArbitrary ''PartialNDParams)
  64
  65 instance Arbitrary Node where
  66   arbitrary = Node <$> genFQDN <*> genFQDN <*> genFQDN
  67               <*> arbitrary <*> arbitrary <*> arbitrary <*> genFQDN
  68               <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
  69               <*> arbitrary <*> arbitrary <*> genFQDN <*> arbitrary
  70               <*> (Set.fromList <$> genTags)
  71
  72 $(genArbitrary ''BlockDriver)
  73
  74 $(genArbitrary ''DiskMode)
  75
  76 instance Arbitrary DiskLogicalId where
  77   arbitrary = oneof [ LIDPlain <$> arbitrary <*> arbitrary
  78                     , LIDDrbd8 <$> genFQDN <*> genFQDN <*> arbitrary
  79                                <*> arbitrary <*> arbitrary <*> arbitrary
  80                     , LIDFile  <$> arbitrary <*> arbitrary
  81                     , LIDBlockDev <$> arbitrary <*> arbitrary
  82                     , LIDRados <$> arbitrary <*> arbitrary
  83                     ]
  84
  85 -- | 'Disk' 'arbitrary' instance. Since we don't test disk hierarchy
  86 -- properties, we only generate disks with no children (FIXME), as
  87 -- generating recursive datastructures is a bit more work.
  88 instance Arbitrary Disk where
  89   arbitrary = Disk <$> arbitrary <*> pure [] <*> arbitrary
  90                    <*> arbitrary <*> arbitrary
  91
  92 -- FIXME: we should generate proper values, >=0, etc., but this is
  93 -- hard for partial ones, where all must be wrapped in a 'Maybe'
  94 $(genArbitrary ''PartialBeParams)
  95
  96 $(genArbitrary ''AdminState)
  97
  98 $(genArbitrary ''PartialNicParams)
  99
 100 $(genArbitrary ''PartialNic)
 101
 102 instance Arbitrary Instance where
 103   arbitrary =
 104     Instance
 105       <$> genFQDN <*> genFQDN <*> genFQDN -- OS name, but...
 106       <*> arbitrary
 107       -- FIXME: add non-empty hvparams when they're a proper type
 108       <*> pure (GenericContainer Map.empty) <*> arbitrary
 109       -- ... and for OSParams
 110       <*> pure (GenericContainer Map.empty) <*> arbitrary <*> arbitrary
 111       <*> arbitrary <*> arbitrary <*> arbitrary
 112       -- ts
 113       <*> arbitrary <*> arbitrary
 114       -- uuid
 115       <*> arbitrary
 116       -- serial
 117       <*> arbitrary
 118       -- tags
 119       <*> (Set.fromList <$> genTags)
 120
 121 -- | FIXME: This generates completely random data, without normal
 122 -- validation rules.
 123 $(genArbitrary ''PartialISpecParams)
 124
 125 -- | FIXME: This generates completely random data, without normal
 126 -- validation rules.
 127 $(genArbitrary ''PartialIPolicy)
 128
 129 $(genArbitrary ''FilledISpecParams)
 130 $(genArbitrary ''FilledIPolicy)
 131 $(genArbitrary ''IpFamily)
 132 $(genArbitrary ''FilledNDParams)
 133 $(genArbitrary ''FilledNicParams)
 134 $(genArbitrary ''FilledBeParams)
 135
 136 -- | No real arbitrary instance for 'ClusterHvParams' yet.
 137 instance Arbitrary ClusterHvParams where
 138   arbitrary = return $ GenericContainer Map.empty
 139
 140 -- | No real arbitrary instance for 'OsHvParams' yet.
 141 instance Arbitrary OsHvParams where
 142   arbitrary = return $ GenericContainer Map.empty
 143
 144 instance Arbitrary ClusterNicParams where
 145   arbitrary = (GenericContainer . Map.singleton C.ppDefault) <$> arbitrary
 146
 147 instance Arbitrary OsParams where
 148   arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
 149
 150 instance Arbitrary ClusterOsParams where
 151   arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
 152
 153 instance Arbitrary ClusterBeParams where
 154   arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
 155
 156 instance Arbitrary TagSet where
 157   arbitrary = Set.fromList <$> genTags
 158
 159 $(genArbitrary ''Cluster)
 160
 161 instance Arbitrary Network where
 162   arbitrary = genValidNetwork
 163
 164 -- | Generates a network instance with minimum netmasks of /24. Generating
 165 -- bigger networks slows down the tests, because long bit strings are generated
 166 -- for the reservations.
 167 genValidNetwork :: Gen Objects.Network
 168 genValidNetwork = do
 169   -- generate netmask for the IPv4 network
 170   netmask <- choose (24::Int, 30)
 171   name <- genName >>= mkNonEmpty
 172   network_type <- genMaybe genNetworkType
 173   mac_prefix <- genMaybe genName
 174   net_family <- arbitrary
 175   net <- genIp4NetWithNetmask netmask
 176   net6 <- genMaybe genIp6Net
 177   gateway <- genMaybe genIp4AddrStr
 178   gateway6 <- genMaybe genIp6Addr
 179   size <- genMaybe genJSValue
 180   res <- liftM Just (genBitString $ netmask2NumHosts netmask)
 181   ext_res <- liftM Just (genBitString $ netmask2NumHosts netmask)
 182   let n = Network name network_type mac_prefix net_family net net6 gateway
 183           gateway6 size res ext_res 0 Set.empty
 184   return n
 185
 186 -- | Generates an arbitrary network type.
 187 genNetworkType :: Gen NetworkType
 188 genNetworkType = elements [ PrivateNetwork, PublicNetwork ]
 189
 190 -- | Generate an arbitrary string consisting of '0' and '1' of the given length.
 191 genBitString :: Int -> Gen String
 192 genBitString len = vectorOf len (elements "01")
 193
 194 -- | Generate an arbitrary string consisting of '0' and '1' of the maximum given
 195 -- length.
 196 genBitStringMaxLen :: Int -> Gen String
 197 genBitStringMaxLen maxLen = choose (0, maxLen) >>= genBitString
 198
 199 -- | Generator for config data with an empty cluster (no instances),
 200 -- with N defined nodes.
 201 genEmptyCluster :: Int -> Gen ConfigData
 202 genEmptyCluster ncount = do
 203   nodes <- vector ncount
 204   version <- arbitrary
 205   let guuid = "00"
 206       nodes' = zipWith (\n idx ->
 207                           let newname = nodeName n ++ "-" ++ show idx
 208                           in (newname, n { nodeGroup = guuid,
 209                                            nodeName = newname}))
 210                nodes [(1::Int)..]
 211       nodemap = Map.fromList nodes'
 212       contnodes = if Map.size nodemap /= ncount
 213                     then error ("Inconsistent node map, duplicates in" ++
 214                                 " node name list? Names: " ++
 215                                 show (map fst nodes'))
 216                     else GenericContainer nodemap
 217       continsts = GenericContainer Map.empty
 218   grp <- arbitrary
 219   let contgroups = GenericContainer $ Map.singleton guuid grp
 220   serial <- arbitrary
 221   cluster <- resize 8 arbitrary
 222   let c = ConfigData version cluster contnodes contgroups continsts serial
 223   return c
 224
 225 -- * Test properties
 226
 227 -- | Tests that fillDict behaves correctly
 228 prop_fillDict :: [(Int, Int)] -> [(Int, Int)] -> Property
 229 prop_fillDict defaults custom =
 230   let d_map = Map.fromList defaults
 231       d_keys = map fst defaults
 232       c_map = Map.fromList custom
 233       c_keys = map fst custom
 234   in conjoin [ printTestCase "Empty custom filling"
 235                (fillDict d_map Map.empty [] == d_map)
 236              , printTestCase "Empty defaults filling"
 237                (fillDict Map.empty c_map [] == c_map)
 238              , printTestCase "Delete all keys"
 239                (fillDict d_map c_map (d_keys++c_keys) == Map.empty)
 240              ]
 241
 242 -- | Test that the serialisation of 'DiskLogicalId', which is
 243 -- implemented manually, is idempotent. Since we don't have a
 244 -- standalone JSON instance for DiskLogicalId (it's a data type that
 245 -- expands over two fields in a JSObject), we test this by actially
 246 -- testing entire Disk serialisations. So this tests two things at
 247 -- once, basically.
 248 prop_Disk_serialisation :: Disk -> Property
 249 prop_Disk_serialisation = testSerialisation
 250
 251 -- | Check that node serialisation is idempotent.
 252 prop_Node_serialisation :: Node -> Property
 253 prop_Node_serialisation = testSerialisation
 254
 255 -- | Check that instance serialisation is idempotent.
 256 prop_Inst_serialisation :: Instance -> Property
 257 prop_Inst_serialisation = testSerialisation
 258
 259 -- | Check that network serialisation is idempotent.
 260 prop_Network_serialisation :: Network -> Property
 261 prop_Network_serialisation = testSerialisation
 262
 263 -- | Check config serialisation.
 264 prop_Config_serialisation :: Property
 265 prop_Config_serialisation =
 266   forAll (choose (0, maxNodes `div` 4) >>= genEmptyCluster) testSerialisation
 267
 268 -- | Custom HUnit test to check the correspondence between Haskell-generated
 269 -- networks and their Python decoded, validated and re-encoded version.
 270 -- For the technical background of this unit test, check the documentation
 271 -- of "case_py_compat_types" of htest/Test/Ganeti/Opcodes.hs
 272 case_py_compat_networks :: HUnit.Assertion
 273 case_py_compat_networks = do
 274   let num_networks = 500::Int
 275   sample_networks <- sample' (vectorOf num_networks genValidNetwork)
 276   let networks = head sample_networks
 277       networks_with_properties = map getNetworkProperties networks
 278       serialized = J.encode networks
 279   -- check for non-ASCII fields, usually due to 'arbitrary :: String'
 280   mapM_ (\net -> when (any (not . isAscii) (J.encode net)) .
 281                  HUnit.assertFailure $
 282                  "Network has non-ASCII fields: " ++ show net
 283         ) networks
 284   py_stdout <-
 285     runPython "from ganeti import network\n\
 286               \from ganeti import objects\n\
 287               \from ganeti import serializer\n\
 288               \import sys\n\
 289               \net_data = serializer.Load(sys.stdin.read())\n\
 290               \decoded = [objects.Network.FromDict(n) for n in net_data]\n\
 291               \encoded = []\n\
 292               \for net in decoded:\n\
 293               \  a = network.AddressPool(net)\n\
 294               \  encoded.append((a.GetFreeCount(), a.GetReservedCount(), \\\n\
 295               \    net.ToDict()))\n\
 296               \print serializer.Dump(encoded)" serialized
 297     >>= checkPythonResult
 298   let deserialised = J.decode py_stdout::J.Result [(Int, Int, Network)]
 299   decoded <- case deserialised of
 300                J.Ok ops -> return ops
 301                J.Error msg ->
 302                  HUnit.assertFailure ("Unable to decode networks: " ++ msg)
 303                  -- this already raised an expection, but we need it
 304                  -- for proper types
 305                  >> fail "Unable to decode networks"
 306   HUnit.assertEqual "Mismatch in number of returned networks"
 307     (length decoded) (length networks_with_properties)
 308   mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
 309         ) $ zip decoded networks_with_properties
 310
 311 -- | Creates a tuple of the given network combined with some of its properties
 312 -- to be compared against the same properties generated by the python code.
 313 getNetworkProperties :: Network -> (Int, Int, Network)
 314 getNetworkProperties net =
 315   let maybePool = createAddressPool net
 316   in  case maybePool of
 317            (Just pool) -> (getFreeCount pool, getReservedCount pool, net)
 318            Nothing -> (-1, -1, net)
 319
 320 -- | Tests the compatibility between Haskell-serialized node groups and their
 321 -- python-decoded and encoded version.
 322 case_py_compat_nodegroups :: HUnit.Assertion
 323 case_py_compat_nodegroups = do
 324   let num_groups = 500::Int
 325   sample_groups <- sample' (vectorOf num_groups genNodeGroup)
 326   let groups = head sample_groups
 327       serialized = J.encode groups
 328   -- check for non-ASCII fields, usually due to 'arbitrary :: String'
 329   mapM_ (\group -> when (any (not . isAscii) (J.encode group)) .
 330                  HUnit.assertFailure $
 331                  "Node group has non-ASCII fields: " ++ show group
 332         ) groups
 333   py_stdout <-
 334     runPython "from ganeti import objects\n\
 335               \from ganeti import serializer\n\
 336               \import sys\n\
 337               \group_data = serializer.Load(sys.stdin.read())\n\
 338               \decoded = [objects.NodeGroup.FromDict(g) for g in group_data]\n\
 339               \encoded = [g.ToDict() for g in decoded]\n\
 340               \print serializer.Dump(encoded)" serialized
 341     >>= checkPythonResult
 342   let deserialised = J.decode py_stdout::J.Result [NodeGroup]
 343   decoded <- case deserialised of
 344                J.Ok ops -> return ops
 345                J.Error msg ->
 346                  HUnit.assertFailure ("Unable to decode node groups: " ++ msg)
 347                  -- this already raised an expection, but we need it
 348                  -- for proper types
 349                  >> fail "Unable to decode node groups"
 350   HUnit.assertEqual "Mismatch in number of returned node groups"
 351     (length decoded) (length groups)
 352   mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
 353         ) $ zip decoded groups
 354
 355 -- | Generates a node group with up to 3 networks.
 356 -- | FIXME: This generates still somewhat completely random data, without normal
 357 -- validation rules.
 358 genNodeGroup :: Gen NodeGroup
 359 genNodeGroup = do
 360   name <- genFQDN
 361   members <- pure []
 362   ndparams <- arbitrary
 363   alloc_policy <- arbitrary
 364   ipolicy <- arbitrary
 365   diskparams <- pure (GenericContainer Map.empty)
 366   num_networks <- choose (0, 3)
 367   net_uuid_list <- vectorOf num_networks (arbitrary::Gen String)
 368   nic_param_list <- vectorOf num_networks (arbitrary::Gen PartialNic)
 369   net_map <- pure (GenericContainer . Map.fromList $
 370     zip net_uuid_list nic_param_list)
 371   -- timestamp fields
 372   ctime <- arbitrary
 373   mtime <- arbitrary
 374   uuid <- arbitrary
 375   serial <- arbitrary
 376   tags <- Set.fromList <$> genTags
 377   let group = NodeGroup name members ndparams alloc_policy ipolicy diskparams
 378               net_map ctime mtime uuid serial tags
 379   return group
 380
 381 instance Arbitrary NodeGroup where
 382   arbitrary = genNodeGroup
 383
 384 testSuite "Objects"
 385   [ 'prop_fillDict
 386   , 'prop_Disk_serialisation
 387   , 'prop_Inst_serialisation
 388   , 'prop_Network_serialisation
 389   , 'prop_Node_serialisation
 390   , 'prop_Config_serialisation
 391   , 'case_py_compat_networks
 392   , 'case_py_compat_nodegroups
 393   ]