code.grnet.gr Git - ganeti-local/blob - test/hs/Test/Ganeti/Hypervisor/Xen/XmParser.hs

   1 {-# LANGUAGE TemplateHaskell #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3
   4 {-| Unittests for @xm list --long@ parser -}
   5
   6 {-
   7
   8 Copyright (C) 2013 Google Inc.
   9
  10 This program is free software; you can redistribute it and/or modify
  11 it under the terms of the GNU General Public License as published by
  12 the Free Software Foundation; either version 2 of the License, or
  13 (at your option) any later version.
  14
  15 This program is distributed in the hope that it will be useful, but
  16 WITHOUT ANY WARRANTY; without even the implied warranty of
  17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 General Public License for more details.
  19
  20 You should have received a copy of the GNU General Public License
  21 along with this program; if not, write to the Free Software
  22 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  23 02110-1301, USA.
  24
  25 -}
  26
  27 module Test.Ganeti.Hypervisor.Xen.XmParser
  28   ( testHypervisor_Xen_XmParser
  29   ) where
  30
  31 import Test.HUnit
  32 import Test.QuickCheck as QuickCheck hiding (Result)
  33
  34 import Test.Ganeti.TestHelper
  35 import Test.Ganeti.TestCommon
  36
  37 import Control.Monad (liftM)
  38 import qualified Data.Attoparsec.Text as A
  39 import Data.Text (pack)
  40 import Data.Char
  41 import qualified Data.Map as Map
  42 import Text.Printf
  43
  44 import Ganeti.Hypervisor.Xen.Types
  45 import Ganeti.Hypervisor.Xen.XmParser
  46
  47 {-# ANN module "HLint: ignore Use camelCase" #-}
  48
  49 -- * Arbitraries
  50
  51 -- | Generator for 'ListConfig'.
  52 --
  53 -- A completely arbitrary configuration would contain too many lists
  54 -- and its size would be to big to be actually parsable in reasonable
  55 -- time. This generator builds a random Config that is still of a
  56 -- reasonable size, and it also Avoids generating strings that might
  57 -- be interpreted as numbers.
  58 genConfig :: Int -> Gen LispConfig
  59 genConfig 0 =
  60   -- only terminal values for size 0
  61   frequency [ (5, liftM LCString (genName `suchThat` (not . canBeNumber)))
  62             , (5, liftM LCDouble arbitrary)
  63             ]
  64 genConfig n =
  65   -- for size greater than 0, allow "some" lists
  66   frequency [ (5, liftM LCString (resize n genName `suchThat`
  67                                   (not . canBeNumber)))
  68             , (5, liftM LCDouble arbitrary)
  69             , (1, liftM LCList (choose (1, n) >>=
  70                                 (\n' -> vectorOf n' (genConfig $ n `div` n'))))
  71             ]
  72
  73 -- | Arbitrary instance for 'LispConfig' using 'genConfig'.
  74 instance Arbitrary LispConfig where
  75   arbitrary = sized genConfig
  76
  77 -- | Determines conservatively whether a string could be a number.
  78 canBeNumber :: String -> Bool
  79 canBeNumber [] = False
  80 canBeNumber (c:[]) = canBeNumberChar c
  81 canBeNumber (c:xs) = canBeNumberChar c && canBeNumber xs
  82
  83 -- | Determines whether a char can be part of the string representation of a
  84 -- number (even in scientific notation).
  85 canBeNumberChar :: Char -> Bool
  86 canBeNumberChar c = isDigit c || (c `elem` "eE-")
  87
  88 -- | Generates an arbitrary @xm uptime@ output line.
  89 instance Arbitrary UptimeInfo where
  90   arbitrary = do
  91     name <- genFQDN
  92     NonNegative idNum <- arbitrary :: Gen (NonNegative Int)
  93     NonNegative days <- arbitrary :: Gen (NonNegative Int)
  94     hours <- choose (0, 23) :: Gen Int
  95     mins <- choose (0, 59) :: Gen Int
  96     secs <- choose (0, 59) :: Gen Int
  97     let uptime :: String
  98         uptime =
  99           if days /= 0
 100             then printf "%d days, %d:%d:%d" days hours mins secs
 101             else printf "%d:%d:%d" hours mins secs
 102     return $ UptimeInfo name idNum uptime
 103
 104 -- * Helper functions for tests
 105
 106 -- | Function for testing whether a domain configuration is parsed correctly.
 107 testDomain :: String -> Map.Map String Domain -> Assertion
 108 testDomain fileName expectedContent = do
 109   fileContent <- readTestData fileName
 110   case A.parseOnly xmListParser $ pack fileContent of
 111     Left msg -> assertFailure $ "Parsing failed: " ++ msg
 112     Right obtained -> assertEqual fileName expectedContent obtained
 113
 114 -- | Function for testing whether a @xm uptime@ output (stored in a file)
 115 -- is parsed correctly.
 116 testUptimeInfo :: String -> Map.Map Int UptimeInfo -> Assertion
 117 testUptimeInfo fileName expectedContent = do
 118   fileContent <- readTestData fileName
 119   case A.parseOnly xmUptimeParser $ pack fileContent of
 120     Left msg -> assertFailure $ "Parsing failed: " ++ msg
 121     Right obtained -> assertEqual fileName expectedContent obtained
 122
 123 -- | Determines whether two LispConfig are equal, with the exception of Double
 124 -- values, that just need to be \"almost equal\".
 125 --
 126 -- Meant mainly for testing purposes, given that Double values may be slightly
 127 -- rounded during parsing.
 128 isAlmostEqual :: LispConfig -> LispConfig -> Property
 129 isAlmostEqual (LCList c1) (LCList c2) =
 130   (length c1 ==? length c2) .&&.
 131   conjoin (zipWith isAlmostEqual c1 c2)
 132 isAlmostEqual (LCString s1) (LCString s2) = s1 ==? s2
 133 isAlmostEqual (LCDouble d1) (LCDouble d2) = printTestCase msg $ rel <= 1e-12
 134     where rel = relativeError d1 d2
 135           msg = "Relative error " ++ show rel ++ " not smaller than 1e-12\n" ++
 136                 "expected: " ++ show d2 ++ "\n but got: " ++ show d1
 137 isAlmostEqual a b =
 138   failTest $ "Comparing different types: '" ++ show a ++ "' with '" ++
 139              show b ++ "'"
 140
 141 -- | Function to serialize LispConfigs in such a way that they can be rebuilt
 142 -- again by the lispConfigParser.
 143 serializeConf :: LispConfig -> String
 144 serializeConf (LCList c) = "(" ++ unwords (map serializeConf c) ++ ")"
 145 serializeConf (LCString s) = s
 146 serializeConf (LCDouble d) = show d
 147
 148 -- | Function to serialize UptimeInfos in such a way that they can be rebuilt
 149 -- againg by the uptimeLineParser.
 150 serializeUptime :: UptimeInfo -> String
 151 serializeUptime (UptimeInfo name idNum uptime) =
 152   printf "%s\t%d\t%s" name idNum uptime
 153
 154 -- | Test whether a randomly generated config can be parsed.
 155 -- Implicitly, this also tests that the Show instance of Config is correct.
 156 prop_config :: LispConfig -> Property
 157 prop_config conf =
 158   case A.parseOnly lispConfigParser . pack . serializeConf $ conf of
 159         Left msg -> failTest $ "Parsing failed: " ++ msg
 160         Right obtained -> printTestCase "Failing almost equal check" $
 161                           isAlmostEqual obtained conf
 162
 163 -- | Test whether a randomly generated UptimeInfo text line can be parsed.
 164 prop_uptimeInfo :: UptimeInfo -> Property
 165 prop_uptimeInfo uInfo =
 166   case A.parseOnly uptimeLineParser . pack . serializeUptime $ uInfo of
 167     Left msg -> failTest $ "Parsing failed: " ++ msg
 168     Right obtained -> obtained ==? uInfo
 169
 170 -- | Test a Xen 4.0.1 @xm list --long@ output.
 171 case_xen401list :: Assertion
 172 case_xen401list = testDomain "xen-xm-list-long-4.0.1.txt" $
 173   Map.fromList
 174     [ ("Domain-0", Domain 0 "Domain-0" 184000.41332 ActualRunning Nothing)
 175     , ("instance1.example.com", Domain 119 "instance1.example.com" 24.116146647
 176       ActualBlocked Nothing)
 177     ]
 178
 179 -- | Test a Xen 4.0.1 @xm uptime@ output.
 180 case_xen401uptime :: Assertion
 181 case_xen401uptime = testUptimeInfo "xen-xm-uptime-4.0.1.txt" $
 182   Map.fromList
 183     [ (0, UptimeInfo "Domain-0" 0 "98 days,  2:27:44")
 184     , (119, UptimeInfo "instance1.example.com" 119 "15 days, 20:57:07")
 185     ]
 186
 187 testSuite "Hypervisor/Xen/XmParser"
 188           [ 'prop_config
 189           , 'prop_uptimeInfo
 190           , 'case_xen401list
 191           , 'case_xen401uptime
 192           ]