## root / htest / Test / Ganeti / Objects.hs @ 942a9a6a

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

32 |
, Node(..) |

33 |
, genEmptyCluster |

34 |
) where |

35 | |

36 |
import Test.QuickCheck |

37 | |

38 |
import Control.Applicative |

39 |
import qualified Data.Map as Map |

40 |
import qualified Data.Set as Set |

41 | |

42 |
import Test.Ganeti.TestHelper |

43 |
import Test.Ganeti.TestCommon |

44 | |

45 |
import qualified Ganeti.Constants as C |

46 |
import Ganeti.Objects as Objects |

47 |
import Ganeti.JSON |

48 | |

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

50 | |

51 |
-- * Arbitrary instances |

52 | |

53 |
$(genArbitrary ''Hypervisor) |

54 | |

55 |
$(genArbitrary ''PartialNDParams) |

56 | |

57 |
instance Arbitrary Node where |

58 |
arbitrary = Node <$> getFQDN <*> getFQDN <*> getFQDN |

59 |
<*> arbitrary <*> arbitrary <*> arbitrary <*> getFQDN |

60 |
<*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary |

61 |
<*> arbitrary <*> arbitrary <*> getFQDN <*> arbitrary |

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

63 | |

64 |
$(genArbitrary ''FileDriver) |

65 | |

66 |
$(genArbitrary ''BlockDriver) |

67 | |

68 |
$(genArbitrary ''DiskMode) |

69 | |

70 |
instance Arbitrary DiskLogicalId where |

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

72 |
, LIDDrbd8 <$> getFQDN <*> getFQDN <*> arbitrary |

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

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

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

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

77 |
] |

78 | |

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

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

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

82 |
instance Arbitrary Disk where |

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

84 |
<*> arbitrary <*> arbitrary |

85 | |

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

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

88 |
$(genArbitrary ''PartialBeParams) |

89 | |

90 |
$(genArbitrary ''DiskTemplate) |

91 | |

92 |
$(genArbitrary ''AdminState) |

93 | |

94 |
$(genArbitrary ''NICMode) |

95 | |

96 |
$(genArbitrary ''PartialNicParams) |

97 | |

98 |
$(genArbitrary ''PartialNic) |

99 | |

100 |
instance Arbitrary Instance where |

101 |
arbitrary = |

102 |
Instance |

103 |
<$> getFQDN <*> getFQDN <*> getFQDN -- OS name, but... |

104 |
<*> arbitrary |

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

106 |
<*> pure (Container Map.empty) <*> arbitrary |

107 |
-- ... and for OSParams |

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

109 |
<*> arbitrary <*> arbitrary <*> arbitrary |

110 |
-- ts |

111 |
<*> arbitrary <*> arbitrary |

112 |
-- uuid |

113 |
<*> arbitrary |

114 |
-- serial |

115 |
<*> arbitrary |

116 |
-- tags |

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

118 | |

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

120 |
-- validation rules. |

121 |
$(genArbitrary ''PartialISpecParams) |

122 | |

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

124 |
-- validation rules. |

125 |
$(genArbitrary ''PartialIPolicy) |

126 | |

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

128 |
-- validation rules. |

129 |
instance Arbitrary NodeGroup where |

130 |
arbitrary = NodeGroup <$> getFQDN <*> pure [] <*> arbitrary <*> arbitrary |

131 |
<*> arbitrary <*> pure (Container Map.empty) |

132 |
-- ts |

133 |
<*> arbitrary <*> arbitrary |

134 |
-- uuid |

135 |
<*> arbitrary |

136 |
-- serial |

137 |
<*> arbitrary |

138 |
-- tags |

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

140 | |

141 |
$(genArbitrary ''AllocPolicy) |

142 |
$(genArbitrary ''FilledISpecParams) |

143 |
$(genArbitrary ''FilledIPolicy) |

144 |
$(genArbitrary ''IpFamily) |

145 |
$(genArbitrary ''FilledNDParams) |

146 |
$(genArbitrary ''FilledNicParams) |

147 |
$(genArbitrary ''FilledBeParams) |

148 | |

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

150 |
instance Arbitrary ClusterHvParams where |

151 |
arbitrary = return $ Container Map.empty |

152 | |

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

154 |
instance Arbitrary OsHvParams where |

155 |
arbitrary = return $ Container Map.empty |

156 | |

157 |
instance Arbitrary ClusterNicParams where |

158 |
arbitrary = (Container . Map.singleton C.ppDefault) <$> arbitrary |

159 | |

160 |
instance Arbitrary OsParams where |

161 |
arbitrary = (Container . Map.fromList) <$> arbitrary |

162 | |

163 |
instance Arbitrary ClusterOsParams where |

164 |
arbitrary = (Container . Map.fromList) <$> arbitrary |

165 | |

166 |
instance Arbitrary ClusterBeParams where |

167 |
arbitrary = (Container . Map.fromList) <$> arbitrary |

168 | |

169 |
instance Arbitrary TagSet where |

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

171 | |

172 |
$(genArbitrary ''Cluster) |

173 | |

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

175 |
-- with N defined nodes. |

176 |
genEmptyCluster :: Int -> Gen ConfigData |

177 |
genEmptyCluster ncount = do |

178 |
nodes <- vector ncount |

179 |
version <- arbitrary |

180 |
let guuid = "00" |

181 |
nodes' = zipWith (\n idx -> n { nodeGroup = guuid, |

182 |
nodeName = nodeName n ++ show idx }) |

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

184 |
contnodes = Container . Map.fromList $ map (\n -> (nodeName n, n)) nodes' |

185 |
continsts = Container Map.empty |

186 |
grp <- arbitrary |

187 |
let contgroups = Container $ Map.singleton guuid grp |

188 |
serial <- arbitrary |

189 |
cluster <- resize 8 arbitrary |

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

191 |
return c |

192 | |

193 |
-- * Test properties |

194 | |

195 |
-- | Tests that fillDict behaves correctly |

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

197 |
prop_fillDict defaults custom = |

198 |
let d_map = Map.fromList defaults |

199 |
d_keys = map fst defaults |

200 |
c_map = Map.fromList custom |

201 |
c_keys = map fst custom |

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

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

204 |
, printTestCase "Empty defaults filling" |

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

206 |
, printTestCase "Delete all keys" |

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

208 |
] |

209 | |

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

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

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

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

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

215 |
-- once, basically. |

216 |
prop_Disk_serialisation :: Disk -> Property |

217 |
prop_Disk_serialisation = testSerialisation |

218 | |

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

220 |
prop_Node_serialisation :: Node -> Property |

221 |
prop_Node_serialisation = testSerialisation |

222 | |

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

224 |
prop_Inst_serialisation :: Instance -> Property |

225 |
prop_Inst_serialisation = testSerialisation |

226 | |

227 |
-- | Check config serialisation. |

228 |
prop_Config_serialisation :: Property |

229 |
prop_Config_serialisation = |

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

231 | |

232 |
testSuite "Objects" |

233 |
[ 'prop_fillDict |

234 |
, 'prop_Disk_serialisation |

235 |
, 'prop_Inst_serialisation |

236 |
, 'prop_Node_serialisation |

237 |
, 'prop_Config_serialisation |

238 |
] |