code.grnet.gr Git - ganeti-local/blob - htest/Test/Ganeti/Query/Language.hs

   1 {-# LANGUAGE TemplateHaskell #-}
   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.Query.Language
  30   ( testQuery_Language
  31   , genFilter
  32   ) where
  33
  34 import Test.QuickCheck
  35
  36 import Control.Applicative
  37 import Control.Arrow (second)
  38 import Text.JSON
  39
  40 import Test.Ganeti.TestHelper
  41 import Test.Ganeti.TestCommon
  42
  43 import Ganeti.Query.Language
  44
  45 -- | Custom 'Filter' generator (top-level), which enforces a
  46 -- (sane) limit on the depth of the generated filters.
  47 genFilter :: Gen (Filter FilterField)
  48 genFilter = choose (0, 10) >>= genFilter'
  49
  50 -- | Custom generator for filters that correctly halves the state of
  51 -- the generators at each recursive step, per the QuickCheck
  52 -- documentation, in order not to run out of memory.
  53 genFilter' :: Int -> Gen (Filter FilterField)
  54 genFilter' 0 =
  55   oneof [ pure EmptyFilter
  56         , TrueFilter     <$> getName
  57         , EQFilter       <$> getName <*> value
  58         , LTFilter       <$> getName <*> value
  59         , GTFilter       <$> getName <*> value
  60         , LEFilter       <$> getName <*> value
  61         , GEFilter       <$> getName <*> value
  62         , RegexpFilter   <$> getName <*> arbitrary
  63         , ContainsFilter <$> getName <*> value
  64         ]
  65     where value = oneof [ QuotedString <$> getName
  66                         , NumericValue <$> arbitrary
  67                         ]
  68 genFilter' n =
  69   oneof [ AndFilter  <$> vectorOf n'' (genFilter' n')
  70         , OrFilter   <$> vectorOf n'' (genFilter' n')
  71         , NotFilter  <$> genFilter' n'
  72         ]
  73   where n' = n `div` 2 -- sub-filter generator size
  74         n'' = max n' 2 -- but we don't want empty or 1-element lists,
  75                        -- so use this for and/or filter list length
  76
  77 $(genArbitrary ''ItemType)
  78
  79 instance Arbitrary FilterRegex where
  80   arbitrary = getName >>= mkRegex -- a name should be a good regex
  81
  82 $(genArbitrary ''ResultStatus)
  83
  84 $(genArbitrary ''FieldType)
  85
  86 $(genArbitrary ''FieldDefinition)
  87
  88 -- | Generates an arbitrary JSValue. We do this via a function a not
  89 -- via arbitrary instance since that would require us to define an
  90 -- arbitrary for JSValue, which can be recursive, entering the usual
  91 -- problems with that; so we only generate the base types, not the
  92 -- recursive ones, and not 'JSNull', which we can't use in a
  93 -- 'RSNormal' 'ResultEntry'.
  94 genJSValue :: Gen JSValue
  95 genJSValue =
  96   oneof [ JSBool <$> arbitrary
  97         , JSRational <$> pure False <*> arbitrary
  98         , JSString <$> (toJSString <$> arbitrary)
  99         , (JSArray . map showJSON) <$> (arbitrary::Gen [Int])
 100         , JSObject . toJSObject . map (second showJSON) <$>
 101           (arbitrary::Gen [(String, Int)])
 102         ]
 103
 104 -- | Generates a 'ResultEntry' value.
 105 genResultEntry :: Gen ResultEntry
 106 genResultEntry = do
 107   rs <- arbitrary
 108   rv <- case rs of
 109           RSNormal -> Just <$> genJSValue
 110           _ -> pure Nothing
 111   return $ ResultEntry rs rv
 112
 113 $(genArbitrary ''QueryFieldsResult)
 114
 115 -- | Tests that serialisation/deserialisation of filters is
 116 -- idempotent.
 117 prop_filter_serialisation :: Property
 118 prop_filter_serialisation = forAll genFilter testSerialisation
 119
 120 -- | Tests that filter regexes are serialised correctly.
 121 prop_filterregex_instances :: FilterRegex -> Property
 122 prop_filterregex_instances rex =
 123   printTestCase "failed JSON encoding" (testSerialisation rex) .&&.
 124   printTestCase "failed read/show instances" (read (show rex) ==? rex)
 125
 126 -- | Tests 'ResultStatus' serialisation.
 127 prop_resultstatus_serialisation :: ResultStatus -> Property
 128 prop_resultstatus_serialisation = testSerialisation
 129
 130 -- | Tests 'FieldType' serialisation.
 131 prop_fieldtype_serialisation :: FieldType -> Property
 132 prop_fieldtype_serialisation = testSerialisation
 133
 134 -- | Tests 'FieldDef' serialisation.
 135 prop_fielddef_serialisation :: FieldDefinition -> Property
 136 prop_fielddef_serialisation = testSerialisation
 137
 138 -- | Tests 'ResultEntry' serialisation. Needed especially as this is
 139 -- done manually, and not via buildObject (different serialisation
 140 -- format).
 141 prop_resultentry_serialisation :: Property
 142 prop_resultentry_serialisation = forAll genResultEntry testSerialisation
 143
 144 -- | Tests 'FieldDef' serialisation. We use a made-up maximum limit of
 145 -- 20 for the generator, since otherwise the lists become too long and
 146 -- we don't care so much about list length but rather structure.
 147 prop_fieldsresult_serialisation :: Property
 148 prop_fieldsresult_serialisation =
 149   forAll (resize 20 arbitrary::Gen QueryFieldsResult) testSerialisation
 150
 151 testSuite "Query/Language"
 152   [ 'prop_filter_serialisation
 153   , 'prop_filterregex_instances
 154   , 'prop_resultstatus_serialisation
 155   , 'prop_fieldtype_serialisation
 156   , 'prop_fielddef_serialisation
 157   , 'prop_resultentry_serialisation
 158   , 'prop_fieldsresult_serialisation
 159   ]