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