## root / test / hs / Test / Ganeti / Objects.hs @ d9b681ea

History | View | Annotate | Download (17.2 kB)

1 |
{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances, |
---|---|

2 |
OverloadedStrings #-} |

3 |
{-# OPTIONS_GHC -fno-warn-orphans #-} |

4 | |

5 |
{-| Unittests for ganeti-htools. |

6 | |

7 |
-} |

8 | |

9 |
{- |

10 | |

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

12 | |

13 |
This program is free software; you can redistribute it and/or modify |

14 |
it under the terms of the GNU General Public License as published by |

15 |
the Free Software Foundation; either version 2 of the License, or |

16 |
(at your option) any later version. |

17 | |

18 |
This program is distributed in the hope that it will be useful, but |

19 |
WITHOUT ANY WARRANTY; without even the implied warranty of |

20 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |

21 |
General Public License for more details. |

22 | |

23 |
You should have received a copy of the GNU General Public License |

24 |
along with this program; if not, write to the Free Software |

25 |
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |

26 |
02110-1301, USA. |

27 | |

28 |
-} |

29 | |

30 |
module Test.Ganeti.Objects |

31 |
( testObjects |

32 |
, Node(..) |

33 |
, genConfigDataWithNetworks |

34 |
, genDisk |

35 |
, genDiskWithChildren |

36 |
, genEmptyCluster |

37 |
, genInstWithNets |

38 |
, genValidNetwork |

39 |
, genBitStringMaxLen |

40 |
) where |

41 | |

42 |
import Test.QuickCheck |

43 |
import qualified Test.HUnit as HUnit |

44 | |

45 |
import Control.Applicative |

46 |
import Control.Monad |

47 |
import Data.Char |

48 |
import qualified Data.List as List |

49 |
import qualified Data.Map as Map |

50 |
import Data.Maybe (fromMaybe) |

51 |
import qualified Data.Set as Set |

52 |
import GHC.Exts (IsString(..)) |

53 |
import qualified Text.JSON as J |

54 | |

55 |
import Test.Ganeti.TestHelper |

56 |
import Test.Ganeti.TestCommon |

57 |
import Test.Ganeti.Types () |

58 | |

59 |
import qualified Ganeti.Constants as C |

60 |
import Ganeti.Network |

61 |
import Ganeti.Objects as Objects |

62 |
import Ganeti.JSON |

63 |
import Ganeti.Types |

64 | |

65 |
-- * Arbitrary instances |

66 | |

67 |
$(genArbitrary ''PartialNDParams) |

68 | |

69 |
instance Arbitrary Node where |

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

71 |
<*> arbitrary <*> arbitrary <*> arbitrary <*> genFQDN |

72 |
<*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary |

73 |
<*> arbitrary <*> arbitrary <*> genFQDN <*> arbitrary |

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

75 | |

76 |
$(genArbitrary ''BlockDriver) |

77 | |

78 |
$(genArbitrary ''DiskMode) |

79 | |

80 |
instance Arbitrary DiskLogicalId where |

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

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

83 |
<*> arbitrary <*> arbitrary <*> arbitrary |

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

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

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

87 |
] |

88 | |

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

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

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

92 |
instance Arbitrary Disk where |

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

94 |
<*> arbitrary <*> arbitrary <*> arbitrary |

95 |
<*> arbitrary |

96 | |

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

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

99 |
$(genArbitrary ''PartialBeParams) |

100 | |

101 |
$(genArbitrary ''AdminState) |

102 | |

103 |
$(genArbitrary ''PartialNicParams) |

104 | |

105 |
$(genArbitrary ''PartialNic) |

106 | |

107 |
instance Arbitrary Instance where |

108 |
arbitrary = |

109 |
Instance |

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

111 |
<*> arbitrary |

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

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

114 |
-- ... and for OSParams |

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

116 |
<*> arbitrary <*> arbitrary <*> arbitrary |

117 |
-- ts |

118 |
<*> arbitrary <*> arbitrary |

119 |
-- uuid |

120 |
<*> arbitrary |

121 |
-- serial |

122 |
<*> arbitrary |

123 |
-- tags |

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

125 | |

126 |
-- | Generates an instance that is connected to the given networks |

127 |
-- and possibly some other networks |

128 |
genInstWithNets :: [String] -> Gen Instance |

129 |
genInstWithNets nets = do |

130 |
plain_inst <- arbitrary |

131 |
mac <- arbitrary |

132 |
ip <- arbitrary |

133 |
nicparams <- arbitrary |

134 |
name <- arbitrary |

135 |
uuid <- arbitrary |

136 |
-- generate some more networks than the given ones |

137 |
num_more_nets <- choose (0,3) |

138 |
more_nets <- vectorOf num_more_nets genName |

139 |
let genNic net = PartialNic mac ip nicparams net name uuid |

140 |
partial_nics = map (genNic . Just) |

141 |
(List.nub (nets ++ more_nets)) |

142 |
new_inst = plain_inst { instNics = partial_nics } |

143 |
return new_inst |

144 | |

145 |
genDiskWithChildren :: Int -> Gen Disk |

146 |
genDiskWithChildren num_children = do |

147 |
logicalid <- arbitrary |

148 |
children <- vectorOf num_children (genDiskWithChildren 0) |

149 |
ivname <- genName |

150 |
size <- arbitrary |

151 |
mode <- arbitrary |

152 |
name <- genMaybe genName |

153 |
uuid <- genName |

154 |
let disk = Disk logicalid children ivname size mode name uuid |

155 |
return disk |

156 | |

157 |
genDisk :: Gen Disk |

158 |
genDisk = genDiskWithChildren 3 |

159 | |

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

161 |
-- validation rules. |

162 |
$(genArbitrary ''PartialISpecParams) |

163 | |

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

165 |
-- validation rules. |

166 |
$(genArbitrary ''PartialIPolicy) |

167 | |

168 |
$(genArbitrary ''FilledISpecParams) |

169 |
$(genArbitrary ''MinMaxISpecs) |

170 |
$(genArbitrary ''FilledIPolicy) |

171 |
$(genArbitrary ''IpFamily) |

172 |
$(genArbitrary ''FilledNDParams) |

173 |
$(genArbitrary ''FilledNicParams) |

174 |
$(genArbitrary ''FilledBeParams) |

175 | |

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

177 |
instance Arbitrary ClusterHvParams where |

178 |
arbitrary = return $ GenericContainer Map.empty |

179 | |

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

181 |
instance Arbitrary OsHvParams where |

182 |
arbitrary = return $ GenericContainer Map.empty |

183 | |

184 |
instance Arbitrary ClusterNicParams where |

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

186 | |

187 |
instance Arbitrary OsParams where |

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

189 | |

190 |
instance Arbitrary ClusterOsParams where |

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

192 | |

193 |
instance Arbitrary ClusterBeParams where |

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

195 | |

196 |
instance Arbitrary TagSet where |

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

198 | |

199 |
$(genArbitrary ''Cluster) |

200 | |

201 |
instance Arbitrary Network where |

202 |
arbitrary = genValidNetwork |

203 | |

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

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

206 |
-- for the reservations. |

207 |
genValidNetwork :: Gen Objects.Network |

208 |
genValidNetwork = do |

209 |
-- generate netmask for the IPv4 network |

210 |
netmask <- fromIntegral <$> choose (24::Int, 30) |

211 |
name <- genName >>= mkNonEmpty |

212 |
mac_prefix <- genMaybe genName |

213 |
net <- arbitrary |

214 |
net6 <- genMaybe genIp6Net |

215 |
gateway <- genMaybe arbitrary |

216 |
gateway6 <- genMaybe genIp6Addr |

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

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

219 |
uuid <- arbitrary |

220 |
let n = Network name mac_prefix (Ip4Network net netmask) net6 gateway |

221 |
gateway6 res ext_res uuid 0 Set.empty |

222 |
return n |

223 | |

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

225 |
genBitString :: Int -> Gen String |

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

227 | |

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

229 |
-- length. |

230 |
genBitStringMaxLen :: Int -> Gen String |

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

232 | |

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

234 |
-- with N defined nodes. |

235 |
genEmptyCluster :: Int -> Gen ConfigData |

236 |
genEmptyCluster ncount = do |

237 |
nodes <- vector ncount |

238 |
version <- arbitrary |

239 |
grp <- arbitrary |

240 |
let guuid = groupUuid grp |

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

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

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

244 |
nodeName = newname})) |

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

