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   , testSlowObjects
  32   , Hypervisor(..)
  33   , Node(..)
  34   , genEmptyCluster
  35   ) where
  36
  37 import Test.QuickCheck
  38
  39 import Control.Applicative
  40 import qualified Data.Map as Map
  41 import qualified Data.Set as Set
  42
  43 import Test.Ganeti.TestHelper
  44 import Test.Ganeti.TestCommon
  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 ''Hypervisor)
  55
  56 $(genArbitrary ''PartialNDParams)
  57
  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)
  64
  65 $(genArbitrary ''FileDriver)
  66
  67 $(genArbitrary ''BlockDriver)
  68
  69 $(genArbitrary ''DiskMode)
  70
  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
  78                     ]
  79
  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
  86
  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)
  90
  91 $(genArbitrary ''DiskTemplate)
  92
  93 $(genArbitrary ''AdminState)
  94
  95 $(genArbitrary ''NICMode)
  96
  97 $(genArbitrary ''PartialNicParams)
  98
  99 $(genArbitrary ''PartialNic)
 100
 101 instance Arbitrary Instance where
 102   arbitrary =
 103     Instance
 104       <$> getFQDN <*> getFQDN <*> getFQDN -- OS name, but...
 105       <*> arbitrary
 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
 111       -- ts
 112       <*> arbitrary <*> arbitrary
 113       -- uuid
 114       <*> arbitrary
 115       -- serial
 116       <*> arbitrary
 117       -- tags
 118       <*> (Set.fromList <$> genTags)
 119
 120 -- | FIXME: This generates completely random data, without normal
 121 -- validation rules.
 122 $(genArbitrary ''PartialISpecParams)
 123
 124 -- | FIXME: This generates completely random data, without normal
 125 -- validation rules.
 126 $(genArbitrary ''PartialIPolicy)
 127
 128 -- | FIXME: This generates completely random data, without normal
 129 -- validation rules.
 130 instance Arbitrary NodeGroup where
 131   arbitrary = NodeGroup <$> getFQDN <*> pure [] <*> arbitrary <*> arbitrary
 132                         <*> arbitrary <*> pure (Container Map.empty)
 133                         -- ts
 134                         <*> arbitrary <*> arbitrary
 135                         -- uuid
 136                         <*> arbitrary
 137                         -- serial
 138                         <*> arbitrary
 139                         -- tags
 140                         <*> (Set.fromList <$> genTags)
 141
 142 $(genArbitrary ''AllocPolicy)
 143 $(genArbitrary ''FilledISpecParams)
 144 $(genArbitrary ''FilledIPolicy)
 145 $(genArbitrary ''IpFamily)
 146 $(genArbitrary ''FilledNDParams)
 147 $(genArbitrary ''FilledNicParams)
 148 $(genArbitrary ''FilledBeParams)
 149
 150 -- | No real arbitrary instance for 'ClusterHvParams' yet.
 151 instance Arbitrary ClusterHvParams where
 152   arbitrary = return $ Container Map.empty
 153
 154 -- | No real arbitrary instance for 'OsHvParams' yet.
 155 instance Arbitrary OsHvParams where
 156   arbitrary = return $ Container Map.empty
 157
 158 instance Arbitrary ClusterNicParams where
 159   arbitrary = (Container . Map.singleton C.ppDefault) <$> arbitrary
 160
 161 instance Arbitrary OsParams where
 162   arbitrary = (Container . Map.fromList) <$> arbitrary
 163
 164 instance Arbitrary ClusterOsParams where
 165   arbitrary = (Container . Map.fromList) <$> arbitrary
 166
 167 instance Arbitrary ClusterBeParams where
 168   arbitrary = (Container . Map.fromList) <$> arbitrary
 169
 170 instance Arbitrary TagSet where
 171   arbitrary = Set.fromList <$> genTags
 172
 173 $(genArbitrary ''Cluster)
 174
 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
 180   version <- arbitrary
 181   let guuid = "00"
 182       nodes' = zipWith (\n idx -> n { nodeGroup = guuid,
 183                                       nodeName = nodeName n ++ show idx })
 184                nodes [(1::Int)..]
 185       contnodes = Container . Map.fromList $ map (\n -> (nodeName n, n)) nodes'
 186       continsts = Container Map.empty
 187   grp <- arbitrary
 188   let contgroups = Container $ Map.singleton guuid grp
 189   serial <- arbitrary
 190   cluster <- arbitrary
 191   let c = ConfigData version cluster contnodes contgroups continsts serial
 192   return c
 193
 194 -- * Test properties
 195
 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)
 209
 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
 215 -- once, basically.
 216 prop_Disk_serialisation :: Disk -> Property
 217 prop_Disk_serialisation = testSerialisation
 218
 219 -- | Check that node serialisation is idempotent.
 220 prop_Node_serialisation :: Node -> Property
 221 prop_Node_serialisation = testSerialisation
 222
 223 -- | Check that instance serialisation is idempotent.
 224 prop_Inst_serialisation :: Instance -> Property
 225 prop_Inst_serialisation = testSerialisation
 226
 227 -- | Check config serialisation.
 228 prop_Config_serialisation :: Property
 229 prop_Config_serialisation =
 230   forAll (choose (0, maxNodes) >>= genEmptyCluster) testSerialisation
 231
 232 testSuite "Objects"
 233   [ 'prop_fillDict
 234   , 'prop_Disk_serialisation
 235   , 'prop_Inst_serialisation
 236   , 'prop_Node_serialisation
 237   ]
 238
 239 testSuite "SlowObjects"
 240   [ 'prop_Config_serialisation
 241   ]