code.grnet.gr Git - ganeti-local/blob - htest/Test/Ganeti/Objects.hs

   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.Query.Language (genJSValue)
  42 import Test.Ganeti.TestHelper
  43 import Test.Ganeti.TestCommon
  44 import Test.Ganeti.Types ()
  45
  46 import qualified Ganeti.Constants as C
  47 import Ganeti.Objects as Objects
  48 import Ganeti.JSON
  49
  50 {-# ANN module "HLint: ignore Use camelCase" #-}
  51
  52 -- * Arbitrary instances
  53
  54 $(genArbitrary ''PartialNDParams)
  55
  56 instance Arbitrary Node where
  57   arbitrary = Node <$> genFQDN <*> genFQDN <*> genFQDN
  58               <*> arbitrary <*> arbitrary <*> arbitrary <*> genFQDN
  59               <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
  60               <*> arbitrary <*> arbitrary <*> genFQDN <*> arbitrary
  61               <*> (Set.fromList <$> genTags)
  62
  63 $(genArbitrary ''BlockDriver)
  64
  65 $(genArbitrary ''DiskMode)
  66
  67 instance Arbitrary DiskLogicalId where
  68   arbitrary = oneof [ LIDPlain <$> arbitrary <*> arbitrary
  69                     , LIDDrbd8 <$> genFQDN <*> genFQDN <*> arbitrary
  70                                <*> arbitrary <*> arbitrary <*> arbitrary
  71                     , LIDFile  <$> arbitrary <*> arbitrary
  72                     , LIDBlockDev <$> arbitrary <*> arbitrary
  73                     , LIDRados <$> arbitrary <*> arbitrary
  74                     ]
  75
  76 -- | 'Disk' 'arbitrary' instance. Since we don't test disk hierarchy
  77 -- properties, we only generate disks with no children (FIXME), as
  78 -- generating recursive datastructures is a bit more work.
  79 instance Arbitrary Disk where
  80   arbitrary = Disk <$> arbitrary <*> pure [] <*> arbitrary
  81                    <*> arbitrary <*> arbitrary
  82
  83 -- FIXME: we should generate proper values, >=0, etc., but this is
  84 -- hard for partial ones, where all must be wrapped in a 'Maybe'
  85 $(genArbitrary ''PartialBeParams)
  86
  87 $(genArbitrary ''AdminState)
  88
  89 $(genArbitrary ''PartialNicParams)
  90
  91 $(genArbitrary ''PartialNic)
  92
  93 instance Arbitrary Instance where
  94   arbitrary =
  95     Instance
  96       <$> genFQDN <*> genFQDN <*> genFQDN -- OS name, but...
  97       <*> arbitrary
  98       -- FIXME: add non-empty hvparams when they're a proper type
  99       <*> pure (GenericContainer Map.empty) <*> arbitrary
 100       -- ... and for OSParams
 101       <*> pure (GenericContainer Map.empty) <*> arbitrary <*> arbitrary
 102       <*> arbitrary <*> arbitrary <*> arbitrary
 103       -- ts
 104       <*> arbitrary <*> arbitrary
 105       -- uuid
 106       <*> arbitrary
 107       -- serial
 108       <*> arbitrary
 109       -- tags
 110       <*> (Set.fromList <$> genTags)
 111
 112 -- | FIXME: This generates completely random data, without normal
 113 -- validation rules.
 114 $(genArbitrary ''PartialISpecParams)
 115
 116 -- | FIXME: This generates completely random data, without normal
 117 -- validation rules.
 118 $(genArbitrary ''PartialIPolicy)
 119
 120 -- | FIXME: This generates completely random data, without normal
 121 -- validation rules.
 122 instance Arbitrary NodeGroup where
 123   arbitrary = NodeGroup <$> genFQDN <*> pure [] <*> arbitrary <*> arbitrary
 124                         <*> arbitrary <*> pure (GenericContainer Map.empty)
 125                         -- ts
 126                         <*> arbitrary <*> arbitrary
 127                         -- uuid
 128                         <*> arbitrary
 129                         -- serial
 130                         <*> arbitrary
 131                         -- tags
 132                         <*> (Set.fromList <$> genTags)
 133
 134 $(genArbitrary ''FilledISpecParams)
 135 $(genArbitrary ''FilledIPolicy)
 136 $(genArbitrary ''IpFamily)
 137 $(genArbitrary ''FilledNDParams)
 138 $(genArbitrary ''FilledNicParams)
 139 $(genArbitrary ''FilledBeParams)
 140
 141 -- | No real arbitrary instance for 'ClusterHvParams' yet.
 142 instance Arbitrary ClusterHvParams where
 143   arbitrary = return $ GenericContainer Map.empty
 144
 145 -- | No real arbitrary instance for 'OsHvParams' yet.
 146 instance Arbitrary OsHvParams where
 147   arbitrary = return $ GenericContainer Map.empty
 148
 149 instance Arbitrary ClusterNicParams where
 150   arbitrary = (GenericContainer . Map.singleton C.ppDefault) <$> arbitrary
 151
 152 instance Arbitrary OsParams where
 153   arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
 154
 155 instance Arbitrary ClusterOsParams where
 156   arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
 157
 158 instance Arbitrary ClusterBeParams where
 159   arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
 160
 161 instance Arbitrary TagSet where
 162   arbitrary = Set.fromList <$> genTags
 163
 164 $(genArbitrary ''Cluster)
 165
 166 instance Arbitrary Network where
 167   arbitrary = Network <$>
 168                         -- name
 169                         arbitrary
 170                         -- network_type
 171                         <*> arbitrary
 172                         -- mac_prefix
 173                         <*> arbitrary
 174                         -- family
 175                         <*> arbitrary
 176                         -- network
 177                         <*> arbitrary
 178                         -- network6
 179                         <*> arbitrary
 180                         -- gateway
 181                         <*> arbitrary
 182                         -- gateway6
 183                         <*> arbitrary
 184                         -- size
 185                         <*> genMaybe genJSValue
 186                         -- reservations
 187                         <*> arbitrary
 188                         -- external reservations
 189                         <*> arbitrary
 190                         -- serial
 191                         <*> arbitrary
 192                         -- tags
 193                         <*> (Set.fromList <$> genTags)
 194
 195 -- | Generator for config data with an empty cluster (no instances),
 196 -- with N defined nodes.
 197 genEmptyCluster :: Int -> Gen ConfigData
 198 genEmptyCluster ncount = do
 199   nodes <- vector ncount
 200   version <- arbitrary
 201   let guuid = "00"
 202       nodes' = zipWith (\n idx ->
 203                           let newname = nodeName n ++ "-" ++ show idx
 204                           in (newname, n { nodeGroup = guuid,
 205                                            nodeName = newname}))
 206                nodes [(1::Int)..]
 207       nodemap = Map.fromList nodes'
 208       contnodes = if Map.size nodemap /= ncount
 209                     then error ("Inconsistent node map, duplicates in" ++
 210                                 " node name list? Names: " ++
 211                                 show (map fst nodes'))
 212                     else GenericContainer nodemap
 213       continsts = GenericContainer Map.empty
 214   grp <- arbitrary
 215   let contgroups = GenericContainer $ Map.singleton guuid grp
 216   serial <- arbitrary
 217   cluster <- resize 8 arbitrary
 218   let c = ConfigData version cluster contnodes contgroups continsts serial
 219   return c
 220
 221 -- * Test properties
 222
 223 -- | Tests that fillDict behaves correctly
 224 prop_fillDict :: [(Int, Int)] -> [(Int, Int)] -> Property
 225 prop_fillDict defaults custom =
 226   let d_map = Map.fromList defaults
 227       d_keys = map fst defaults
 228       c_map = Map.fromList custom
 229       c_keys = map fst custom
 230   in conjoin [ printTestCase "Empty custom filling"
 231                (fillDict d_map Map.empty [] == d_map)
 232              , printTestCase "Empty defaults filling"
 233                (fillDict Map.empty c_map [] == c_map)
 234              , printTestCase "Delete all keys"
 235                (fillDict d_map c_map (d_keys++c_keys) == Map.empty)
 236              ]
 237
 238 -- | Test that the serialisation of 'DiskLogicalId', which is
 239 -- implemented manually, is idempotent. Since we don't have a
 240 -- standalone JSON instance for DiskLogicalId (it's a data type that
 241 -- expands over two fields in a JSObject), we test this by actially
 242 -- testing entire Disk serialisations. So this tests two things at
 243 -- once, basically.
 244 prop_Disk_serialisation :: Disk -> Property
 245 prop_Disk_serialisation = testSerialisation
 246
 247 -- | Check that node serialisation is idempotent.
 248 prop_Node_serialisation :: Node -> Property
 249 prop_Node_serialisation = testSerialisation
 250
 251 -- | Check that instance serialisation is idempotent.
 252 prop_Inst_serialisation :: Instance -> Property
 253 prop_Inst_serialisation = testSerialisation
 254
 255 -- | Check that network serialisation is idempotent.
 256 prop_Network_serialisation :: Network -> Property
 257 prop_Network_serialisation = testSerialisation
 258
 259 -- | Check config serialisation.
 260 prop_Config_serialisation :: Property
 261 prop_Config_serialisation =
 262   forAll (choose (0, maxNodes `div` 4) >>= genEmptyCluster) testSerialisation
 263
 264 testSuite "Objects"
 265   [ 'prop_fillDict
 266   , 'prop_Disk_serialisation
 267   , 'prop_Inst_serialisation
 268   , 'prop_Network_serialisation
 269   , 'prop_Node_serialisation
 270   , 'prop_Config_serialisation
 271   ]