246 |
nodemap = Map.fromList nodes' |

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

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

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

250 |
show (map fst nodes')) |

251 |
else GenericContainer nodemap |

252 |
continsts = GenericContainer Map.empty |

253 |
networks = GenericContainer Map.empty |

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

255 |
serial <- arbitrary |

256 |
cluster <- resize 8 arbitrary |

257 |
let c = ConfigData version cluster contnodes contgroups continsts networks |

258 |
serial |

259 |
return c |

260 | |

261 |
-- | FIXME: make an even simpler base version of creating a cluster. |

262 | |

263 |
-- | Generates config data with a couple of networks. |

264 |
genConfigDataWithNetworks :: ConfigData -> Gen ConfigData |

265 |
genConfigDataWithNetworks old_cfg = do |

266 |
num_nets <- choose (0, 3) |

267 |
-- generate a list of network names (no duplicates) |

268 |
net_names <- genUniquesList num_nets genName >>= mapM mkNonEmpty |

269 |
-- generate a random list of networks (possibly with duplicate names) |

270 |
nets <- vectorOf num_nets genValidNetwork |

271 |
-- use unique names for the networks |

272 |
let nets_unique = map ( \(name, net) -> net { networkName = name } ) |

273 |
(zip net_names nets) |

274 |
net_map = GenericContainer $ Map.fromList |

275 |
(map (\n -> (networkUuid n, n)) nets_unique) |

276 |
new_cfg = old_cfg { configNetworks = net_map } |

277 |
return new_cfg |

278 | |

279 |
-- * Test properties |

280 | |

281 |
-- | Tests that fillDict behaves correctly |

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

283 |
prop_fillDict defaults custom = |

284 |
let d_map = Map.fromList defaults |

285 |
d_keys = map fst defaults |

286 |
c_map = Map.fromList custom |

287 |
c_keys = map fst custom |

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

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

290 |
, printTestCase "Empty defaults filling" |

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

292 |
, printTestCase "Delete all keys" |

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

294 |
] |

