diff --git a/htest/Test/Ganeti/Objects.hs b/htest/Test/Ganeti/Objects.hs index 4d94fdb4fbde315c39dff8476256f9408291bd50..c6d8e89d7d68295b08e2511f6efa1348761e0b64 100644 --- a/htest/Test/Ganeti/Objects.hs +++ b/htest/Test/Ganeti/Objects.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-| Unittests for ganeti-htools. @@ -28,8 +28,10 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA module Test.Ganeti.Objects ( testObjects + , testSlowObjects , Hypervisor(..) , Node(..) + , genEmptyCluster ) where import Test.QuickCheck @@ -40,6 +42,8 @@ import qualified Data.Set as Set import Test.Ganeti.TestHelper import Test.Ganeti.TestCommon + +import qualified Ganeti.Constants as C import Ganeti.Objects as Objects import Ganeti.JSON @@ -111,6 +115,78 @@ instance Arbitrary Instance where -- tags <*> (Set.fromList <$> genTags) +-- | FIXME: This generates completely random data, without normal +-- validation rules. +$(genArbitrary ''PartialISpecParams) + +-- | FIXME: This generates completely random data, without normal +-- validation rules. +$(genArbitrary ''PartialIPolicy) + +-- | FIXME: This generates completely random data, without normal +-- validation rules. +instance Arbitrary NodeGroup where + arbitrary = NodeGroup <$> getFQDN <*> pure [] <*> arbitrary <*> arbitrary + <*> arbitrary <*> (pure $ Container Map.empty) + -- ts + <*> arbitrary <*> arbitrary + -- uuid + <*> arbitrary + -- serial + <*> arbitrary + -- tags + <*> (Set.fromList <$> genTags) + +$(genArbitrary ''AllocPolicy) +$(genArbitrary ''FilledISpecParams) +$(genArbitrary ''FilledIPolicy) +$(genArbitrary ''IpFamily) +$(genArbitrary ''FilledNDParams) +$(genArbitrary ''FilledNicParams) +$(genArbitrary ''FilledBeParams) + +-- | No real arbitrary instance for 'ClusterHvParams' yet. +instance Arbitrary ClusterHvParams where + arbitrary = return $ Container Map.empty + +-- | No real arbitrary instance for 'OsHvParams' yet. +instance Arbitrary OsHvParams where + arbitrary = return $ Container Map.empty + +instance Arbitrary ClusterNicParams where + arbitrary = (Container . Map.singleton C.ppDefault) <$> arbitrary + +instance Arbitrary OsParams where + arbitrary = (Container . Map.fromList) <$> arbitrary + +instance Arbitrary ClusterOsParams where + arbitrary = (Container . Map.fromList) <$> arbitrary + +instance Arbitrary ClusterBeParams where + arbitrary = (Container . Map.fromList) <$> arbitrary + +instance Arbitrary TagSet where + arbitrary = Set.fromList <$> genTags + +$(genArbitrary ''Cluster) + +-- | Generator for config data with an empty cluster (no instances), +-- with N defined nodes. +genEmptyCluster :: Int -> Gen ConfigData +genEmptyCluster ncount = do + nodes <- vector ncount + version <- arbitrary + let guuid = "00" + nodes' = map (\n -> n { nodeGroup = guuid }) nodes + contnodes = Container . Map.fromList $ map (\n -> (nodeName n, n)) nodes' + continsts = Container $ Map.empty + grp <- arbitrary + let contgroups = Container $ Map.singleton guuid grp + serial <- arbitrary + cluster <- arbitrary + let c = ConfigData version cluster contnodes contgroups continsts serial + return c + -- * Test properties -- | Tests that fillDict behaves correctly @@ -144,9 +220,18 @@ prop_Node_serialisation = testSerialisation prop_Inst_serialisation :: Instance -> Property prop_Inst_serialisation = testSerialisation +-- | Check config serialisation. +prop_Config_serialisation :: Property +prop_Config_serialisation = + forAll (choose (0, maxNodes) >>= genEmptyCluster) testSerialisation + testSuite "Objects" [ 'prop_fillDict , 'prop_Disk_serialisation , 'prop_Inst_serialisation , 'prop_Node_serialisation ] + +testSuite "SlowObjects" + [ 'prop_Config_serialisation + ] diff --git a/htest/test.hs b/htest/test.hs index 899db7ed8066280550a5a5c77f0ea9199822fa25..c9f62f315b8140c90329dd86d48c0e2eae2b01c3 100644 --- a/htest/test.hs +++ b/htest/test.hs @@ -95,6 +95,7 @@ allTests = , (True, testRpc) , (True, testSsconf) , (False, testHTools_Cluster) + , (False, testSlowObjects) ] -- | Slow a test's max tests, if provided as such. diff --git a/htools/Ganeti/Objects.hs b/htools/Ganeti/Objects.hs index 5fddf64b4f0dd7c666cc588f0a659c877c68eac9..9aa14986e00b667b4e7ce8f14a81e450a14e9d8f 100644 --- a/htools/Ganeti/Objects.hs +++ b/htools/Ganeti/Objects.hs @@ -88,6 +88,7 @@ module Ganeti.Objects , SerialNoObject(..) , TagsObject(..) , DictObject(..) -- re-exported from THH + , TagSet -- re-exported from THH ) where import Data.List (foldl') diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs index 49d1aa1da1077edb06ff9bf42fb16a7ac9f83cc1..95d93fe93b637520a3c3a1fab4c7703533da89d5 100644 --- a/htools/Ganeti/THH.hs +++ b/htools/Ganeti/THH.hs @@ -48,6 +48,7 @@ module Ganeti.THH ( declareSADT , uuidFields , serialFields , tagsFields + , TagSet , buildObject , buildObjectSerialisation , buildParam @@ -171,10 +172,13 @@ serialFields = uuidFields :: [Field] uuidFields = [ simpleField "uuid" [t| String |] ] +-- | Tag set type alias. +type TagSet = Set.Set String + -- | Tag field description. tagsFields :: [Field] tagsFields = [ defaultField [| Set.empty |] $ - simpleField "tags" [t| Set.Set String |] ] + simpleField "tags" [t| TagSet |] ] -- * Helper functions