Statistics
| Branch: | Tag: | Revision:

root / test / hs / Test / Ganeti / Objects.hs @ 22ff02a7

History | View | Annotate | Download (13.9 kB)

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
  ]