Statistics
| Branch: | Tag: | Revision:

root / htest / Test / Ganeti / Objects.hs @ 22381768

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
  , Node(..)
32
  , genEmptyCluster
33
  ) where
34

    
35
import Test.QuickCheck
36

    
37
import Control.Applicative
38
import qualified Data.Map as Map
39
import qualified Data.Set as Set
40

    
41
import Test.Ganeti.TestHelper
42
import Test.Ganeti.TestCommon
43
import Test.Ganeti.Types ()
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 ''PartialNDParams)
54

    
55
instance Arbitrary Node where
56
  arbitrary = Node <$> getFQDN <*> getFQDN <*> getFQDN
57
              <*> arbitrary <*> arbitrary <*> arbitrary <*> getFQDN
58
              <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
59
              <*> arbitrary <*> arbitrary <*> getFQDN <*> arbitrary
60
              <*> (Set.fromList <$> genTags)
61

    
62
$(genArbitrary ''FileDriver)
63

    
64
$(genArbitrary ''BlockDriver)
65

    
66
$(genArbitrary ''DiskMode)
67

    
68
instance Arbitrary DiskLogicalId where
69
  arbitrary = oneof [ LIDPlain <$> arbitrary <*> arbitrary
70
                    , LIDDrbd8 <$> getFQDN <*> getFQDN <*> arbitrary
71
                               <*> arbitrary <*> arbitrary <*> arbitrary
72
                    , LIDFile  <$> arbitrary <*> arbitrary
73
                    , LIDBlockDev <$> arbitrary <*> arbitrary
74
                    , LIDRados <$> arbitrary <*> arbitrary
75
                    ]
76

    
77
-- | 'Disk' 'arbitrary' instance. Since we don't test disk hierarchy
78
-- properties, we only generate disks with no children (FIXME), as
79
-- generating recursive datastructures is a bit more work.
80
instance Arbitrary Disk where
81
  arbitrary = Disk <$> arbitrary <*> pure [] <*> arbitrary
82
                   <*> arbitrary <*> arbitrary
83

    
84
-- FIXME: we should generate proper values, >=0, etc., but this is
85
-- hard for partial ones, where all must be wrapped in a 'Maybe'
86
$(genArbitrary ''PartialBeParams)
87

    
88
$(genArbitrary ''AdminState)
89

    
90
$(genArbitrary ''NICMode)
91

    
92
$(genArbitrary ''PartialNicParams)
93

    
94
$(genArbitrary ''PartialNic)
95

    
96
instance Arbitrary Instance where
97
  arbitrary =
98
    Instance
99
      <$> getFQDN <*> getFQDN <*> getFQDN -- OS name, but...
100
      <*> arbitrary
101
      -- FIXME: add non-empty hvparams when they're a proper type
102
      <*> pure (GenericContainer Map.empty) <*> arbitrary
103
      -- ... and for OSParams
104
      <*> pure (GenericContainer Map.empty) <*> arbitrary <*> arbitrary
105
      <*> arbitrary <*> arbitrary <*> arbitrary
106
      -- ts
107
      <*> arbitrary <*> arbitrary
108
      -- uuid
109
      <*> arbitrary
110
      -- serial
111
      <*> arbitrary
112
      -- tags
113
      <*> (Set.fromList <$> genTags)
114

    
115
-- | FIXME: This generates completely random data, without normal
116
-- validation rules.
117
$(genArbitrary ''PartialISpecParams)
118

    
119
-- | FIXME: This generates completely random data, without normal
120
-- validation rules.
121
$(genArbitrary ''PartialIPolicy)
122

    
123
-- | FIXME: This generates completely random data, without normal
124
-- validation rules.
125
instance Arbitrary NodeGroup where
126
  arbitrary = NodeGroup <$> getFQDN <*> pure [] <*> arbitrary <*> arbitrary
127
                        <*> arbitrary <*> pure (GenericContainer Map.empty)
128
                        -- ts
129
                        <*> arbitrary <*> arbitrary
130
                        -- uuid
131
                        <*> arbitrary
132
                        -- serial
133
                        <*> arbitrary
134
                        -- tags
135
                        <*> (Set.fromList <$> genTags)