295 | |

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

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

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

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

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

301 |
-- once, basically. |

302 |
prop_Disk_serialisation :: Disk -> Property |

303 |
prop_Disk_serialisation = testSerialisation |

304 | |

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

306 |
prop_Node_serialisation :: Node -> Property |

307 |
prop_Node_serialisation = testSerialisation |

308 | |

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

310 |
prop_Inst_serialisation :: Instance -> Property |

311 |
prop_Inst_serialisation = testSerialisation |

312 | |

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

314 |
prop_Network_serialisation :: Network -> Property |

315 |
prop_Network_serialisation = testSerialisation |

316 | |

317 |
-- | Check config serialisation. |

318 |
prop_Config_serialisation :: Property |

319 |
prop_Config_serialisation = |

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

321 | |

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

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

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

325 |
-- of "case_py_compat_types" of test/hs/Test/Ganeti/Opcodes.hs |

326 |
casePyCompatNetworks :: HUnit.Assertion |

327 |
casePyCompatNetworks = do |

328 |
let num_networks = 500::Int |

329 |
networks <- genSample (vectorOf num_networks genValidNetwork) |

330 |
let networks_with_properties = map getNetworkProperties networks |

331 |
serialized = J.encode networks |

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

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

334 |
HUnit.assertFailure $ |

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

336 |
) networks |

337 |
py_stdout <- |

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

339 |
\from ganeti import objects\n\ |

340 |
\from ganeti import serializer\n\ |

341 |
\import sys\n\ |

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

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

344 |
\encoded = []\n\ |

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

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

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

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

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

350 |
>>= checkPythonResult |

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

352 |
decoded <- case deserialised of |

353 |
J.Ok ops -> return ops |

354 |
J.Error msg -> |

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

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

357 |
-- for proper types |

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

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

360 |
(length decoded) (length networks_with_properties) |

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

362 |
) $ zip decoded networks_with_properties |

363 | |

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

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

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

367 |
getNetworkProperties net = |

368 |
let maybePool = createAddressPool net |

369 |
in case maybePool of |

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

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

372 | |

373 |
-- | Tests the compatibility between Haskell-serialized node groups and their |

374 |
-- python-decoded and encoded version. |

375 |
casePyCompatNodegroups :: HUnit.Assertion |

376 |
casePyCompatNodegroups = do |

377 |
let num_groups = 500::Int |

378 |
groups <- genSample (vectorOf num_groups genNodeGroup) |

379 |
let serialized = J.encode groups |

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

381 |
mapM_ (\group -> when (any (not . isAscii) (J.encode group)) . |

382 |
HUnit.assertFailure $ |

383 |
"Node group has non-ASCII fields: " ++ show group |

384 |
) groups |

385 |
py_stdout <- |

386 |
runPython "from ganeti import objects\n\ |

387 |
\from ganeti import serializer\n\ |

388 |
\import sys\n\ |

389 |
\group_data = serializer.Load(sys.stdin.read())\n\ |

390 |
\decoded = [objects.NodeGroup.FromDict(g) for g in group_data]\n\ |

391 |
\encoded = [g.ToDict() for g in decoded]\n\ |

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

