code.grnet.gr Git - ganeti-local/blob - test/hs/Test/Ganeti/TestCommon.hs

   1 {-| Unittest helpers for ganeti-htools.
   2
   3 -}
   4
   5 {-
   6
   7 Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
   8
   9 This program is free software; you can redistribute it and/or modify
  10 it under the terms of the GNU General Public License as published by
  11 the Free Software Foundation; either version 2 of the License, or
  12 (at your option) any later version.
  13
  14 This program is distributed in the hope that it will be useful, but
  15 WITHOUT ANY WARRANTY; without even the implied warranty of
  16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 General Public License for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with this program; if not, write to the Free Software
  21 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  22 02110-1301, USA.
  23
  24 -}
  25
  26 module Test.Ganeti.TestCommon
  27   ( maxMem
  28   , maxDsk
  29   , maxCpu
  30   , maxSpindles
  31   , maxVcpuRatio
  32   , maxSpindleRatio
  33   , maxNodes
  34   , maxOpCodes
  35   , (==?)
  36   , (/=?)
  37   , failTest
  38   , passTest
  39   , pythonCmd
  40   , runPython
  41   , checkPythonResult
  42   , DNSChar(..)
  43   , genName
  44   , genFQDN
  45   , genUUID
  46   , genMaybe
  47   , genTags
  48   , genFields
  49   , genUniquesList
  50   , SmallRatio(..)
  51   , genSetHelper
  52   , genSet
  53   , genListSet
  54   , genIPv4Address
  55   , genIPv4Network
  56   , genIp6Addr
  57   , genIp6Net
  58   , genOpCodesTagName
  59   , genLuxiTagName
  60   , netmask2NumHosts
  61   , testSerialisation
  62   , resultProp
  63   , readTestData
  64   , genSample
  65   , testParser
  66   , genPropParser
  67   , genNonNegative
  68   , relativeError
  69   ) where
  70
  71 import Control.Applicative
  72 import Control.Exception (catchJust)
  73 import Control.Monad
  74 import Data.Attoparsec.Text (Parser, parseOnly)
  75 import Data.List
  76 import Data.Text (pack)
  77 import Data.Word
  78 import qualified Data.Set as Set
  79 import System.Environment (getEnv)
  80 import System.Exit (ExitCode(..))
  81 import System.IO.Error (isDoesNotExistError)
  82 import System.Process (readProcessWithExitCode)
  83 import qualified Test.HUnit as HUnit
  84 import Test.QuickCheck
  85 import Test.QuickCheck.Monadic
  86 import qualified Text.JSON as J
  87 import Numeric
  88
  89 import qualified Ganeti.BasicTypes as BasicTypes
  90 import Ganeti.Types
  91
  92 -- * Constants
  93
  94 -- | Maximum memory (1TiB, somewhat random value).
  95 maxMem :: Int
  96 maxMem = 1024 * 1024
  97
  98 -- | Maximum disk (8TiB, somewhat random value).
  99 maxDsk :: Int
 100 maxDsk = 1024 * 1024 * 8
 101
 102 -- | Max CPUs (1024, somewhat random value).
 103 maxCpu :: Int
 104 maxCpu = 1024
 105
 106 -- | Max spindles (1024, somewhat random value).
 107 maxSpindles :: Int
 108 maxSpindles = 1024
 109
 110 -- | Max vcpu ratio (random value).
 111 maxVcpuRatio :: Double
 112 maxVcpuRatio = 1024.0
 113
 114 -- | Max spindle ratio (random value).
 115 maxSpindleRatio :: Double
 116 maxSpindleRatio = 1024.0
 117
 118 -- | Max nodes, used just to limit arbitrary instances for smaller
 119 -- opcode definitions (e.g. list of nodes in OpTestDelay).
 120 maxNodes :: Int
 121 maxNodes = 32
 122
 123 -- | Max opcodes or jobs in a submit job and submit many jobs.
 124 maxOpCodes :: Int
 125 maxOpCodes = 16
 126
 127 -- * Helper functions
 128
 129 -- | Checks for equality with proper annotation. The first argument is
 130 -- the computed value, the second one the expected value.
 131 (==?) :: (Show a, Eq a) => a -> a -> Property
 132 (==?) x y = printTestCase
 133             ("Expected equality, but got mismatch\nexpected: " ++
 134              show y ++ "\n but got: " ++ show x) (x == y)
 135 infix 3 ==?
 136
 137 -- | Checks for inequality with proper annotation. The first argument
 138 -- is the computed value, the second one the expected (not equal)
 139 -- value.
 140 (/=?) :: (Show a, Eq a) => a -> a -> Property
 141 (/=?) x y = printTestCase
 142             ("Expected inequality, but got equality: '" ++
 143              show x ++ "'.") (x /= y)
 144 infix 3 /=?
 145
 146 -- | Show a message and fail the test.
 147 failTest :: String -> Property
 148 failTest msg = printTestCase msg False
 149
 150 -- | A 'True' property.
 151 passTest :: Property
 152 passTest = property True
 153
 154 -- | Return the python binary to use. If the PYTHON environment
 155 -- variable is defined, use its value, otherwise use just \"python\".
 156 pythonCmd :: IO String
 157 pythonCmd = catchJust (guard . isDoesNotExistError)
 158             (getEnv "PYTHON") (const (return "python"))
 159
 160 -- | Run Python with an expression, returning the exit code, standard
 161 -- output and error.
 162 runPython :: String -> String -> IO (ExitCode, String, String)
 163 runPython expr stdin = do
 164   py_binary <- pythonCmd
 165   readProcessWithExitCode py_binary ["-c", expr] stdin
 166
 167 -- | Check python exit code, and fail via HUnit assertions if
 168 -- non-zero. Otherwise, return the standard output.
 169 checkPythonResult :: (ExitCode, String, String) -> IO String
 170 checkPythonResult (py_code, py_stdout, py_stderr) = do
 171   HUnit.assertEqual ("python exited with error: " ++ py_stderr)
 172        ExitSuccess py_code
 173   return py_stdout
 174
 175 -- * Arbitrary instances
 176
 177 -- | Defines a DNS name.
 178 newtype DNSChar = DNSChar { dnsGetChar::Char }
 179
 180 instance Arbitrary DNSChar where
 181   arbitrary = liftM DNSChar $ elements (['a'..'z'] ++ ['0'..'9'] ++ "_-")
 182
 183 instance Show DNSChar where
 184   show = show . dnsGetChar
 185
 186 -- | Generates a single name component.
 187 genName :: Gen String
 188 genName = do
 189   n <- choose (1, 16)
 190   dn <- vector n
 191   return (map dnsGetChar dn)
 192
 193 -- | Generates an entire FQDN.
 194 genFQDN :: Gen String
 195 genFQDN = do
 196   ncomps <- choose (1, 4)
 197   names <- vectorOf ncomps genName
 198   return $ intercalate "." names
 199
 200 -- | Generates a UUID-like string.
 201 --
 202 -- Only to be used for QuickCheck testing. For obtaining actual UUIDs use
 203 -- the newUUID function in Ganeti.Utils
 204 genUUID :: Gen String
 205 genUUID = do
 206   c1 <- vector 6
 207   c2 <- vector 4
 208   c3 <- vector 4
 209   c4 <- vector 4
 210   c5 <- vector 4
 211   c6 <- vector 4
 212   c7 <- vector 6
 213   return $ map dnsGetChar c1 ++ "-" ++ map dnsGetChar c2 ++ "-" ++
 214     map dnsGetChar c3 ++ "-" ++ map dnsGetChar c4 ++ "-" ++
 215     map dnsGetChar c5 ++ "-" ++ map dnsGetChar c6 ++ "-" ++
 216     map dnsGetChar c7
 217
 218 -- | Combinator that generates a 'Maybe' using a sub-combinator.
 219 genMaybe :: Gen a -> Gen (Maybe a)
 220 genMaybe subgen = frequency [ (1, pure Nothing), (3, Just <$> subgen) ]
 221
 222 -- | Defines a tag type.
 223 newtype TagChar = TagChar { tagGetChar :: Char }
 224
 225 -- | All valid tag chars. This doesn't need to match _exactly_
 226 -- Ganeti's own tag regex, just enough for it to be close.
 227 tagChar :: String
 228 tagChar = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ".+*/:@-"
 229
 230 instance Arbitrary TagChar where
 231   arbitrary = liftM TagChar $ elements tagChar
 232
 233 -- | Generates a tag
 234 genTag :: Gen [TagChar]
 235 genTag = do
 236   -- the correct value would be C.maxTagLen, but that's way too
 237   -- verbose in unittests, and at the moment I don't see any possible
 238   -- bugs with longer tags and the way we use tags in htools
 239   n <- choose (1, 10)
 240   vector n
 241
 242 -- | Generates a list of tags (correctly upper bounded).
 243 genTags :: Gen [String]
 244 genTags = do
 245   -- the correct value would be C.maxTagsPerObj, but per the comment
 246   -- in genTag, we don't use tags enough in htools to warrant testing
 247   -- such big values
 248   n <- choose (0, 10::Int)
 249   tags <- mapM (const genTag) [1..n]
 250   return $ map (map tagGetChar) tags
 251
 252 -- | Generates a fields list. This uses the same character set as a
 253 -- DNS name (just for simplicity).
 254 genFields :: Gen [String]
 255 genFields = do
 256   n <- choose (1, 32)
 257   vectorOf n genName
 258
 259 -- | Generates a list of a given size with non-duplicate elements.
 260 genUniquesList :: (Eq a, Arbitrary a, Ord a) => Int -> Gen a -> Gen [a]
 261 genUniquesList cnt generator = do
 262   set <- foldM (\set _ -> do
 263                   newelem <- generator `suchThat` (`Set.notMember` set)
 264                   return (Set.insert newelem set)) Set.empty [1..cnt]
 265   return $ Set.toList set
 266
 267 newtype SmallRatio = SmallRatio Double deriving Show
 268 instance Arbitrary SmallRatio where
 269   arbitrary = liftM SmallRatio $ choose (0, 1)
 270
 271 -- | Helper for 'genSet', declared separately due to type constraints.
 272 genSetHelper :: (Ord a) => [a] -> Maybe Int -> Gen (Set.Set a)
 273 genSetHelper candidates size = do
 274   size' <- case size of
 275              Nothing -> choose (0, length candidates)
 276              Just s | s > length candidates ->
 277                         error $ "Invalid size " ++ show s ++ ", maximum is " ++
 278                                 show (length candidates)
 279                     | otherwise -> return s
 280   foldM (\set _ -> do
 281            newelem <- elements candidates `suchThat` (`Set.notMember` set)
 282            return (Set.insert newelem set)) Set.empty [1..size']
 283
 284 -- | Generates a 'Set' of arbitrary elements.
 285 genSet :: (Ord a, Bounded a, Enum a) => Maybe Int -> Gen (Set.Set a)
 286 genSet = genSetHelper [minBound..maxBound]
 287
 288 -- | Generates a 'Set' of arbitrary elements wrapped in a 'ListSet'
 289 genListSet :: (Ord a, Bounded a, Enum a) => Maybe Int
 290               -> Gen (BasicTypes.ListSet a)
 291 genListSet is = BasicTypes.ListSet <$> genSet is
 292
 293 -- | Generate an arbitrary IPv4 address in textual form.
 294 genIPv4 :: Gen String
 295 genIPv4 = do
 296   a <- choose (1::Int, 255)
 297   b <- choose (0::Int, 255)
 298   c <- choose (0::Int, 255)
 299   d <- choose (0::Int, 255)
 300   return . intercalate "." $ map show [a, b, c, d]
 301
 302 genIPv4Address :: Gen IPv4Address
 303 genIPv4Address = mkIPv4Address =<< genIPv4
 304
 305 -- | Generate an arbitrary IPv4 network in textual form.
 306 genIPv4AddrRange :: Gen String
 307 genIPv4AddrRange = do
 308   ip <- genIPv4
 309   netmask <- choose (8::Int, 30)
 310   return $ ip ++ "/" ++ show netmask
 311
 312 genIPv4Network :: Gen IPv4Network
 313 genIPv4Network = mkIPv4Network =<< genIPv4AddrRange
 314
 315 -- | Helper function to compute the number of hosts in a network
 316 -- given the netmask. (For IPv4 only.)
 317 netmask2NumHosts :: Word8 -> Int
 318 netmask2NumHosts n = 2^(32-n)
 319
 320 -- | Generates an arbitrary IPv6 network address in textual form.
 321 -- The generated address is not simpflified, e. g. an address like
 322 -- "2607:f0d0:1002:0051:0000:0000:0000:0004" does not become
 323 -- "2607:f0d0:1002:51::4"
 324 genIp6Addr :: Gen String
 325 genIp6Addr = do
 326   rawIp <- vectorOf 8 $ choose (0::Integer, 65535)
 327   return $ intercalate ":" (map (`showHex` "") rawIp)
 328
 329 -- | Generates an arbitrary IPv6 network in textual form.
 330 genIp6Net :: Gen String
 331 genIp6Net = do
 332   netmask <- choose (8::Int, 126)
 333   ip <- genIp6Addr
 334   return $ ip ++ "/" ++ show netmask
 335
 336 -- | Generates a valid, arbitrary tag name with respect to the given
 337 -- 'TagKind' for opcodes.
 338 genOpCodesTagName :: TagKind -> Gen (Maybe String)
 339 genOpCodesTagName TagKindCluster = return Nothing
 340 genOpCodesTagName _ = Just <$> genFQDN
 341
 342 -- | Generates a valid, arbitrary tag name with respect to the given
 343 -- 'TagKind' for Luxi.
 344 genLuxiTagName :: TagKind -> Gen String
 345 genLuxiTagName TagKindCluster = return ""
 346 genLuxiTagName _ = genFQDN
 347
 348 -- * Helper functions
 349
 350 -- | Checks for serialisation idempotence.
 351 testSerialisation :: (Eq a, Show a, J.JSON a) => a -> Property
 352 testSerialisation a =
 353   case J.readJSON (J.showJSON a) of
 354     J.Error msg -> failTest $ "Failed to deserialise: " ++ msg
 355     J.Ok a' -> a ==? a'
 356
 357 -- | Result to PropertyM IO.
 358 resultProp :: (Show a) => BasicTypes.GenericResult a b -> PropertyM IO b
 359 resultProp (BasicTypes.Bad err) = stop . failTest $ show err
 360 resultProp (BasicTypes.Ok  val) = return val
 361
 362 -- | Return the source directory of Ganeti.
 363 getSourceDir :: IO FilePath
 364 getSourceDir = catchJust (guard . isDoesNotExistError)
 365             (getEnv "TOP_SRCDIR")
 366             (const (return "."))
 367
 368 -- | Returns the path of a file in the test data directory, given its name.
 369 testDataFilename :: String -> String -> IO FilePath
 370 testDataFilename datadir name = do
 371         src <- getSourceDir
 372         return $ src ++ datadir ++ name
 373
 374 -- | Returns the content of the specified haskell test data file.
 375 readTestData :: String -> IO String
 376 readTestData filename = do
 377     name <- testDataFilename "/test/data/" filename
 378     readFile name
 379
 380 -- | Generate arbitrary values in the IO monad. This is a simple
 381 -- wrapper over 'sample''.
 382 genSample :: Gen a -> IO a
 383 genSample gen = do
 384   values <- sample' gen
 385   case values of
 386     [] -> error "sample' returned an empty list of values??"
 387     x:_ -> return x
 388
 389 -- | Function for testing whether a file is parsed correctly.
 390 testParser :: (Show a, Eq a) => Parser a -> String -> a -> HUnit.Assertion
 391 testParser parser fileName expectedContent = do
 392   fileContent <- readTestData fileName
 393   case parseOnly parser $ pack fileContent of
 394     Left msg -> HUnit.assertFailure $ "Parsing failed: " ++ msg
 395     Right obtained -> HUnit.assertEqual fileName expectedContent obtained
 396
 397 -- | Generate a property test for parsers.
 398 genPropParser :: (Show a, Eq a) => Parser a -> String -> a -> Property
 399 genPropParser parser s expected =
 400   case parseOnly parser $ pack s of
 401     Left msg -> failTest $ "Parsing failed: " ++ msg
 402     Right obtained -> expected ==? obtained
 403
 404 -- | Generate an arbitrary non negative integer number
 405 genNonNegative :: Gen Int
 406 genNonNegative =
 407   fmap fromIntegral (arbitrary::Gen (Test.QuickCheck.NonNegative Int))
 408
 409 -- | Computes the relative error of two 'Double' numbers.
 410 --
 411 -- This is the \"relative error\" algorithm in
 412 -- http:\/\/randomascii.wordpress.com\/2012\/02\/25\/
 413 -- comparing-floating-point-numbers-2012-edition (URL split due to too
 414 -- long line).
 415 relativeError :: Double -> Double -> Double
 416 relativeError d1 d2 =
 417   let delta = abs $ d1 - d2
 418       a1 = abs d1
 419       a2 = abs d2
 420       greatest = max a1 a2
 421   in if delta == 0
 422        then 0
 423        else delta / greatest