root / htest / Test / Ganeti / Objects.hs @ 9924d61e
History | View | Annotate | Download (7.4 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 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 |
, testSlowObjects |
32 |
, Hypervisor(..) |
33 |
, Node(..) |
34 |
, genEmptyCluster |
35 |
) where |
36 |
|
37 |
import Test.QuickCheck |
38 |
|
39 |
import Control.Applicative |
40 |
import qualified Data.Map as Map |
41 |
import qualified Data.Set as Set |
42 |
|
43 |
import Test.Ganeti.TestHelper |
44 |
import Test.Ganeti.TestCommon |
45 |
|
46 |
import qualified Ganeti.Constants as C |
47 |
import Ganeti.Objects as Objects |
48 |
import Ganeti.JSON |
49 |
|
50 |
-- * Arbitrary instances |
51 |
|
52 |
$(genArbitrary ''Hypervisor) |
53 |
|
54 |
$(genArbitrary ''PartialNDParams) |
55 |
|
56 |
instance Arbitrary Node where |
57 |
arbitrary = Node <$> getFQDN <*> getFQDN <*> getFQDN |
58 |
<*> arbitrary <*> arbitrary <*> arbitrary <*> getFQDN |
59 |
<*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary |
60 |
<*> arbitrary <*> arbitrary <*> getFQDN <*> arbitrary |
61 |
<*> (Set.fromList <$> genTags) |
62 |
|
63 |
$(genArbitrary ''FileDriver) |
64 |
|
65 |
$(genArbitrary ''BlockDriver) |
66 |
|
67 |
$(genArbitrary ''DiskMode) |
68 |
|
69 |
instance Arbitrary DiskLogicalId where |
70 |
arbitrary = oneof [ LIDPlain <$> arbitrary <*> arbitrary |
71 |
, LIDDrbd8 <$> getFQDN <*> getFQDN <*> arbitrary |
72 |
<*> arbitrary <*> arbitrary <*> arbitrary |
73 |
, LIDFile <$> arbitrary <*> arbitrary |
74 |
, LIDBlockDev <$> arbitrary <*> arbitrary |
75 |
, LIDRados <$> arbitrary <*> arbitrary |
76 |
] |
77 |
|
78 |
-- | 'Disk' 'arbitrary' instance. Since we don't test disk hierarchy |
79 |
-- properties, we only generate disks with no children (FIXME), as |
80 |
-- generating recursive datastructures is a bit more work. |
81 |
instance Arbitrary Disk where |
82 |
arbitrary = Disk <$> arbitrary <*> (pure []) <*> arbitrary |
83 |
<*> arbitrary <*> arbitrary |
84 |
|
85 |
-- FIXME: we should generate proper values, >=0, etc., but this is |
86 |
-- hard for partial ones, where all must be wrapped in a 'Maybe' |
87 |
$(genArbitrary ''PartialBeParams) |
88 |
|
89 |
$(genArbitrary ''DiskTemplate) |
90 |
|
91 |
$(genArbitrary ''AdminState) |
92 |
|
93 |
$(genArbitrary ''NICMode) |
94 |
|
95 |
$(genArbitrary ''PartialNicParams) |
96 |
|
97 |
$(genArbitrary ''PartialNic) |
98 |
|
99 |
instance Arbitrary Instance where |
100 |
arbitrary = |
101 |
Instance |
102 |
<$> getFQDN <*> getFQDN <*> getFQDN -- OS name, but... |
103 |
<*> arbitrary |
104 |
-- FIXME: add non-empty hvparams when they're a proper type |
105 |
<*> (pure $ Container Map.empty) <*> arbitrary |
106 |
-- ... and for OSParams |
107 |
<*> (pure $ Container Map.empty) <*> arbitrary <*> arbitrary |
108 |
<*> arbitrary <*> arbitrary <*> arbitrary |
109 |
-- ts |
110 |
<*> arbitrary <*> arbitrary |
111 |
-- uuid |
112 |
<*> arbitrary |
113 |
-- serial |
114 |
<*> arbitrary |
115 |
-- tags |
116 |
<*> (Set.fromList <$> genTags) |
117 |
|
118 |
-- | FIXME: This generates completely random data, without normal |
119 |
-- validation rules. |
120 |
$(genArbitrary ''PartialISpecParams) |
121 |
|
122 |
-- | FIXME: This generates completely random data, without normal |
123 |
-- validation rules. |
124 |
$(genArbitrary ''PartialIPolicy) |
125 |
|
126 |
-- | FIXME: This generates completely random data, without normal |
127 |
-- validation rules. |
128 |
instance Arbitrary NodeGroup where |
129 |
arbitrary = NodeGroup <$> getFQDN <*> pure [] <*> arbitrary <*> arbitrary |
130 |
<*> arbitrary <*> (pure $ Container Map.empty) |
131 |
-- ts |
132 |
<*> arbitrary <*> arbitrary |
133 |
-- uuid |
134 |
<*> arbitrary |
135 |
-- serial |
136 |
<*> arbitrary |
137 |
-- tags |
138 |
<*> (Set.fromList <$> genTags) |
139 |
|
140 |
$(genArbitrary ''AllocPolicy) |
141 |
$(genArbitrary ''FilledISpecParams) |
142 |
$(genArbitrary ''FilledIPolicy) |
143 |
$(genArbitrary ''IpFamily) |
144 |
$(genArbitrary ''FilledNDParams) |
145 |
$(genArbitrary ''FilledNicParams) |
146 |
$(genArbitrary ''FilledBeParams) |
147 |
|
148 |
-- | No real arbitrary instance for 'ClusterHvParams' yet. |
149 |
instance Arbitrary ClusterHvParams where |
150 |
arbitrary = return $ Container Map.empty |
151 |
|
152 |
-- | No real arbitrary instance for 'OsHvParams' yet. |
153 |
instance Arbitrary OsHvParams where |
154 |
arbitrary = return $ Container Map.empty |
155 |
|
156 |
instance Arbitrary ClusterNicParams where |
157 |
arbitrary = (Container . Map.singleton C.ppDefault) <$> arbitrary |
158 |
|
159 |
instance Arbitrary OsParams where |
160 |
arbitrary = (Container . Map.fromList) <$> arbitrary |
161 |
|
162 |
instance Arbitrary ClusterOsParams where |
163 |
arbitrary = (Container . Map.fromList) <$> arbitrary |
164 |
|
165 |
instance Arbitrary ClusterBeParams where |
166 |
arbitrary = (Container . Map.fromList) <$> arbitrary |
167 |
|
168 |
instance Arbitrary TagSet where |
169 |
arbitrary = Set.fromList <$> genTags |
170 |
|
171 |
$(genArbitrary ''Cluster) |
172 |
|
173 |
-- | Generator for config data with an empty cluster (no instances), |
174 |
-- with N defined nodes. |
175 |
genEmptyCluster :: Int -> Gen ConfigData |
176 |
genEmptyCluster ncount = do |
177 |
nodes <- vector ncount |
178 |
version <- arbitrary |
179 |
let guuid = "00" |
180 |
nodes' = map (\n -> n { nodeGroup = guuid }) nodes |
181 |
contnodes = Container . Map.fromList $ map (\n -> (nodeName n, n)) nodes' |
182 |
continsts = Container $ Map.empty |
183 |
grp <- arbitrary |
184 |
let contgroups = Container $ Map.singleton guuid grp |
185 |
serial <- arbitrary |
186 |
cluster <- arbitrary |
187 |
let c = ConfigData version cluster contnodes contgroups continsts serial |
188 |
return c |
189 |
|
190 |
-- * Test properties |
191 |
|
192 |
-- | Tests that fillDict behaves correctly |
193 |
prop_fillDict :: [(Int, Int)] -> [(Int, Int)] -> Property |
194 |
prop_fillDict defaults custom = |
195 |
let d_map = Map.fromList defaults |
196 |
d_keys = map fst defaults |
197 |
c_map = Map.fromList custom |
198 |
c_keys = map fst custom |
199 |
in printTestCase "Empty custom filling" |
200 |
(fillDict d_map Map.empty [] == d_map) .&&. |
201 |
printTestCase "Empty defaults filling" |
202 |
(fillDict Map.empty c_map [] == c_map) .&&. |
203 |
printTestCase "Delete all keys" |
204 |
(fillDict d_map c_map (d_keys++c_keys) == Map.empty) |
205 |
|
206 |
-- | Test that the serialisation of 'DiskLogicalId', which is |
207 |
-- implemented manually, is idempotent. Since we don't have a |
208 |
-- standalone JSON instance for DiskLogicalId (it's a data type that |
209 |
-- expands over two fields in a JSObject), we test this by actially |
210 |
-- testing entire Disk serialisations. So this tests two things at |
211 |
-- once, basically. |
212 |
prop_Disk_serialisation :: Disk -> Property |
213 |
prop_Disk_serialisation = testSerialisation |
214 |
|
215 |
-- | Check that node serialisation is idempotent. |
216 |
prop_Node_serialisation :: Node -> Property |
217 |
prop_Node_serialisation = testSerialisation |
218 |
|
219 |
-- | Check that instance serialisation is idempotent. |
220 |
prop_Inst_serialisation :: Instance -> Property |
221 |
prop_Inst_serialisation = testSerialisation |
222 |
|
223 |
-- | Check config serialisation. |
224 |
prop_Config_serialisation :: Property |
225 |
prop_Config_serialisation = |
226 |
forAll (choose (0, maxNodes) >>= genEmptyCluster) testSerialisation |
227 |
|
228 |
testSuite "Objects" |
229 |
[ 'prop_fillDict |
230 |
, 'prop_Disk_serialisation |
231 |
, 'prop_Inst_serialisation |
232 |
, 'prop_Node_serialisation |
233 |
] |
234 |
|
235 |
testSuite "SlowObjects" |
236 |
[ 'prop_Config_serialisation |
237 |
] |