136

    
137
$(genArbitrary ''FilledISpecParams)
138
$(genArbitrary ''FilledIPolicy)
139
$(genArbitrary ''IpFamily)
140
$(genArbitrary ''FilledNDParams)
141
$(genArbitrary ''FilledNicParams)
142
$(genArbitrary ''FilledBeParams)
143

    
144
-- | No real arbitrary instance for 'ClusterHvParams' yet.
145
instance Arbitrary ClusterHvParams where
146
  arbitrary = return $ GenericContainer Map.empty
147

    
148
-- | No real arbitrary instance for 'OsHvParams' yet.
149
instance Arbitrary OsHvParams where
150
  arbitrary = return $ GenericContainer Map.empty
151

    
152
instance Arbitrary ClusterNicParams where
153
  arbitrary = (GenericContainer . Map.singleton C.ppDefault) <$> arbitrary
154

    
155
instance Arbitrary OsParams where
156
  arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
157

    
158
instance Arbitrary ClusterOsParams where
159
  arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
160

    
161
instance Arbitrary ClusterBeParams where
162
  arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
163

    
164
instance Arbitrary TagSet where
165
  arbitrary = Set.fromList <$> genTags
166

    
167
$(genArbitrary ''Cluster)
168

    
169
-- | Generator for config data with an empty cluster (no instances),
170
-- with N defined nodes.
171
genEmptyCluster :: Int -> Gen ConfigData
172
genEmptyCluster ncount = do
173
  nodes <- vector ncount
174
  version <- arbitrary
175
  let guuid = "00"
176
      nodes' = zipWith (\n idx -> n { nodeGroup = guuid,
177
                                      nodeName = nodeName n ++ show idx })
178
               nodes [(1::Int)..]
179
      contnodes = GenericContainer . Map.fromList $
180
                  map (\n -> (nodeName n, n)) nodes'
181
      continsts = GenericContainer Map.empty
182
  grp <- arbitrary
183
  let contgroups = GenericContainer $ Map.singleton guuid grp
184
  serial <- arbitrary
185
  cluster <- resize 8 arbitrary
186
  let c = ConfigData version cluster contnodes contgroups continsts serial
187
  return c
188

    
189
-- * Test properties
190

    
191
-- | Tests that fillDict behaves correctly
192
prop_fillDict :: [(Int, Int)] -> [(Int, Int)] -> Property
193
prop_fillDict defaults custom =
194
  let d_map = Map.fromList defaults
195
      d_keys = map fst defaults
196
      c_map = Map.fromList custom
197
      c_keys = map fst custom
198
  in conjoin [ printTestCase "Empty custom filling"
199
               (fillDict d_map Map.empty [] == d_map)
200
             , printTestCase "Empty defaults filling"
201
               (fillDict Map.empty c_map [] == c_map)
202
             , printTestCase "Delete all keys"
203
               (fillDict d_map c_map (d_keys++c_keys) == Map.empty)
204
             ]
205

    
206
-- | Test that the serialisation of 'DiskLogicalId', which is
207
-- implemented manually, is idempotent. Since we don't have a
208
-- standalone JSON instance for DiskLogicalId (it's a data type that
209
-- expands over two fields in a JSObject), we test this by actially
210
-- testing entire Disk serialisations. So this tests two things at
211
-- once, basically.
212
prop_Disk_serialisation :: Disk -> Property
213
prop_Disk_serialisation = testSerialisation
214

    
215
-- | Check that node serialisation is idempotent.
216
prop_Node_serialisation :: Node -> Property
217
prop_Node_serialisation = testSerialisation
218

    
219
-- | Check that instance serialisation is idempotent.
220
prop_Inst_serialisation :: Instance -> Property
221
prop_Inst_serialisation = testSerialisation
222

    
223
-- | Check config serialisation.
224
prop_Config_serialisation :: Property
225
prop_Config_serialisation =
226
  forAll (choose (0, maxNodes `div` 4) >>= genEmptyCluster) testSerialisation
227

    
228
testSuite "Objects"
229
  [ 'prop_fillDict
230
  , 'prop_Disk_serialisation
231
  , 'prop_Inst_serialisation
232
  , 'prop_Node_serialisation
233
  , 'prop_Config_serialisation
234
  ]