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 -- * Arbitrary instances
52 $(genArbitrary ''Hypervisor)
54 $(genArbitrary ''PartialNDParams)
56 instance Arbitrary Node where
57 arbitrary = Node <$> getFQDN <*> getFQDN <*> getFQDN
58 <*> arbitrary <*> arbitrary <*> arbitrary <*> getFQDN
59 <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
60 <*> arbitrary <*> arbitrary <*> getFQDN <*> arbitrary
61 <*> (Set.fromList <$> genTags)
63 $(genArbitrary ''FileDriver)
65 $(genArbitrary ''BlockDriver)
67 $(genArbitrary ''DiskMode)
69 instance Arbitrary DiskLogicalId where
70 arbitrary = oneof [ LIDPlain <$> arbitrary <*> arbitrary
71 , LIDDrbd8 <$> getFQDN <*> getFQDN <*> arbitrary
72 <*> arbitrary <*> arbitrary <*> arbitrary
73 , LIDFile <$> arbitrary <*> arbitrary
74 , LIDBlockDev <$> arbitrary <*> arbitrary
75 , LIDRados <$> arbitrary <*> arbitrary
78 -- | 'Disk' 'arbitrary' instance. Since we don't test disk hierarchy
79 -- properties, we only generate disks with no children (FIXME), as
80 -- generating recursive datastructures is a bit more work.
81 instance Arbitrary Disk where
82 arbitrary = Disk <$> arbitrary <*> (pure []) <*> arbitrary
83 <*> arbitrary <*> arbitrary
85 -- FIXME: we should generate proper values, >=0, etc., but this is
86 -- hard for partial ones, where all must be wrapped in a 'Maybe'
87 $(genArbitrary ''PartialBeParams)
89 $(genArbitrary ''DiskTemplate)
91 $(genArbitrary ''AdminState)
93 $(genArbitrary ''NICMode)
95 $(genArbitrary ''PartialNicParams)
97 $(genArbitrary ''PartialNic)
99 instance Arbitrary Instance where
102 <$> getFQDN <*> getFQDN <*> getFQDN -- OS name, but...
104 -- FIXME: add non-empty hvparams when they're a proper type
105 <*> (pure $ Container Map.empty) <*> arbitrary
106 -- ... and for OSParams
107 <*> (pure $ Container Map.empty) <*> arbitrary <*> arbitrary
108 <*> arbitrary <*> arbitrary <*> arbitrary
110 <*> arbitrary <*> arbitrary
116 <*> (Set.fromList <$> genTags)
118 -- | FIXME: This generates completely random data, without normal
120 $(genArbitrary ''PartialISpecParams)
122 -- | FIXME: This generates completely random data, without normal
124 $(genArbitrary ''PartialIPolicy)
126 -- | FIXME: This generates completely random data, without normal
128 instance Arbitrary NodeGroup where
129 arbitrary = NodeGroup <$> getFQDN <*> pure [] <*> arbitrary <*> arbitrary
130 <*> arbitrary <*> (pure $ Container Map.empty)
132 <*> arbitrary <*> arbitrary
138 <*> (Set.fromList <$> genTags)
140 $(genArbitrary ''AllocPolicy)
141 $(genArbitrary ''FilledISpecParams)
142 $(genArbitrary ''FilledIPolicy)
143 $(genArbitrary ''IpFamily)
144 $(genArbitrary ''FilledNDParams)
145 $(genArbitrary ''FilledNicParams)
146 $(genArbitrary ''FilledBeParams)
148 -- | No real arbitrary instance for 'ClusterHvParams' yet.
149 instance Arbitrary ClusterHvParams where
150 arbitrary = return $ Container Map.empty
152 -- | No real arbitrary instance for 'OsHvParams' yet.
153 instance Arbitrary OsHvParams where
154 arbitrary = return $ Container Map.empty
156 instance Arbitrary ClusterNicParams where
157 arbitrary = (Container . Map.singleton C.ppDefault) <$> arbitrary
159 instance Arbitrary OsParams where
160 arbitrary = (Container . Map.fromList) <$> arbitrary
162 instance Arbitrary ClusterOsParams where
163 arbitrary = (Container . Map.fromList) <$> arbitrary
165 instance Arbitrary ClusterBeParams where
166 arbitrary = (Container . Map.fromList) <$> arbitrary
168 instance Arbitrary TagSet where
169 arbitrary = Set.fromList <$> genTags
171 $(genArbitrary ''Cluster)
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
180 nodes' = zipWith (\n idx -> n { nodeGroup = guuid,
181 nodeName = nodeName n ++ show idx })
183 contnodes = Container . Map.fromList $ map (\n -> (nodeName n, n)) nodes'
184 continsts = Container $ Map.empty
186 let contgroups = Container $ Map.singleton guuid grp
189 let c = ConfigData version cluster contnodes contgroups continsts serial
194 -- | Tests that fillDict behaves correctly
195 prop_fillDict :: [(Int, Int)] -> [(Int, Int)] -> Property
196 prop_fillDict defaults custom =
197 let d_map = Map.fromList defaults
198 d_keys = map fst defaults
199 c_map = Map.fromList custom
200 c_keys = map fst custom
201 in printTestCase "Empty custom filling"
202 (fillDict d_map Map.empty [] == d_map) .&&.
203 printTestCase "Empty defaults filling"
204 (fillDict Map.empty c_map [] == c_map) .&&.
205 printTestCase "Delete all keys"
206 (fillDict d_map c_map (d_keys++c_keys) == Map.empty)
208 -- | Test that the serialisation of 'DiskLogicalId', which is
209 -- implemented manually, is idempotent. Since we don't have a
210 -- standalone JSON instance for DiskLogicalId (it's a data type that
211 -- expands over two fields in a JSObject), we test this by actially
212 -- testing entire Disk serialisations. So this tests two things at
214 prop_Disk_serialisation :: Disk -> Property
215 prop_Disk_serialisation = testSerialisation
217 -- | Check that node serialisation is idempotent.
218 prop_Node_serialisation :: Node -> Property
219 prop_Node_serialisation = testSerialisation
221 -- | Check that instance serialisation is idempotent.
222 prop_Inst_serialisation :: Instance -> Property
223 prop_Inst_serialisation = testSerialisation
225 -- | Check config serialisation.
226 prop_Config_serialisation :: Property
227 prop_Config_serialisation =
228 forAll (choose (0, maxNodes) >>= genEmptyCluster) testSerialisation
232 , 'prop_Disk_serialisation
233 , 'prop_Inst_serialisation
234 , 'prop_Node_serialisation
237 testSuite "SlowObjects"
238 [ 'prop_Config_serialisation