393 |
>>= checkPythonResult |

394 |
let deserialised = J.decode py_stdout::J.Result [NodeGroup] |

395 |
decoded <- case deserialised of |

396 |
J.Ok ops -> return ops |

397 |
J.Error msg -> |

398 |
HUnit.assertFailure ("Unable to decode node groups: " ++ msg) |

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

400 |
-- for proper types |

401 |
>> fail "Unable to decode node groups" |

402 |
HUnit.assertEqual "Mismatch in number of returned node groups" |

403 |
(length decoded) (length groups) |

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

405 |
) $ zip decoded groups |

406 | |

407 |
-- | Generates a node group with up to 3 networks. |

408 |
-- | FIXME: This generates still somewhat completely random data, without normal |

409 |
-- validation rules. |

410 |
genNodeGroup :: Gen NodeGroup |

411 |
genNodeGroup = do |

412 |
name <- genFQDN |

413 |
members <- pure [] |

414 |
ndparams <- arbitrary |

415 |
alloc_policy <- arbitrary |

416 |
ipolicy <- arbitrary |

417 |
diskparams <- pure (GenericContainer Map.empty) |

418 |
num_networks <- choose (0, 3) |

419 |
net_uuid_list <- vectorOf num_networks (arbitrary::Gen String) |

420 |
nic_param_list <- vectorOf num_networks (arbitrary::Gen PartialNicParams) |

421 |
net_map <- pure (GenericContainer . Map.fromList $ |

422 |
zip net_uuid_list nic_param_list) |

423 |
-- timestamp fields |

424 |
ctime <- arbitrary |

425 |
mtime <- arbitrary |

426 |
uuid <- genFQDN `suchThat` (/= name) |

427 |
serial <- arbitrary |

428 |
tags <- Set.fromList <$> genTags |

429 |
let group = NodeGroup name members ndparams alloc_policy ipolicy diskparams |

430 |
net_map ctime mtime uuid serial tags |

431 |
return group |

432 | |

433 |
instance Arbitrary NodeGroup where |

434 |
arbitrary = genNodeGroup |

435 | |

436 |
$(genArbitrary ''Ip4Address) |

437 | |

438 |
$(genArbitrary ''Ip4Network) |

439 | |

440 |
-- | Helper to compute absolute value of an IPv4 address. |

441 |
ip4AddrValue :: Ip4Address -> Integer |

442 |
ip4AddrValue (Ip4Address a b c d) = |

443 |
fromIntegral a * (2^(24::Integer)) + |

444 |
fromIntegral b * (2^(16::Integer)) + |

445 |
fromIntegral c * (2^(8::Integer)) + fromIntegral d |

446 | |

447 |
-- | Tests that any difference between IPv4 consecutive addresses is 1. |

448 |
prop_nextIp4Address :: Ip4Address -> Property |

449 |
prop_nextIp4Address ip4 = |

450 |
ip4AddrValue (nextIp4Address ip4) ==? ip4AddrValue ip4 + 1 |

451 | |

452 |
-- | IsString instance for 'Ip4Address', to help write the tests. |

453 |
instance IsString Ip4Address where |

454 |
fromString s = |

455 |
fromMaybe (error $ "Failed to parse address from " ++ s) (readIp4Address s) |

456 | |

457 |
-- | Tests a few simple cases of IPv4 next address. |

458 |
caseNextIp4Address :: HUnit.Assertion |

459 |
caseNextIp4Address = do |

460 |
HUnit.assertEqual "" "0.0.0.1" $ nextIp4Address "0.0.0.0" |

461 |
HUnit.assertEqual "" "0.0.0.0" $ nextIp4Address "255.255.255.255" |

462 |
HUnit.assertEqual "" "1.2.3.5" $ nextIp4Address "1.2.3.4" |

463 |
HUnit.assertEqual "" "1.3.0.0" $ nextIp4Address "1.2.255.255" |

464 |
HUnit.assertEqual "" "1.2.255.63" $ nextIp4Address "1.2.255.62" |

465 | |

466 |
testSuite "Objects" |

467 |
[ 'prop_fillDict |

468 |
, 'prop_Disk_serialisation |

469 |
, 'prop_Inst_serialisation |

470 |
, 'prop_Network_serialisation |

471 |
, 'prop_Node_serialisation |

472 |
, 'prop_Config_serialisation |

473 |
, 'casePyCompatNetworks |

474 |
, 'casePyCompatNodegroups |

475 |
, 'prop_nextIp4Address |

476 |
, 'caseNextIp4Address |

477 |
] |