| 1 |
|
{-# LANGUAGE TemplateHaskell #-}
|
|
1 |
{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-}
|
| 2 |
2 |
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
| 3 |
3 |
|
| 4 |
4 |
{-| Unittests for ganeti-htools.
|
| ... | ... | |
| 28 |
28 |
|
| 29 |
29 |
module Test.Ganeti.Objects
|
| 30 |
30 |
( testObjects
|
|
31 |
, testSlowObjects
|
| 31 |
32 |
, Hypervisor(..)
|
| 32 |
33 |
, Node(..)
|
|
34 |
, genEmptyCluster
|
| 33 |
35 |
) where
|
| 34 |
36 |
|
| 35 |
37 |
import Test.QuickCheck
|
| ... | ... | |
| 40 |
42 |
|
| 41 |
43 |
import Test.Ganeti.TestHelper
|
| 42 |
44 |
import Test.Ganeti.TestCommon
|
|
45 |
|
|
46 |
import qualified Ganeti.Constants as C
|
| 43 |
47 |
import Ganeti.Objects as Objects
|
| 44 |
48 |
import Ganeti.JSON
|
| 45 |
49 |
|
| ... | ... | |
| 111 |
115 |
-- tags
|
| 112 |
116 |
<*> (Set.fromList <$> genTags)
|
| 113 |
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 |
|
| 114 |
190 |
-- * Test properties
|
| 115 |
191 |
|
| 116 |
192 |
-- | Tests that fillDict behaves correctly
|
| ... | ... | |
| 144 |
220 |
prop_Inst_serialisation :: Instance -> Property
|
| 145 |
221 |
prop_Inst_serialisation = testSerialisation
|
| 146 |
222 |
|
|
223 |
-- | Check config serialisation.
|
|
224 |
prop_Config_serialisation :: Property
|
|
225 |
prop_Config_serialisation =
|
|
226 |
forAll (choose (0, maxNodes) >>= genEmptyCluster) testSerialisation
|
|
227 |
|
| 147 |
228 |
testSuite "Objects"
|
| 148 |
229 |
[ 'prop_fillDict
|
| 149 |
230 |
, 'prop_Disk_serialisation
|
| 150 |
231 |
, 'prop_Inst_serialisation
|
| 151 |
232 |
, 'prop_Node_serialisation
|
| 152 |
233 |
]
|
|
234 |
|
|
235 |
testSuite "SlowObjects"
|
|
236 |
[ 'prop_Config_serialisation
|
|
237 |
]
|