test/hs/Test/Ganeti/Query/Language.hs

{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

{-| Unittests for ganeti-htools.

-}

{-

Copyright (C) 2009, 2010, 2011, 2012 Google Inc.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.

-}

module Test.Ganeti.Query.Language
  ( testQuery_Language
  , genFilter
  , genJSValue
  ) where

import Test.QuickCheck

import Control.Applicative
import Control.Arrow (second)
import Text.JSON

import Test.Ganeti.TestHelper
import Test.Ganeti.TestCommon

import Ganeti.Query.Language

-- | Custom 'Filter' generator (top-level), which enforces a
-- (sane) limit on the depth of the generated filters.
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 (Filter FilterField)
genFilter' 0 =
  oneof [ pure EmptyFilter
        , TrueFilter     <$> genName
        , EQFilter       <$> genName <*> value
        , LTFilter       <$> genName <*> value
        , GTFilter       <$> genName <*> value
        , LEFilter       <$> genName <*> value
        , GEFilter       <$> genName <*> value
        , RegexpFilter   <$> genName <*> arbitrary
        , ContainsFilter <$> genName <*> value
        ]
    where value = oneof [ QuotedString <$> genName
                        , NumericValue <$> arbitrary
                        ]
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 ''QueryTypeOp)

$(genArbitrary ''QueryTypeLuxi)

$(genArbitrary ''ItemType)

instance Arbitrary FilterRegex where
  arbitrary = genName >>= 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 =
  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_filter_serialisation :: Property
prop_filter_serialisation = forAll genFilter testSerialisation

-- | Tests that filter regexes are serialised correctly.
prop_filterregex_instances :: FilterRegex -> Property
prop_filterregex_instances rex =
  printTestCase "failed JSON encoding" (testSerialisation 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

-- | Tests 'ItemType' serialisation.
prop_itemtype_serialisation :: ItemType -> Property
prop_itemtype_serialisation = testSerialisation

testSuite "Query/Language"
  [ 'prop_filter_serialisation
  , 'prop_filterregex_instances
  , 'prop_resultstatus_serialisation
  , 'prop_fieldtype_serialisation
  , 'prop_fielddef_serialisation
  , 'prop_resultentry_serialisation
  , 'prop_fieldsresult_serialisation
  , 'prop_itemtype_serialisation
  ]