Statistics
| Branch: | Tag: | Revision:

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

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 ''BlockDriver)
63

    
64
$(genArbitrary ''DiskMode)
65

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

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

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

    
86
$(genArbitrary ''AdminState)
87

    
88
$(genArbitrary ''NICMode)
89

    
90
$(genArbitrary ''PartialNicParams)
91

    
92
$(genArbitrary ''PartialNic)
93

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

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

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

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

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

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

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

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

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

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

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

    
162
instance Arbitrary TagSet where
163
  arbitrary = Set.fromList <$> genTags
164

    
165
$(genArbitrary ''Cluster)
166

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

    
187
-- * Test properties
188

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

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

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

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

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

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