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