1 {-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
4 {-| Unittests for ganeti-htools.
10 Copyright (C) 2009, 2010, 2011, 2012 Google Inc.
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.
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.
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
29 module Test.Ganeti.Objects
37 import Test.QuickCheck
39 import Control.Applicative
40 import qualified Data.Map as Map
41 import qualified Data.Set as Set
43 import Test.Ganeti.TestHelper
44 import Test.Ganeti.TestCommon
46 import qualified Ganeti.Constants as C
47 import Ganeti.Objects as Objects
50 {-# ANN module "HLint: ignore Use camelCase" #-}
52 -- * Arbitrary instances
54 $(genArbitrary ''Hypervisor)
56 $(genArbitrary ''PartialNDParams)
58 instance Arbitrary Node where
59 arbitrary = Node <$> getFQDN <*> getFQDN <*> getFQDN
60 <*> arbitrary <*> arbitrary <*> arbitrary <*> getFQDN
61 <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
62 <*> arbitrary <*> arbitrary <*> getFQDN <*> arbitrary
63 <*> (Set.fromList <$> genTags)
65 $(genArbitrary ''FileDriver)
67 $(genArbitrary ''BlockDriver)
69 $(genArbitrary ''DiskMode)
71 instance Arbitrary DiskLogicalId where
72 arbitrary = oneof [ LIDPlain <$> arbitrary <*> arbitrary
73 , LIDDrbd8 <$> getFQDN <*> getFQDN <*> arbitrary
74 <*> arbitrary <*> arbitrary <*> arbitrary
75 , LIDFile <$> arbitrary <*> arbitrary
76 , LIDBlockDev <$> arbitrary <*> arbitrary
77 , LIDRados <$> arbitrary <*> arbitrary
80 -- | 'Disk' 'arbitrary' instance. Since we don't test disk hierarchy
81 -- properties, we only generate disks with no children (FIXME), as
82 -- generating recursive datastructures is a bit more work.
83 instance Arbitrary Disk where
84 arbitrary = Disk <$> arbitrary <*> pure [] <*> arbitrary
85 <*> arbitrary <*> arbitrary
87 -- FIXME: we should generate proper values, >=0, etc., but this is
88 -- hard for partial ones, where all must be wrapped in a 'Maybe'
89 $(genArbitrary ''PartialBeParams)
91 $(genArbitrary ''DiskTemplate)
93 $(genArbitrary ''AdminState)
95 $(genArbitrary ''NICMode)
97 $(genArbitrary ''PartialNicParams)
99 $(genArbitrary ''PartialNic)
101 instance Arbitrary Instance where
104 <$> getFQDN <*> getFQDN <*> getFQDN -- OS name, but...
106 -- FIXME: add non-empty hvparams when they're a proper type
107 <*> pure (Container Map.empty) <*> arbitrary
108 -- ... and for OSParams
109 <*> pure (Container Map.empty) <*> arbitrary <*> arbitrary
110 <*> arbitrary <*> arbitrary <*> arbitrary
112 <*> arbitrary <*> arbitrary
118 <*> (Set.fromList <$> genTags)
120 -- | FIXME: This generates completely random data, without normal
122 $(genArbitrary ''PartialISpecParams)
124 -- | FIXME: This generates completely random data, without normal
126 $(genArbitrary ''PartialIPolicy)
128 -- | FIXME: This generates completely random data, without normal
130 instance Arbitrary NodeGroup where
131 arbitrary = NodeGroup <$> getFQDN <*> pure [] <*> arbitrary <*> arbitrary
132 <*> arbitrary <*> pure (Container Map.empty)
134 <*> arbitrary <*> arbitrary
140 <*> (Set.fromList <$> genTags)
142 $(genArbitrary ''AllocPolicy)
143 $(genArbitrary ''FilledISpecParams)
144 $(genArbitrary ''FilledIPolicy)
145 $(genArbitrary ''IpFamily)
146 $(genArbitrary ''FilledNDParams)
147 $(genArbitrary ''FilledNicParams)
148 $(genArbitrary ''FilledBeParams)
150 -- | No real arbitrary instance for 'ClusterHvParams' yet.
151 instance Arbitrary ClusterHvParams where
152 arbitrary = return $ Container Map.empty
154 -- | No real arbitrary instance for 'OsHvParams' yet.
155 instance Arbitrary OsHvParams where
156 arbitrary = return $ Container Map.empty
158 instance Arbitrary ClusterNicParams where
159 arbitrary = (Container . Map.singleton C.ppDefault) <$> arbitrary
161 instance Arbitrary OsParams where
162 arbitrary = (Container . Map.fromList) <$> arbitrary
164 instance Arbitrary ClusterOsParams where
165 arbitrary = (Container . Map.fromList) <$> arbitrary
167 instance Arbitrary ClusterBeParams where
168 arbitrary = (Container . Map.fromList) <$> arbitrary
170 instance Arbitrary TagSet where
171 arbitrary = Set.fromList <$> genTags
173 $(genArbitrary ''Cluster)
175 -- | Generator for config data with an empty cluster (no instances),
176 -- with N defined nodes.
177 genEmptyCluster :: Int -> Gen ConfigData
178 genEmptyCluster ncount = do
179 nodes <- vector ncount
182 nodes' = zipWith (\n idx -> n { nodeGroup = guuid,
183 nodeName = nodeName n ++ show idx })
185 contnodes = Container . Map.fromList $ map (\n -> (nodeName n, n)) nodes'
186 continsts = Container Map.empty
188 let contgroups = Container $ Map.singleton guuid grp
191 let c = ConfigData version cluster contnodes contgroups continsts serial
196 -- | Tests that fillDict behaves correctly
197 prop_fillDict :: [(Int, Int)] -> [(Int, Int)] -> Property
198 prop_fillDict defaults custom =
199 let d_map = Map.fromList defaults
200 d_keys = map fst defaults
201 c_map = Map.fromList custom
202 c_keys = map fst custom
203 in printTestCase "Empty custom filling"
204 (fillDict d_map Map.empty [] == d_map) .&&.
205 printTestCase "Empty defaults filling"
206 (fillDict Map.empty c_map [] == c_map) .&&.
207 printTestCase "Delete all keys"
208 (fillDict d_map c_map (d_keys++c_keys) == Map.empty)
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
216 prop_Disk_serialisation :: Disk -> Property
217 prop_Disk_serialisation = testSerialisation
219 -- | Check that node serialisation is idempotent.
220 prop_Node_serialisation :: Node -> Property
221 prop_Node_serialisation = testSerialisation
223 -- | Check that instance serialisation is idempotent.
224 prop_Inst_serialisation :: Instance -> Property
225 prop_Inst_serialisation = testSerialisation
227 -- | Check config serialisation.
228 prop_Config_serialisation :: Property
229 prop_Config_serialisation =
230 forAll (choose (0, maxNodes) >>= genEmptyCluster) testSerialisation
234 , 'prop_Disk_serialisation
235 , 'prop_Inst_serialisation
236 , 'prop_Node_serialisation
239 testSuite "SlowObjects"
240 [ 'prop_Config_serialisation