diff --git a/htest/Test/Ganeti/Query/Language.hs b/htest/Test/Ganeti/Query/Language.hs index c38fe5ee08ff3c1013a8f79e8d743c6031af6840..ce5e95c02d82b8cc56be1f7ab84e3775b04519c5 100644 --- a/htest/Test/Ganeti/Query/Language.hs +++ b/htest/Test/Ganeti/Query/Language.hs @@ -34,60 +34,126 @@ module Test.Ganeti.Query.Language import Test.QuickCheck import Control.Applicative +import Control.Arrow (second) +import Text.JSON import Test.Ganeti.TestHelper import Test.Ganeti.TestCommon -import qualified Ganeti.Query.Language as Qlang +import Ganeti.Query.Language --- | Custom 'Qlang.Filter' generator (top-level), which enforces a +-- | Custom 'Filter' generator (top-level), which enforces a -- (sane) limit on the depth of the generated filters. -genFilter :: Gen (Qlang.Filter Qlang.FilterField) +genFilter :: Gen (Filter FilterField) genFilter = choose (0, 10) >>= genFilter' -- | Custom generator for filters that correctly halves the state of -- the generators at each recursive step, per the QuickCheck -- documentation, in order not to run out of memory. -genFilter' :: Int -> Gen (Qlang.Filter Qlang.FilterField) +genFilter' :: Int -> Gen (Filter FilterField) genFilter' 0 = - oneof [ return Qlang.EmptyFilter - , Qlang.TrueFilter <$> getName - , Qlang.EQFilter <$> getName <*> value - , Qlang.LTFilter <$> getName <*> value - , Qlang.GTFilter <$> getName <*> value - , Qlang.LEFilter <$> getName <*> value - , Qlang.GEFilter <$> getName <*> value - , Qlang.RegexpFilter <$> getName <*> arbitrary - , Qlang.ContainsFilter <$> getName <*> value + oneof [ pure EmptyFilter + , TrueFilter <$> getName + , EQFilter <$> getName <*> value + , LTFilter <$> getName <*> value + , GTFilter <$> getName <*> value + , LEFilter <$> getName <*> value + , GEFilter <$> getName <*> value + , RegexpFilter <$> getName <*> arbitrary + , ContainsFilter <$> getName <*> value ] - where value = oneof [ Qlang.QuotedString <$> getName - , Qlang.NumericValue <$> arbitrary + where value = oneof [ QuotedString <$> getName + , NumericValue <$> arbitrary ] genFilter' n = do - oneof [ Qlang.AndFilter <$> vectorOf n'' (genFilter' n') - , Qlang.OrFilter <$> vectorOf n'' (genFilter' n') - , Qlang.NotFilter <$> genFilter' n' + oneof [ AndFilter <$> vectorOf n'' (genFilter' n') + , OrFilter <$> vectorOf n'' (genFilter' n') + , NotFilter <$> genFilter' n' ] where n' = n `div` 2 -- sub-filter generator size n'' = max n' 2 -- but we don't want empty or 1-element lists, -- so use this for and/or filter list length -$(genArbitrary ''Qlang.ItemType) +$(genArbitrary ''ItemType) -instance Arbitrary Qlang.FilterRegex where - arbitrary = getName >>= Qlang.mkRegex -- a name should be a good regex +instance Arbitrary FilterRegex where + arbitrary = getName >>= mkRegex -- a name should be a good regex + +$(genArbitrary ''ResultStatus) + +$(genArbitrary ''FieldType) + +$(genArbitrary ''FieldDefinition) + +-- | Generates an arbitrary JSValue. We do this via a function a not +-- via arbitrary instance since that would require us to define an +-- arbitrary for JSValue, which can be recursive, entering the usual +-- problems with that; so we only generate the base types, not the +-- recursive ones, and not 'JSNull', which we can't use in a +-- 'RSNormal' 'ResultEntry'. +genJSValue :: Gen JSValue +genJSValue = do + oneof [ JSBool <$> arbitrary + , JSRational <$> pure False <*> arbitrary + , JSString <$> (toJSString <$> arbitrary) + , (JSArray . map showJSON) <$> (arbitrary::Gen [Int]) + , JSObject . toJSObject . map (second showJSON) <$> + (arbitrary::Gen [(String, Int)]) + ] + +-- | Generates a 'ResultEntry' value. +genResultEntry :: Gen ResultEntry +genResultEntry = do + rs <- arbitrary + rv <- case rs of + RSNormal -> Just <$> genJSValue + _ -> pure Nothing + return $ ResultEntry rs rv + +$(genArbitrary ''QueryFieldsResult) -- | Tests that serialisation/deserialisation of filters is -- idempotent. -prop_Serialisation :: Property -prop_Serialisation = forAll genFilter testSerialisation +prop_filter_serialisation :: Property +prop_filter_serialisation = forAll genFilter testSerialisation -prop_FilterRegex_instances :: Qlang.FilterRegex -> Property -prop_FilterRegex_instances rex = +-- | Tests that filter regexes are serialised correctly. +prop_filterregex_instances :: FilterRegex -> Property +prop_filterregex_instances rex = printTestCase "failed JSON encoding" (testSerialisation rex) .&&. printTestCase "failed read/show instances" (read (show rex) ==? rex) +-- | Tests 'ResultStatus' serialisation. +prop_resultstatus_serialisation :: ResultStatus -> Property +prop_resultstatus_serialisation = testSerialisation + +-- | Tests 'FieldType' serialisation. +prop_fieldtype_serialisation :: FieldType -> Property +prop_fieldtype_serialisation = testSerialisation + +-- | Tests 'FieldDef' serialisation. +prop_fielddef_serialisation :: FieldDefinition -> Property +prop_fielddef_serialisation = testSerialisation + +-- | Tests 'ResultEntry' serialisation. Needed especially as this is +-- done manually, and not via buildObject (different serialisation +-- format). +prop_resultentry_serialisation :: Property +prop_resultentry_serialisation = forAll genResultEntry testSerialisation + +-- | Tests 'FieldDef' serialisation. We use a made-up maximum limit of +-- 20 for the generator, since otherwise the lists become too long and +-- we don't care so much about list length but rather structure. +prop_fieldsresult_serialisation :: Property +prop_fieldsresult_serialisation = + forAll (resize 20 arbitrary::Gen QueryFieldsResult) testSerialisation + testSuite "Query/Language" - [ 'prop_Serialisation - , 'prop_FilterRegex_instances + [ 'prop_filter_serialisation + , 'prop_filterregex_instances + , 'prop_resultstatus_serialisation + , 'prop_fieldtype_serialisation + , 'prop_fielddef_serialisation + , 'prop_resultentry_serialisation + , 'prop_fieldsresult_serialisation ] diff --git a/htools/Ganeti/Query/Language.hs b/htools/Ganeti/Query/Language.hs index 31b0a1b184679c07cc49dd1ec212b39569164e71..a702af6a7a095f8e6df9522f66e2d86980e3b10d 100644 --- a/htools/Ganeti/Query/Language.hs +++ b/htools/Ganeti/Query/Language.hs @@ -348,7 +348,7 @@ instance JSON ResultEntry where (rs, rv) <- readJSON v rv' <- case rv of JSNull -> return Nothing - x -> readJSON x + x -> Just <$> readJSON x return $ ResultEntry rs rv' -- | The type of one result row.