## root / htest / Test / Ganeti / Objects.hs @ 0b288282

History | View | Annotate | Download (12.2 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 |
, Node(..) |

32 |
, genEmptyCluster |

33 |
, genValidNetwork |

34 |
, genNetworkType |

35 |
, genBitStringMaxLen |

36 |
) where |

37 | |

38 |
import Test.QuickCheck |

39 |
import qualified Test.HUnit as HUnit |

40 | |

41 |
import Control.Applicative |

42 |
import Control.Monad |

43 |
import Data.Char |

44 |
import qualified Data.Map as Map |

45 |
import qualified Data.Set as Set |

46 |
import qualified Text.JSON as J |

47 | |

48 |
import Test.Ganeti.Query.Language (genJSValue) |

49 |
import Test.Ganeti.TestHelper |

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 |

56 |
import Ganeti.JSON |

57 |
import Ganeti.Types |

58 | |

59 |
{-# ANN module "HLint: ignore Use camelCase" #-} |

60 | |

61 |
-- * Arbitrary instances |

62 | |

63 |
$(genArbitrary ''PartialNDParams) |

64 | |

65 |
instance Arbitrary Node where |

66 |
arbitrary = Node <$> genFQDN <*> genFQDN <*> genFQDN |

67 |
<*> arbitrary <*> arbitrary <*> arbitrary <*> genFQDN |

68 |
<*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary |

69 |
<*> arbitrary <*> arbitrary <*> genFQDN <*> arbitrary |

70 |
<*> (Set.fromList <$> genTags) |

71 | |

72 |
$(genArbitrary ''BlockDriver) |

73 | |

74 |
$(genArbitrary ''DiskMode) |

75 | |

76 |
instance Arbitrary DiskLogicalId where |

77 |
arbitrary = oneof [ LIDPlain <$> arbitrary <*> arbitrary |

78 |
, LIDDrbd8 <$> genFQDN <*> genFQDN <*> arbitrary |

79 |
<*> arbitrary <*> arbitrary <*> arbitrary |

80 |
, LIDFile <$> arbitrary <*> arbitrary |

81 |
, LIDBlockDev <$> arbitrary <*> arbitrary |

82 |
, LIDRados <$> arbitrary <*> arbitrary |

83 |
] |

84 | |

85 |
-- | 'Disk' 'arbitrary' instance. Since we don't test disk hierarchy |

86 |
-- properties, we only generate disks with no children (FIXME), as |

87 |
-- generating recursive datastructures is a bit more work. |

88 |
instance Arbitrary Disk where |

89 |
arbitrary = Disk <$> arbitrary <*> pure [] <*> arbitrary |

90 |
<*> arbitrary <*> arbitrary |

91 | |

92 |
-- FIXME: we should generate proper values, >=0, etc., but this is |

93 |
-- hard for partial ones, where all must be wrapped in a 'Maybe' |

94 |
$(genArbitrary ''PartialBeParams) |

95 | |

96 |
$(genArbitrary ''AdminState) |

97 | |

98 |
$(genArbitrary ''PartialNicParams) |

99 | |

100 |
$(genArbitrary ''PartialNic) |

101 | |

102 |
instance Arbitrary Instance where |

103 |
arbitrary = |

104 |
Instance |

105 |
<$> genFQDN <*> genFQDN <*> genFQDN -- OS name, but... |

106 |
<*> arbitrary |

107 |
-- FIXME: add non-empty hvparams when they're a proper type |

108 |
<*> pure (GenericContainer Map.empty) <*> arbitrary |

109 |
-- ... and for OSParams |

110 |
<*> pure (GenericContainer Map.empty) <*> arbitrary <*> arbitrary |

111 |
<*> arbitrary <*> arbitrary <*> arbitrary |

112 |
-- ts |

113 |
<*> arbitrary <*> arbitrary |

114 |
-- uuid |

115 |
<*> arbitrary |

116 |
-- serial |

117 |
<*> arbitrary |

118 |
-- tags |

119 |
<*> (Set.fromList <$> genTags) |

120 | |

121 |
-- | FIXME: This generates completely random data, without normal |

122 |
-- validation rules. |

123 |
$(genArbitrary ''PartialISpecParams) |

124 | |

125 |
-- | FIXME: This generates completely random data, without normal |

126 |
-- validation rules. |

127 |
$(genArbitrary ''PartialIPolicy) |

128 | |

129 |
-- | FIXME: This generates completely random data, without normal |

130 |
-- validation rules. |

131 |
instance Arbitrary NodeGroup where |

132 |
arbitrary = NodeGroup <$> genFQDN <*> pure [] <*> arbitrary <*> arbitrary |

133 |
<*> arbitrary <*> pure (GenericContainer Map.empty) |

134 |
-- ts |

135 |
<*> arbitrary <*> arbitrary |

136 |
-- uuid |

137 |
<*> arbitrary |

138 |
-- serial |

139 |
<*> arbitrary |

140 |
-- tags |

141 |
<*> (Set.fromList <$> genTags) |

142 | |

143 |
$(genArbitrary ''FilledISpecParams) |

144 |
$(genArbitrary ''FilledIPolicy) |

145 |
$(genArbitrary ''IpFamily) |

146 |
$(genArbitrary ''FilledNDParams) |

147 |
$(genArbitrary ''FilledNicParams) |

148 |
$(genArbitrary ''FilledBeParams) |

149 | |

150 |
-- | No real arbitrary instance for 'ClusterHvParams' yet. |

151 |
instance Arbitrary ClusterHvParams where |

152 |
arbitrary = return $ GenericContainer Map.empty |

153 | |

154 |
-- | No real arbitrary instance for 'OsHvParams' yet. |

155 |
instance Arbitrary OsHvParams where |

156 |
arbitrary = return $ GenericContainer Map.empty |

157 | |

158 |
instance Arbitrary ClusterNicParams where |

159 |
arbitrary = (GenericContainer . Map.singleton C.ppDefault) <$> arbitrary |

160 | |

161 |
instance Arbitrary OsParams where |

162 |
arbitrary = (GenericContainer . Map.fromList) <$> arbitrary |

163 | |

164 |
instance Arbitrary ClusterOsParams where |

165 |
arbitrary = (GenericContainer . Map.fromList) <$> arbitrary |

166 | |

167 |
instance Arbitrary ClusterBeParams where |

168 |
arbitrary = (GenericContainer . Map.fromList) <$> arbitrary |

169 | |

170 |
instance Arbitrary TagSet where |

171 |
arbitrary = Set.fromList <$> genTags |

172 | |

173 |
$(genArbitrary ''Cluster) |

174 | |

175 |
instance Arbitrary Network where |

176 |
arbitrary = genValidNetwork |

177 | |

178 |
-- | Generates a network instance with minimum netmasks of /24. Generating |

179 |
-- bigger networks slows down the tests, because long bit strings are generated |

180 |
-- for the reservations. |

181 |
genValidNetwork :: Gen Objects.Network |

182 |
genValidNetwork = do |

183 |
-- generate netmask for the IPv4 network |

184 |
netmask <- choose (24::Int, 30) |

185 |
name <- genName >>= mkNonEmpty |

186 |
network_type <- genMaybe genNetworkType |

187 |
mac_prefix <- genMaybe genName |

188 |
fam <- arbitrary |

189 |
net <- genIp4NetWithNetmask netmask |

190 |
net6 <- genMaybe genIp6Net |

191 |
gateway <- genMaybe genIp4AddrStr |

192 |
gateway6 <- genMaybe genIp6Addr |

193 |
size <- genMaybe genJSValue |

194 |
res <- liftM Just (genBitString $ netmask2NumHosts netmask) |

195 |
ext_res <- liftM Just (genBitString $ netmask2NumHosts netmask) |

196 |
let n = Network name network_type mac_prefix fam net net6 gateway |

197 |
gateway6 size res ext_res 0 Set.empty |

198 |
return n |

199 | |

200 |
-- | Generates an arbitrary network type. |

201 |
genNetworkType :: Gen NetworkType |

202 |
genNetworkType = elements [ PrivateNetwork, PublicNetwork ] |

203 | |

204 |
-- | Generate an arbitrary string consisting of '0' and '1' of the given length. |

205 |
genBitString :: Int -> Gen String |

206 |
genBitString len = vectorOf len (elements "01") |

207 | |

208 |
-- | Generate an arbitrary string consisting of '0' and '1' of the maximum given |

209 |
-- length. |

210 |
genBitStringMaxLen :: Int -> Gen String |

211 |
genBitStringMaxLen maxLen = choose (0, maxLen) >>= genBitString |

212 | |

213 |
-- | Generator for config data with an empty cluster (no instances), |

214 |
-- with N defined nodes. |

215 |
genEmptyCluster :: Int -> Gen ConfigData |

216 |
genEmptyCluster ncount = do |

217 |
nodes <- vector ncount |

218 |
version <- arbitrary |

219 |
let guuid = "00" |

220 |
nodes' = zipWith (\n idx -> |

221 |
let newname = nodeName n ++ "-" ++ show idx |

222 |
in (newname, n { nodeGroup = guuid, |

223 |
nodeName = newname})) |

