Objects.hs 7.5 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
  , testSlowObjects
32
33
  , Hypervisor(..)
  , Node(..)
34
  , genEmptyCluster
Iustin Pop's avatar
Iustin Pop committed
35
  ) where
Iustin Pop's avatar
Iustin Pop committed
36

37
38
import Test.QuickCheck

Iustin Pop's avatar
Iustin Pop committed
39
import Control.Applicative
Iustin Pop's avatar
Iustin Pop committed
40
import qualified Data.Map as Map
Iustin Pop's avatar
Iustin Pop committed
41
import qualified Data.Set as Set
Iustin Pop's avatar
Iustin Pop committed
42
43

import Test.Ganeti.TestHelper
Iustin Pop's avatar
Iustin Pop committed
44
import Test.Ganeti.TestCommon
45
46

import qualified Ganeti.Constants as C
47
import Ganeti.Objects as Objects
Iustin Pop's avatar
Iustin Pop committed
48
import Ganeti.JSON
49
50

-- * Arbitrary instances
Iustin Pop's avatar
Iustin Pop committed
51

52
$(genArbitrary ''Hypervisor)
Iustin Pop's avatar
Iustin Pop committed
53

54
$(genArbitrary ''PartialNDParams)
Iustin Pop's avatar
Iustin Pop committed
55

56
57
instance Arbitrary Node where
  arbitrary = Node <$> getFQDN <*> getFQDN <*> getFQDN
Iustin Pop's avatar
Iustin Pop committed
58
59
60
61
62
              <*> arbitrary <*> arbitrary <*> arbitrary <*> getFQDN
              <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
              <*> arbitrary <*> arbitrary <*> getFQDN <*> arbitrary
              <*> (Set.fromList <$> genTags)

63
$(genArbitrary ''FileDriver)
64

65
$(genArbitrary ''BlockDriver)
66

67
$(genArbitrary ''DiskMode)
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84

instance Arbitrary DiskLogicalId where
  arbitrary = oneof [ LIDPlain <$> arbitrary <*> arbitrary
                    , LIDDrbd8 <$> getFQDN <*> getFQDN <*> arbitrary
                               <*> 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
  arbitrary = Disk <$> arbitrary <*> (pure []) <*> arbitrary
                   <*> arbitrary <*> arbitrary

85
86
87
-- 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
88

89
$(genArbitrary ''DiskTemplate)
Iustin Pop's avatar
Iustin Pop committed
90

91
$(genArbitrary ''AdminState)
Iustin Pop's avatar
Iustin Pop committed
92

93
$(genArbitrary ''NICMode)
Iustin Pop's avatar
Iustin Pop committed
94

95
$(genArbitrary ''PartialNicParams)
Iustin Pop's avatar
Iustin Pop committed
96

97
$(genArbitrary ''PartialNic)
Iustin Pop's avatar
Iustin Pop committed
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117

instance Arbitrary Instance where
  arbitrary =
    Instance
      <$> getFQDN <*> getFQDN <*> getFQDN -- OS name, but...
      <*> arbitrary
      -- FIXME: add non-empty hvparams when they're a proper type
      <*> (pure $ Container Map.empty) <*> arbitrary
      -- ... and for OSParams
      <*> (pure $ Container Map.empty) <*> arbitrary <*> arbitrary
      <*> arbitrary <*> arbitrary <*> arbitrary
      -- ts
      <*> arbitrary <*> arbitrary
      -- uuid
      <*> arbitrary
      -- serial
      <*> arbitrary
      -- tags
      <*> (Set.fromList <$> genTags)

118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
-- | FIXME: This generates completely random data, without normal
-- validation rules.
$(genArbitrary ''PartialISpecParams)

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

-- | FIXME: This generates completely random data, without normal
-- validation rules.
instance Arbitrary NodeGroup where
  arbitrary = NodeGroup <$> getFQDN <*> pure [] <*> arbitrary <*> arbitrary
                        <*> arbitrary <*> (pure $ Container Map.empty)
                        -- ts
                        <*> arbitrary <*> arbitrary
                        -- uuid
                        <*> arbitrary
                        -- serial
                        <*> arbitrary
                        -- tags
                        <*> (Set.fromList <$> genTags)

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

-- | No real arbitrary instance for 'ClusterHvParams' yet.
instance Arbitrary ClusterHvParams where
  arbitrary = return $ Container Map.empty

-- | No real arbitrary instance for 'OsHvParams' yet.
instance Arbitrary OsHvParams where
  arbitrary = return $ Container Map.empty

instance Arbitrary ClusterNicParams where
  arbitrary = (Container . Map.singleton C.ppDefault) <$> arbitrary

instance Arbitrary OsParams where
  arbitrary = (Container . Map.fromList) <$> arbitrary

instance Arbitrary ClusterOsParams where
  arbitrary = (Container . Map.fromList) <$> arbitrary

instance Arbitrary ClusterBeParams where
  arbitrary = (Container . Map.fromList) <$> arbitrary

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

$(genArbitrary ''Cluster)

-- | 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"
180
181
182
      nodes' = zipWith (\n idx -> n { nodeGroup = guuid,
                                      nodeName = nodeName n ++ show idx })
               nodes [(1::Int)..]
183
184
185
186
187
188
189
190
191
      contnodes = Container . Map.fromList $ map (\n -> (nodeName n, n)) nodes'
      continsts = Container $ Map.empty
  grp <- arbitrary
  let contgroups = Container $ Map.singleton guuid grp
  serial <- arbitrary
  cluster <- arbitrary
  let c = ConfigData version cluster contnodes contgroups continsts serial
  return c

192
193
-- * Test properties

Iustin Pop's avatar
Iustin Pop committed
194
-- | Tests that fillDict behaves correctly
195
196
prop_fillDict :: [(Int, Int)] -> [(Int, Int)] -> Property
prop_fillDict defaults custom =
Iustin Pop's avatar
Iustin Pop committed
197
198
199
200
201
  let d_map = Map.fromList defaults
      d_keys = map fst defaults
      c_map = Map.fromList custom
      c_keys = map fst custom
  in printTestCase "Empty custom filling"
202
      (fillDict d_map Map.empty [] == d_map) .&&.
Iustin Pop's avatar
Iustin Pop committed
203
     printTestCase "Empty defaults filling"
204
      (fillDict Map.empty c_map [] == c_map) .&&.
Iustin Pop's avatar
Iustin Pop committed
205
     printTestCase "Delete all keys"
206
207
208
209
210
211
212
213
214
      (fillDict d_map c_map (d_keys++c_keys) == Map.empty)

-- | 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
215
prop_Disk_serialisation = testSerialisation
216
217
218

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

Iustin Pop's avatar
Iustin Pop committed
221
222
223
224
-- | Check that instance serialisation is idempotent.
prop_Inst_serialisation :: Instance -> Property
prop_Inst_serialisation = testSerialisation

225
226
227
228
229
-- | Check config serialisation.
prop_Config_serialisation :: Property
prop_Config_serialisation =
  forAll (choose (0, maxNodes) >>= genEmptyCluster) testSerialisation

Iustin Pop's avatar
Iustin Pop committed
230
testSuite "Objects"
231
  [ 'prop_fillDict
232
  , 'prop_Disk_serialisation
Iustin Pop's avatar
Iustin Pop committed
233
  , 'prop_Inst_serialisation
234
  , 'prop_Node_serialisation
Iustin Pop's avatar
Iustin Pop committed
235
  ]
236
237
238
239

testSuite "SlowObjects"
  [ 'prop_Config_serialisation
  ]