Objects.hs 14.2 KB
Newer Older
1
{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-}
Iustin Pop's avatar
Iustin Pop committed
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
{-# OPTIONS_GHC -fno-warn-orphans #-}

{-| Unittests for ganeti-htools.

-}

{-

Copyright (C) 2009, 2010, 2011, 2012 Google Inc.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.

-}

Iustin Pop's avatar
Iustin Pop committed
29
30
module Test.Ganeti.Objects
  ( testObjects
31
  , Node(..)
32
  , genEmptyCluster
33
34
35
  , genValidNetwork
  , genNetworkType
  , genBitStringMaxLen
Iustin Pop's avatar
Iustin Pop committed
36
  ) where
Iustin Pop's avatar
Iustin Pop committed
37

38
import Test.QuickCheck
39
import qualified Test.HUnit as HUnit
40

Iustin Pop's avatar
Iustin Pop committed
41
import Control.Applicative
42
43
import Control.Monad
import Data.Char
Iustin Pop's avatar
Iustin Pop committed
44
import qualified Data.Map as Map
Iustin Pop's avatar
Iustin Pop committed
45
import qualified Data.Set as Set
46
import qualified Text.JSON as J
Iustin Pop's avatar
Iustin Pop committed
47

48
import Test.Ganeti.Query.Language (genJSValue)
Iustin Pop's avatar
Iustin Pop committed
49
import Test.Ganeti.TestHelper
Iustin Pop's avatar
Iustin Pop committed
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
Iustin Pop's avatar
Iustin Pop committed
56
import Ganeti.JSON
57
import Ganeti.Types
58

Iustin Pop's avatar
Iustin Pop committed
59
60
{-# ANN module "HLint: ignore Use camelCase" #-}

61
-- * Arbitrary instances
Iustin Pop's avatar
Iustin Pop committed
62

63
$(genArbitrary ''PartialNDParams)
Iustin Pop's avatar
Iustin Pop committed
64

65
instance Arbitrary Node where
66
67
  arbitrary = Node <$> genFQDN <*> genFQDN <*> genFQDN
              <*> arbitrary <*> arbitrary <*> arbitrary <*> genFQDN
Iustin Pop's avatar
Iustin Pop committed
68
              <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
69
              <*> arbitrary <*> arbitrary <*> genFQDN <*> arbitrary
Iustin Pop's avatar
Iustin Pop committed
70
71
              <*> (Set.fromList <$> genTags)

72
$(genArbitrary ''BlockDriver)
73

74
$(genArbitrary ''DiskMode)
75
76
77

instance Arbitrary DiskLogicalId where
  arbitrary = oneof [ LIDPlain <$> arbitrary <*> arbitrary
78
                    , LIDDrbd8 <$> genFQDN <*> genFQDN <*> arbitrary
79
80
81
82
83
84
85
86
87
88
                               <*> arbitrary <*> arbitrary <*> arbitrary
                    , LIDFile  <$> arbitrary <*> arbitrary
                    , LIDBlockDev <$> arbitrary <*> arbitrary
                    , LIDRados <$> arbitrary <*> arbitrary
                    ]

-- | 'Disk' 'arbitrary' instance. Since we don't test disk hierarchy
-- properties, we only generate disks with no children (FIXME), as
-- generating recursive datastructures is a bit more work.
instance Arbitrary Disk where
Iustin Pop's avatar
Iustin Pop committed
89
  arbitrary = Disk <$> arbitrary <*> pure [] <*> arbitrary
90
91
                   <*> arbitrary <*> arbitrary

92
93
94
-- FIXME: we should generate proper values, >=0, etc., but this is
-- hard for partial ones, where all must be wrapped in a 'Maybe'
$(genArbitrary ''PartialBeParams)
Iustin Pop's avatar
Iustin Pop committed
95

96
$(genArbitrary ''AdminState)
Iustin Pop's avatar
Iustin Pop committed
97

98
$(genArbitrary ''PartialNicParams)
Iustin Pop's avatar
Iustin Pop committed
99

100
$(genArbitrary ''PartialNic)
Iustin Pop's avatar
Iustin Pop committed
101
102
103
104

instance Arbitrary Instance where
  arbitrary =
    Instance
105
      <$> genFQDN <*> genFQDN <*> genFQDN -- OS name, but...
Iustin Pop's avatar
Iustin Pop committed
106
107
      <*> arbitrary
      -- FIXME: add non-empty hvparams when they're a proper type
108
      <*> pure (GenericContainer Map.empty) <*> arbitrary
Iustin Pop's avatar
Iustin Pop committed
109
      -- ... and for OSParams
110
      <*> pure (GenericContainer Map.empty) <*> arbitrary <*> arbitrary
Iustin Pop's avatar
Iustin Pop committed
111
112
113
114
115
116
117
118
119
120
      <*> arbitrary <*> arbitrary <*> arbitrary
      -- ts
      <*> arbitrary <*> arbitrary
      -- uuid
      <*> arbitrary
      -- serial
      <*> arbitrary
      -- tags
      <*> (Set.fromList <$> genTags)

121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
-- | FIXME: This generates completely random data, without normal
-- validation rules.
$(genArbitrary ''PartialISpecParams)

-- | FIXME: This generates completely random data, without normal
-- validation rules.
$(genArbitrary ''PartialIPolicy)

$(genArbitrary ''FilledISpecParams)
$(genArbitrary ''FilledIPolicy)
$(genArbitrary ''IpFamily)
$(genArbitrary ''FilledNDParams)
$(genArbitrary ''FilledNicParams)
$(genArbitrary ''FilledBeParams)

-- | No real arbitrary instance for 'ClusterHvParams' yet.
instance Arbitrary ClusterHvParams where
138
  arbitrary = return $ GenericContainer Map.empty
139
140
141

-- | No real arbitrary instance for 'OsHvParams' yet.
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
157
158
159
160

instance Arbitrary TagSet where
  arbitrary = Set.fromList <$> genTags

$(genArbitrary ''Cluster)

161
instance Arbitrary Network where
162
163
164
165
166
167
168
169
170
171
172
173
  arbitrary = genValidNetwork

-- | Generates a network instance with minimum netmasks of /24. Generating
-- bigger networks slows down the tests, because long bit strings are generated
-- for the reservations.
genValidNetwork :: Gen Objects.Network
genValidNetwork = do
  -- generate netmask for the IPv4 network
  netmask <- choose (24::Int, 30)
  name <- genName >>= mkNonEmpty
  network_type <- genMaybe genNetworkType
  mac_prefix <- genMaybe genName
174
  net_family <- arbitrary
175
176
177
178
179
180
181
  net <- genIp4NetWithNetmask netmask
  net6 <- genMaybe genIp6Net
  gateway <- genMaybe genIp4AddrStr
  gateway6 <- genMaybe genIp6Addr
  size <- genMaybe genJSValue
  res <- liftM Just (genBitString $ netmask2NumHosts netmask)
  ext_res <- liftM Just (genBitString $ netmask2NumHosts netmask)
182
  let n = Network name network_type mac_prefix net_family net net6 gateway
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
          gateway6 size res ext_res 0 Set.empty
  return n

-- | Generates an arbitrary network type.
genNetworkType :: Gen NetworkType
genNetworkType = elements [ PrivateNetwork, PublicNetwork ]

-- | Generate an arbitrary string consisting of '0' and '1' of the given length.
genBitString :: Int -> Gen String
genBitString len = vectorOf len (elements "01")

-- | Generate an arbitrary string consisting of '0' and '1' of the maximum given
-- length.
genBitStringMaxLen :: Int -> Gen String
genBitStringMaxLen maxLen = choose (0, maxLen) >>= genBitString
198

199
200
201
202
203
204
205
-- | Generator for config data with an empty cluster (no instances),
-- with N defined nodes.
genEmptyCluster :: Int -> Gen ConfigData
genEmptyCluster ncount = do
  nodes <- vector ncount
  version <- arbitrary
  let guuid = "00"
206
207
208
209
      nodes' = zipWith (\n idx ->
                          let newname = nodeName n ++ "-" ++ show idx
                          in (newname, n { nodeGroup = guuid,
                                           nodeName = newname}))
210
               nodes [(1::Int)..]
211
212
213
214
215
216
      nodemap = Map.fromList nodes'
      contnodes = if Map.size nodemap /= ncount
                    then error ("Inconsistent node map, duplicates in" ++
                                " node name list? Names: " ++
                                show (map fst nodes'))
                    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
223
224
  let c = ConfigData version cluster contnodes contgroups continsts serial
  return c

225
226
-- * Test properties

Iustin Pop's avatar
Iustin Pop committed
227
-- | Tests that fillDict behaves correctly
228
229
prop_fillDict :: [(Int, Int)] -> [(Int, Int)] -> Property
prop_fillDict defaults custom =
Iustin Pop's avatar
Iustin Pop committed
230
231
232
233
  let d_map = Map.fromList defaults
      d_keys = map fst defaults
      c_map = Map.fromList custom
      c_keys = map fst custom
234
235
236
237
238
239
240
  in conjoin [ printTestCase "Empty custom filling"
               (fillDict d_map Map.empty [] == d_map)
             , printTestCase "Empty defaults filling"
               (fillDict Map.empty c_map [] == c_map)
             , printTestCase "Delete all keys"
               (fillDict d_map c_map (d_keys++c_keys) == Map.empty)
             ]
241
242
243
244
245
246
247
248

-- | Test that the serialisation of 'DiskLogicalId', which is
-- implemented manually, is idempotent. Since we don't have a
-- standalone JSON instance for DiskLogicalId (it's a data type that
-- expands over two fields in a JSObject), we test this by actially
-- testing entire Disk serialisations. So this tests two things at
-- once, basically.
prop_Disk_serialisation :: Disk -> Property
249
prop_Disk_serialisation = testSerialisation
250
251
252

-- | Check that node serialisation is idempotent.
prop_Node_serialisation :: Node -> Property
253
prop_Node_serialisation = testSerialisation
Iustin Pop's avatar
Iustin Pop committed
254

Iustin Pop's avatar
Iustin Pop committed
255
256
257
258
-- | Check that instance serialisation is idempotent.
prop_Inst_serialisation :: Instance -> Property
prop_Inst_serialisation = testSerialisation

259
260
261
262
-- | Check that network serialisation is idempotent.
prop_Network_serialisation :: Network -> Property
prop_Network_serialisation = testSerialisation

263
264
265
-- | Check config serialisation.
prop_Config_serialisation :: Property
prop_Config_serialisation =
266
  forAll (choose (0, maxNodes `div` 4) >>= genEmptyCluster) testSerialisation
267

268
269
270
-- | Custom HUnit test to check the correspondence between Haskell-generated
-- networks and their Python decoded, validated and re-encoded version.
-- For the technical background of this unit test, check the documentation
271
-- of "case_py_compat_types" of test/hs/Test/Ganeti/Opcodes.hs
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
case_py_compat_networks :: HUnit.Assertion
case_py_compat_networks = do
  let num_networks = 500::Int
  sample_networks <- sample' (vectorOf num_networks genValidNetwork)
  let networks = head sample_networks
      networks_with_properties = map getNetworkProperties networks
      serialized = J.encode networks
  -- check for non-ASCII fields, usually due to 'arbitrary :: String'
  mapM_ (\net -> when (any (not . isAscii) (J.encode net)) .
                 HUnit.assertFailure $
                 "Network has non-ASCII fields: " ++ show net
        ) networks
  py_stdout <-
    runPython "from ganeti import network\n\
              \from ganeti import objects\n\
              \from ganeti import serializer\n\
              \import sys\n\
              \net_data = serializer.Load(sys.stdin.read())\n\
              \decoded = [objects.Network.FromDict(n) for n in net_data]\n\
              \encoded = []\n\
              \for net in decoded:\n\
              \  a = network.AddressPool(net)\n\
              \  encoded.append((a.GetFreeCount(), a.GetReservedCount(), \\\n\
              \    net.ToDict()))\n\
              \print serializer.Dump(encoded)" serialized
    >>= checkPythonResult
  let deserialised = J.decode py_stdout::J.Result [(Int, Int, Network)]
  decoded <- case deserialised of
               J.Ok ops -> return ops
               J.Error msg ->
                 HUnit.assertFailure ("Unable to decode networks: " ++ msg)
                 -- this already raised an expection, but we need it
                 -- for proper types
                 >> fail "Unable to decode networks"
  HUnit.assertEqual "Mismatch in number of returned networks"
    (length decoded) (length networks_with_properties)
  mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
        ) $ zip decoded networks_with_properties

-- | Creates a tuple of the given network combined with some of its properties
-- to be compared against the same properties generated by the python code.
getNetworkProperties :: Network -> (Int, Int, Network)
getNetworkProperties net =
  let maybePool = createAddressPool net
  in  case maybePool of
           (Just pool) -> (getFreeCount pool, getReservedCount pool, net)
           Nothing -> (-1, -1, net)

320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
-- | Tests the compatibility between Haskell-serialized node groups and their
-- python-decoded and encoded version.
case_py_compat_nodegroups :: HUnit.Assertion
case_py_compat_nodegroups = do
  let num_groups = 500::Int
  sample_groups <- sample' (vectorOf num_groups genNodeGroup)
  let groups = head sample_groups
      serialized = J.encode groups
  -- check for non-ASCII fields, usually due to 'arbitrary :: String'
  mapM_ (\group -> when (any (not . isAscii) (J.encode group)) .
                 HUnit.assertFailure $
                 "Node group has non-ASCII fields: " ++ show group
        ) groups
  py_stdout <-
    runPython "from ganeti import objects\n\
              \from ganeti import serializer\n\
              \import sys\n\
              \group_data = serializer.Load(sys.stdin.read())\n\
              \decoded = [objects.NodeGroup.FromDict(g) for g in group_data]\n\
              \encoded = [g.ToDict() for g in decoded]\n\
              \print serializer.Dump(encoded)" serialized
    >>= checkPythonResult
  let deserialised = J.decode py_stdout::J.Result [NodeGroup]
  decoded <- case deserialised of
               J.Ok ops -> return ops
               J.Error msg ->
                 HUnit.assertFailure ("Unable to decode node groups: " ++ msg)
                 -- this already raised an expection, but we need it
                 -- for proper types
                 >> fail "Unable to decode node groups"
  HUnit.assertEqual "Mismatch in number of returned node groups"
    (length decoded) (length groups)
  mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding")
        ) $ zip decoded groups

-- | Generates a node group with up to 3 networks.
-- | FIXME: This generates still somewhat completely random data, without normal
-- validation rules.
genNodeGroup :: Gen NodeGroup
genNodeGroup = do
  name <- genFQDN
  members <- pure []
  ndparams <- arbitrary
  alloc_policy <- arbitrary
  ipolicy <- arbitrary
  diskparams <- pure (GenericContainer Map.empty)
  num_networks <- choose (0, 3)
367
  net_uuid_list <- vectorOf num_networks (arbitrary::Gen String)
368
  nic_param_list <- vectorOf num_networks (arbitrary::Gen PartialNicParams)
369
370
  net_map <- pure (GenericContainer . Map.fromList $
    zip net_uuid_list nic_param_list)
371
372
373
374
375
376
377
  -- timestamp fields
  ctime <- arbitrary
  mtime <- arbitrary
  uuid <- arbitrary
  serial <- arbitrary
  tags <- Set.fromList <$> genTags
  let group = NodeGroup name members ndparams alloc_policy ipolicy diskparams
378
              net_map ctime mtime uuid serial tags
379
380
381
382
383
  return group

instance Arbitrary NodeGroup where
  arbitrary = genNodeGroup

Iustin Pop's avatar
Iustin Pop committed
384
testSuite "Objects"
385
  [ 'prop_fillDict
386
  , 'prop_Disk_serialisation
Iustin Pop's avatar
Iustin Pop committed
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
  ]