code.grnet.gr Git - ganeti-local/blob - test/hs/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   uuid <- arbitrary
 183   let n = Network name network_type mac_prefix net_family net net6 gateway
 184           gateway6 size res ext_res uuid 0 Set.empty
 185   return n
 186
 187 -- | Generates an arbitrary network type.
 188 genNetworkType :: Gen NetworkType
 189 genNetworkType = elements [ PrivateNetwork, PublicNetwork ]
 190
 191 -- | Generate an arbitrary string consisting of '0' and '1' of the given length.
 192 genBitString :: Int -> Gen String
 193 genBitString len = vectorOf len (elements "01")
 194
 195 -- | Generate an arbitrary string consisting of '0' and '1' of the maximum given
 196 -- length.
 197 genBitStringMaxLen :: Int -> Gen String
 198 genBitStringMaxLen maxLen = choose (0, maxLen) >>= genBitString
 199
 200 -- | Generator for config data with an empty cluster (no instances),
 201 -- with N defined nodes.
 202 genEmptyCluster :: Int -> Gen ConfigData
 203 genEmptyCluster ncount = do
 204   nodes <- vector ncount
 205   version <- arbitrary
 206   let guuid = "00"
 207       nodes' = zipWith (\n idx ->
 208                           let newname = nodeName n ++ "-" ++ show idx
 209                           in (newname, n { nodeGroup = guuid,
 210                                            nodeName = newname}))
 211                nodes [(1::Int)..]
 212       nodemap = Map.fromList nodes'
 213       contnodes = if Map.size nodemap /= ncount
 214                     then error ("Inconsistent node map, duplicates in" ++
 215                                 " node name list? Names: " ++
 216                                 show (map fst nodes'))
 217                     else GenericContainer nodemap
 218       continsts = GenericContainer Map.empty
 219       networks = GenericContainer Map.empty
 220   grp <- arbitrary
 221   let contgroups = GenericContainer $ Map.singleton guuid grp
 222   serial <- arbitrary
 223   cluster <- resize 8 arbitrary
 224   let c = ConfigData version cluster contnodes contgroups continsts networks
 225             serial
 226   return c
 227
 228 -- * Test properties
 229
 230 -- | Tests that fillDict behaves correctly
 231 prop_fillDict :: [(Int, Int)] -> [(Int, Int)] -> Property
 232 prop_fillDict defaults custom =
 233   let d_map = Map.fromList defaults
 234       d_keys = map fst defaults
 235       c_map = Map.fromList custom
 236       c_keys = map fst custom
 237   in conjoin [ printTestCase "Empty custom filling"
 238                (fillDict d_map Map.empty [] == d_map)
 239              , printTestCase "Empty defaults filling"
 240                (fillDict Map.empty c_map [] == c_map)
 241              , printTestCase "Delete all keys"
 242                (fillDict d_map c_map (d_keys++c_keys) == Map.empty)
 243              ]
 244
 245 -- | Test that the serialisation of 'DiskLogicalId', which is
 246 -- implemented manually, is idempotent. Since we don't have a
 247 -- standalone JSON instance for DiskLogicalId (it's a data type that
 248 -- expands over two fields in a JSObject), we test this by actially
 249 -- testing entire Disk serialisations. So this tests two things at
 250 -- once, basically.
 251 prop_Disk_serialisation :: Disk -> Property
 252 prop_Disk_serialisation = testSerialisation
 253
 254 -- | Check that node serialisation is idempotent.
 255 prop_Node_serialisation :: Node -> Property
 256 prop_Node_serialisation = testSerialisation
 257
 258 -- | Check that instance serialisation is idempotent.
 259 prop_Inst_serialisation :: Instance -> Property
 260 prop_Inst_serialisation = testSerialisation
 261
 262 -- | Check that network serialisation is idempotent.
 263 prop_Network_serialisation :: Network -> Property
 264 prop_Network_serialisation = testSerialisation
 265
 266 -- | Check config serialisation.
 267 prop_Config_serialisation :: Property
 268 prop_Config_serialisation =
 269   forAll (choose (0, maxNodes `div` 4) >>= genEmptyCluster) testSerialisation
 270
 271 -- | Custom HUnit test to check the correspondence between Haskell-generated
 272 -- networks and their Python decoded, validated and re-encoded version.
 273 -- For the technical background of this unit test, check the documentation
 274 -- of "case_py_compat_types" of test/hs/Test/Ganeti/Opcodes.hs
 275 case_py_compat_networks :: HUnit.Assertion
 276 case_py_compat_networks = do
 277   let num_networks = 500::Int
 278   sample_networks <- sample' (vectorOf num_networks genValidNetwork)
 279   let networks = head sample_networks
 280       networks_with_properties = map getNetworkProperties networks
 281       serialized = J.encode networks
 282   -- check for non-ASCII fields, usually due to 'arbitrary :: String'
 283   mapM_ (\net -> when (any (not . isAscii) (J.encode net)) .
 284                  HUnit.assertFailure $
 285                  "Network has non-ASCII fields: " ++ show net
 286         ) networks
 287   py_stdout <-
 288     runPython "from ganeti import network\n\
 289               \from ganeti import objects\n\
 290               \from ganeti import serializer\n\
 291               \import sys\n\
 292               \net_data = serializer.Load(sys.stdin.read())\n\
 293               \decoded = [objects.Network.FromDict(n) for n in net_data]\n\
 294               \encoded = []\n\
 295               \for net in decoded:\n\
 296               \  a = network.AddressPool(net)\n\
 297               \  encoded.append((a.GetFreeCount(), a.GetReservedCount(), \\\n\
 298               \    net.ToDict()))\n\
 299               \print serializer.Dump(encoded)" serialized
 300     >>= checkPythonResult
 301   let deserialised = J.decode py_stdout::J.Result [(Int, Int, Network)]
 302   decoded <- case deserialised of
 303                J.Ok ops -> return ops
 304                J.Error msg ->
 305                  HUnit.assertFailure ("Unable to decode networks: " ++ msg)
 306                  -- this already raised an expection, but we need it
 307                  -- for proper types
 308                  >> fail "Unable to decode networks"
 309   HUnit.assertEqual "Mismatch in number of returned networks"
 310     (length decoded) (length networks_with_properties)
 311   mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
 312         ) $ zip decoded networks_with_properties
 313
 314 -- | Creates a tuple of the given network combined with some of its properties
 315 -- to be compared against the same properties generated by the python code.
 316 getNetworkProperties :: Network -> (Int, Int, Network)
 317 getNetworkProperties net =
 318   let maybePool = createAddressPool net
 319   in  case maybePool of
 320            (Just pool) -> (getFreeCount pool, getReservedCount pool, net)
 321            Nothing -> (-1, -1, net)
 322
 323 -- | Tests the compatibility between Haskell-serialized node groups and their
 324 -- python-decoded and encoded version.
 325 case_py_compat_nodegroups :: HUnit.Assertion
 326 case_py_compat_nodegroups = do
 327   let num_groups = 500::Int
 328   sample_groups <- sample' (vectorOf num_groups genNodeGroup)
 329   let groups = head sample_groups
 330       serialized = J.encode groups
 331   -- check for non-ASCII fields, usually due to 'arbitrary :: String'
 332   mapM_ (\group -> when (any (not . isAscii) (J.encode group)) .
 333                  HUnit.assertFailure $
 334                  "Node group has non-ASCII fields: " ++ show group
 335         ) groups
 336   py_stdout <-
 337     runPython "from ganeti import objects\n\
 338               \from ganeti import serializer\n\
 339               \import sys\n\
 340               \group_data = serializer.Load(sys.stdin.read())\n\
 341               \decoded = [objects.NodeGroup.FromDict(g) for g in group_data]\n\
 342               \encoded = [g.ToDict() for g in decoded]\n\
 343               \print serializer.Dump(encoded)" serialized
 344     >>= checkPythonResult
 345   let deserialised = J.decode py_stdout::J.Result [NodeGroup]
 346   decoded <- case deserialised of
 347                J.Ok ops -> return ops
 348                J.Error msg ->
 349                  HUnit.assertFailure ("Unable to decode node groups: " ++ msg)
 350                  -- this already raised an expection, but we need it
 351                  -- for proper types
 352                  >> fail "Unable to decode node groups"
 353   HUnit.assertEqual "Mismatch in number of returned node groups"
 354     (length decoded) (length groups)
 355   mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
 356         ) $ zip decoded groups
 357
 358 -- | Generates a node group with up to 3 networks.
 359 -- | FIXME: This generates still somewhat completely random data, without normal
 360 -- validation rules.
 361 genNodeGroup :: Gen NodeGroup
 362 genNodeGroup = do
 363   name <- genFQDN
 364   members <- pure []
 365   ndparams <- arbitrary
 366   alloc_policy <- arbitrary
 367   ipolicy <- arbitrary
 368   diskparams <- pure (GenericContainer Map.empty)
 369   num_networks <- choose (0, 3)
 370   net_uuid_list <- vectorOf num_networks (arbitrary::Gen String)
 371   nic_param_list <- vectorOf num_networks (arbitrary::Gen PartialNicParams)
 372   net_map <- pure (GenericContainer . Map.fromList $
 373     zip net_uuid_list nic_param_list)
 374   -- timestamp fields
 375   ctime <- arbitrary
 376   mtime <- arbitrary
 377   uuid <- arbitrary
 378   serial <- arbitrary
 379   tags <- Set.fromList <$> genTags
 380   let group = NodeGroup name members ndparams alloc_policy ipolicy diskparams
 381               net_map ctime mtime uuid serial tags
 382   return group
 383
 384 instance Arbitrary NodeGroup where
 385   arbitrary = genNodeGroup
 386
 387 testSuite "Objects"
 388   [ 'prop_fillDict
 389   , 'prop_Disk_serialisation
 390   , 'prop_Inst_serialisation
 391   , 'prop_Network_serialisation
 392   , 'prop_Node_serialisation
 393   , 'prop_Config_serialisation
 394   , 'case_py_compat_networks
 395   , 'case_py_compat_nodegroups
 396   ]