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 -- * Arbitrary instances
  51
  52 $(genArbitrary ''Hypervisor)
  53
  54 $(genArbitrary ''PartialNDParams)
  55
  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)
  62
  63 $(genArbitrary ''FileDriver)
  64
  65 $(genArbitrary ''BlockDriver)
  66
  67 $(genArbitrary ''DiskMode)
  68
  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
  76                     ]
  77
  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
  84
  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)
  88
  89 $(genArbitrary ''DiskTemplate)
  90
  91 $(genArbitrary ''AdminState)
  92
  93 $(genArbitrary ''NICMode)
  94
  95 $(genArbitrary ''PartialNicParams)
  96
  97 $(genArbitrary ''PartialNic)
  98
  99 instance Arbitrary Instance where
 100   arbitrary =
 101     Instance
 102       <$> getFQDN <*> getFQDN <*> getFQDN -- OS name, but...
 103       <*> arbitrary
 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
 109       -- ts
 110       <*> arbitrary <*> arbitrary
 111       -- uuid
 112       <*> arbitrary
 113       -- serial
 114       <*> arbitrary
 115       -- tags
 116       <*> (Set.fromList <$> genTags)
 117
 118 -- | FIXME: This generates completely random data, without normal
 119 -- validation rules.
 120 $(genArbitrary ''PartialISpecParams)
 121
 122 -- | FIXME: This generates completely random data, without normal
 123 -- validation rules.
 124 $(genArbitrary ''PartialIPolicy)
 125
 126 -- | FIXME: This generates completely random data, without normal
 127 -- validation rules.
 128 instance Arbitrary NodeGroup where
 129   arbitrary = NodeGroup <$> getFQDN <*> pure [] <*> arbitrary <*> arbitrary
 130                         <*> arbitrary <*> (pure $ Container Map.empty)
 131                         -- ts
 132                         <*> arbitrary <*> arbitrary
 133                         -- uuid
 134                         <*> arbitrary
 135                         -- serial
 136                         <*> arbitrary
 137                         -- tags
 138                         <*> (Set.fromList <$> genTags)
 139
 140 $(genArbitrary ''AllocPolicy)
 141 $(genArbitrary ''FilledISpecParams)
 142 $(genArbitrary ''FilledIPolicy)
 143 $(genArbitrary ''IpFamily)
 144 $(genArbitrary ''FilledNDParams)
 145 $(genArbitrary ''FilledNicParams)
 146 $(genArbitrary ''FilledBeParams)
 147
 148 -- | No real arbitrary instance for 'ClusterHvParams' yet.
 149 instance Arbitrary ClusterHvParams where
 150   arbitrary = return $ Container Map.empty
 151
 152 -- | No real arbitrary instance for 'OsHvParams' yet.
 153 instance Arbitrary OsHvParams where
 154   arbitrary = return $ Container Map.empty
 155
 156 instance Arbitrary ClusterNicParams where
 157   arbitrary = (Container . Map.singleton C.ppDefault) <$> arbitrary
 158
 159 instance Arbitrary OsParams where
 160   arbitrary = (Container . Map.fromList) <$> arbitrary
 161
 162 instance Arbitrary ClusterOsParams where
 163   arbitrary = (Container . Map.fromList) <$> arbitrary
 164
 165 instance Arbitrary ClusterBeParams where
 166   arbitrary = (Container . Map.fromList) <$> arbitrary
 167
 168 instance Arbitrary TagSet where
 169   arbitrary = Set.fromList <$> genTags
 170
 171 $(genArbitrary ''Cluster)
 172
 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
 178   version <- arbitrary
 179   let guuid = "00"
 180       nodes' = map (\n -> n { nodeGroup = guuid }) nodes
 181       contnodes = Container . Map.fromList $ map (\n -> (nodeName n, n)) nodes'
 182       continsts = Container $ Map.empty
 183   grp <- arbitrary
 184   let contgroups = Container $ Map.singleton guuid grp
 185   serial <- arbitrary
 186   cluster <- arbitrary
 187   let c = ConfigData version cluster contnodes contgroups continsts serial
 188   return c
 189
 190 -- * Test properties
 191
 192 -- | Tests that fillDict behaves correctly
 193 prop_fillDict :: [(Int, Int)] -> [(Int, Int)] -> Property
 194 prop_fillDict defaults custom =
 195   let d_map = Map.fromList defaults
 196       d_keys = map fst defaults
 197       c_map = Map.fromList custom
 198       c_keys = map fst custom
 199   in printTestCase "Empty custom filling"
 200       (fillDict d_map Map.empty [] == d_map) .&&.
 201      printTestCase "Empty defaults filling"
 202       (fillDict Map.empty c_map [] == c_map) .&&.
 203      printTestCase "Delete all keys"
 204       (fillDict d_map c_map (d_keys++c_keys) == Map.empty)
 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) >>= genEmptyCluster) testSerialisation
 227
 228 testSuite "Objects"
 229   [ 'prop_fillDict
 230   , 'prop_Disk_serialisation
 231   , 'prop_Inst_serialisation
 232   , 'prop_Node_serialisation
 233   ]
 234
 235 testSuite "SlowObjects"
 236   [ 'prop_Config_serialisation
 237   ]