224 |
nodes [(1::Int)..] |

225 |
nodemap = Map.fromList nodes' |

226 |
contnodes = if Map.size nodemap /= ncount |

227 |
then error ("Inconsistent node map, duplicates in" ++ |

228 |
" node name list? Names: " ++ |

229 |
show (map fst nodes')) |

230 |
else GenericContainer nodemap |

231 |
continsts = GenericContainer Map.empty |

232 |
grp <- arbitrary |

233 |
let contgroups = GenericContainer $ Map.singleton guuid grp |

234 |
serial <- arbitrary |

235 |
cluster <- resize 8 arbitrary |

236 |
let c = ConfigData version cluster contnodes contgroups continsts serial |

237 |
return c |

238 | |

239 |
-- * Test properties |

240 | |

241 |
-- | Tests that fillDict behaves correctly |

242 |
prop_fillDict :: [(Int, Int)] -> [(Int, Int)] -> Property |

243 |
prop_fillDict defaults custom = |

244 |
let d_map = Map.fromList defaults |

245 |
d_keys = map fst defaults |

246 |
c_map = Map.fromList custom |

247 |
c_keys = map fst custom |

248 |
in conjoin [ printTestCase "Empty custom filling" |

249 |
(fillDict d_map Map.empty [] == d_map) |

250 |
, printTestCase "Empty defaults filling" |

251 |
(fillDict Map.empty c_map [] == c_map) |

252 |
, printTestCase "Delete all keys" |

253 |
(fillDict d_map c_map (d_keys++c_keys) == Map.empty) |

254 |
] |

255 | |

256 |
-- | Test that the serialisation of 'DiskLogicalId', which is |

257 |
-- implemented manually, is idempotent. Since we don't have a |

258 |
-- standalone JSON instance for DiskLogicalId (it's a data type that |

259 |
-- expands over two fields in a JSObject), we test this by actially |

260 |
-- testing entire Disk serialisations. So this tests two things at |

261 |
-- once, basically. |

262 |
prop_Disk_serialisation :: Disk -> Property |

263 |
prop_Disk_serialisation = testSerialisation |

264 | |

265 |
-- | Check that node serialisation is idempotent. |

266 |
prop_Node_serialisation :: Node -> Property |

267 |
prop_Node_serialisation = testSerialisation |

268 | |

269 |
-- | Check that instance serialisation is idempotent. |

270 |
prop_Inst_serialisation :: Instance -> Property |

271 |
prop_Inst_serialisation = testSerialisation |

272 | |

273 |
-- | Check that network serialisation is idempotent. |

274 |
prop_Network_serialisation :: Network -> Property |

275 |
prop_Network_serialisation = testSerialisation |

276 | |

277 |
-- | Check config serialisation. |

278 |
prop_Config_serialisation :: Property |

279 |
prop_Config_serialisation = |

280 |
forAll (choose (0, maxNodes `div` 4) >>= genEmptyCluster) testSerialisation |

281 | |

282 |
-- | Custom HUnit test to check the correspondence between Haskell-generated |

283 |
-- networks and their Python decoded, validated and re-encoded version. |

284 |
-- For the technical background of this unit test, check the documentation |

285 |
-- of "case_py_compat_types" of htest/Test/Ganeti/Opcodes.hs |

286 |
case_py_compat_networks :: HUnit.Assertion |

287 |
case_py_compat_networks = do |

288 |
let num_networks = 500::Int |

289 |
sample_networks <- sample' (vectorOf num_networks genValidNetwork) |

290 |
let networks = head sample_networks |

291 |
networks_with_properties = map getNetworkProperties networks |

292 |
serialized = J.encode networks |

293 |
-- check for non-ASCII fields, usually due to 'arbitrary :: String' |

294 |
mapM_ (\net -> when (any (not . isAscii) (J.encode net)) . |

295 |
HUnit.assertFailure $ |

296 |
"Network has non-ASCII fields: " ++ show net |

297 |
) networks |

298 |
py_stdout <- |

299 |
runPython "from ganeti import network\n\ |

300 |
\from ganeti import objects\n\ |

301 |
\from ganeti import serializer\n\ |

302 |
\import sys\n\ |

303 |
\net_data = serializer.Load(sys.stdin.read())\n\ |

304 |
\decoded = [objects.Network.FromDict(n) for n in net_data]\n\ |

305 |
\encoded = []\n\ |

306 |
\for net in decoded:\n\ |

307 |
\ a = network.AddressPool(net)\n\ |

308 |
\ encoded.append((a.GetFreeCount(), a.GetReservedCount(), \\\n\ |

309 |
\ net.ToDict()))\n\ |

310 |
\print serializer.Dump(encoded)" serialized |

311 |
>>= checkPythonResult |

312 |
let deserialised = J.decode py_stdout::J.Result [(Int, Int, Network)] |

313 |
decoded <- case deserialised of |

314 |
J.Ok ops -> return ops |

315 |
J.Error msg -> |

316 |
HUnit.assertFailure ("Unable to decode networks: " ++ msg) |

317 |
-- this already raised an expection, but we need it |

318 |
-- for proper types |

319 |
>> fail "Unable to decode networks" |

320 |
HUnit.assertEqual "Mismatch in number of returned networks" |

321 |
(length decoded) (length networks_with_properties) |

322 |
mapM_ (uncurry (HUnit.assertEqual "Different result after encoding/decoding") |

323 |
) $ zip decoded networks_with_properties |

324 | |

325 |
-- | Creates a tuple of the given network combined with some of its properties |

326 |
-- to be compared against the same properties generated by the python code. |

327 |
getNetworkProperties :: Network -> (Int, Int, Network) |

328 |
getNetworkProperties net = |

329 |
let maybePool = createAddressPool net |

330 |
in case maybePool of |

331 |
(Just pool) -> (getFreeCount pool, getReservedCount pool, net) |

332 |
Nothing -> (-1, -1, net) |

333 | |

334 |
testSuite "Objects" |

335 |
[ 'prop_fillDict |

336 |
, 'prop_Disk_serialisation |

337 |
, 'prop_Inst_serialisation |

338 |
, 'prop_Network_serialisation |

339 |
, 'prop_Node_serialisation |

340 |
, 'prop_Config_serialisation |

341 |
, 'case_py_compat_networks |

342 |
] |