On Wed, Feb 06, 2013 at 01:09:51PM +0100, Michele Tartara wrote:
> In order to fetch precise information about the status of the VMs running in
> Xen, we need to analyze the output of the "xm list --long" command.
>
> This commit adds the parser to do that, and its tests.
>
> Signed-off-by: Michele Tartara <[email protected]>
> ---
> Makefile.am | 10 ++
> src/Ganeti/Hypervisor/Xen/Types.hs | 107 +++++++++++++++++++
> src/Ganeti/Hypervisor/Xen/XmParser.hs | 132 +++++++++++++++++++++++
> test/data/xen-xm-list-long-4.0.1.txt | 134
> ++++++++++++++++++++++++
> test/hs/Test/Ganeti/Hypervisor/Xen/XmParser.hs | 119 +++++++++++++++++++++
> test/hs/htest.hs | 2 +
> 6 files changed, 504 insertions(+)
> create mode 100644 src/Ganeti/Hypervisor/Xen/Types.hs
> create mode 100644 src/Ganeti/Hypervisor/Xen/XmParser.hs
> create mode 100644 test/data/xen-xm-list-long-4.0.1.txt
> create mode 100644 test/hs/Test/Ganeti/Hypervisor/Xen/XmParser.hs
>
> diff --git a/Makefile.am b/Makefile.am
> index b1cbdac..9577f53 100644
> --- a/Makefile.am
> +++ b/Makefile.am
> @@ -65,6 +65,8 @@ HS_DIRS = \
> src/Ganeti/HTools \
> src/Ganeti/HTools/Backend \
> src/Ganeti/HTools/Program \
> + src/Ganeti/Hypervisor \
> + src/Ganeti/Hypervisor/Xen \
> src/Ganeti/Query \
> test/hs \
> test/hs/Test \
> @@ -74,6 +76,8 @@ HS_DIRS = \
> test/hs/Test/Ganeti/Confd \
> test/hs/Test/Ganeti/HTools \
> test/hs/Test/Ganeti/HTools/Backend \
> + test/hs/Test/Ganeti/Hypervisor \
> + test/hs/Test/Ganeti/Hypervisor/Xen \
> test/hs/Test/Ganeti/Query
>
> DIRS = \
> @@ -121,6 +125,8 @@ ALL_APIDOC_HS_DIRS = \
> $(APIDOC_HS_DIR)/Ganeti/HTools \
> $(APIDOC_HS_DIR)/Ganeti/HTools/Backend \
> $(APIDOC_HS_DIR)/Ganeti/HTools/Program \
> + $(APIDOC_HS_DIR)/Ganeti/Hypervisor \
> + $(APIDOC_HS_DIR)/Ganeti/Hypervisor/Xen \
> $(APIDOC_HS_DIR)/Ganeti/Query
>
> BUILDTIME_DIR_AUTOCREATE = \
> @@ -514,6 +520,8 @@ HS_LIB_SRCS = \
> src/Ganeti/HTools/Program/Hroller.hs \
> src/Ganeti/HTools/Program/Main.hs \
> src/Ganeti/HTools/Types.hs \
> + src/Ganeti/Hypervisor/Xen/XmParser.hs \
> + src/Ganeti/Hypervisor/Xen/Types.hs \
> src/Ganeti/Hash.hs \
> src/Ganeti/JQueue.hs \
> src/Ganeti/JSON.hs \
> @@ -563,6 +571,7 @@ HS_TEST_SRCS = \
> test/hs/Test/Ganeti/HTools/Node.hs \
> test/hs/Test/Ganeti/HTools/PeerMap.hs \
> test/hs/Test/Ganeti/HTools/Types.hs \
> + test/hs/Test/Ganeti/Hypervisor/Xen/XmParser.hs \
> test/hs/Test/Ganeti/JSON.hs \
> test/hs/Test/Ganeti/Jobs.hs \
> test/hs/Test/Ganeti/JQueue.hs \
> @@ -1044,6 +1053,7 @@ TEST_FILES = \
> test/data/xen-xm-info-4.0.1.txt \
> test/data/xen-xm-list-4.0.1-dom0-only.txt \
> test/data/xen-xm-list-4.0.1-four-instances.txt \
> + test/data/xen-xm-list-long-4.0.1.txt \
> test/py/ganeti-cli.test \
> test/py/gnt-cli.test \
> test/py/import-export_unittest-helper
> diff --git a/src/Ganeti/Hypervisor/Xen/Types.hs
> b/src/Ganeti/Hypervisor/Xen/Types.hs
> new file mode 100644
> index 0000000..ec1049f
> --- /dev/null
> +++ b/src/Ganeti/Hypervisor/Xen/Types.hs
> @@ -0,0 +1,107 @@
> +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
> +{-| Data types for Xen-specific hypervisor functionalities.
> +
> +-}
> +{-
> +
> +Copyright (C) 2013 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 Ganeti.Hypervisor.Xen.Types
> + ( LispConfig(..)
> + , Domain(..)
> + , FromLispConfig(..)
> + , ActualState(..)
> + ) where
> +
> +import qualified Text.JSON as J
> +
> +import Ganeti.BasicTypes
> +
> +-- | Data type representing configuration data as produced by the
> +-- @xm list --long@ command.
> +data LispConfig = LCList [LispConfig]
> + | LCString String
> + | LCDouble Double
> + deriving (Eq, Show)
FYI, usually the intending aligns the '|' with the '=', so that all
constructors start in the same column.
> +
> +-- | Data type representing a Xen Domain.
> +data Domain = Domain
> + { domId :: Int
> + , domName :: String
> + , domCpuTime :: Double
> + , domState :: ActualState
> + , domIsHung :: Maybe Bool
> + } deriving (Show, Eq)
(I) Usually also align on '::' as well.
> +-- | Class representing all the types that can be extracted from LispConfig.
> +class FromLispConfig a where
> + fromLispConfig :: LispConfig -> Result a
> +
> +-- | Instance of FromLispConfig for Int.
> +instance FromLispConfig Int where
> + fromLispConfig (LCDouble d) = Ok $ floor d
> + fromLispConfig (LCList (LCString _:LCDouble d:[])) = Ok $ floor d
> + fromLispConfig c =
> + Bad $ "Unable to extract a Int from this configuration: "
> + ++ show c
> +
> +-- | Instance of FromLispConfig for Double.
> +instance FromLispConfig Double where
> + fromLispConfig (LCDouble d) = Ok d
> + fromLispConfig (LCList (LCString _:LCDouble d:[])) = Ok d
> + fromLispConfig c =
> + Bad $ "Unable to extract a Double from this configuration: "
> + ++ show c
> +
> +-- | Instance of FromLispConfig for String
.
> +instance FromLispConfig String where
> + fromLispConfig (LCString s) = Ok s
> + fromLispConfig (LCList (LCString _:LCString s:[])) = Ok s
> + fromLispConfig c =
> + Bad $ "Unable to extract a String from this configuration: "
> + ++ show c
> +
> +-- | Instance of FromLispConfig for [LispConfig]
.
> +instance FromLispConfig [LispConfig] where
> + fromLispConfig (LCList l) = Ok l
> + fromLispConfig c =
> + Bad $ "Unable to extract a List from this configuration: "
> + ++ show c
> +
> +data ActualState = ActualRunning -- The instance is running
> + | ActualBlocked -- The instance is not running or runnable
> + | ActualPaused -- The instance has been paused
> + | ActualShutdown -- The instance is shut down
> + | ActualCrashed -- The instance has crashed
> + | ActualDying -- The instance is in process of dying
> + | ActualHung -- The instance is hung
> + | ActualUnknown -- Unknown state. Parsing error.
> + deriving (Show, Eq)
You're missing '^'. The correct syntax is 'ActualRunning -- ^ The
instance is running'.
> +instance J.JSON ActualState where
> + showJSON ActualRunning = J.showJSON "running"
> + showJSON ActualBlocked = J.showJSON "blocked"
> + showJSON ActualPaused = J.showJSON "paused"
> + showJSON ActualShutdown = J.showJSON "shutdown"
> + showJSON ActualCrashed = J.showJSON "crashed"
> + showJSON ActualDying = J.showJSON "dying"
> + showJSON ActualHung = J.showJSON "hung"
> + showJSON ActualUnknown = J.showJSON "unknown"
> +
> + readJSON = error "JSON read instance not implemented for type ActualState"
> diff --git a/src/Ganeti/Hypervisor/Xen/XmParser.hs
> b/src/Ganeti/Hypervisor/Xen/XmParser.hs
> new file mode 100644
> index 0000000..c037910
> --- /dev/null
> +++ b/src/Ganeti/Hypervisor/Xen/XmParser.hs
> @@ -0,0 +1,132 @@
> +{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}
> +{-| Parser for the output of the @xm list --long@ command of Xen
> +
> +-}
> +{-
> +
> +Copyright (C) 2013 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 Ganeti.Hypervisor.Xen.XmParser
> + ( xmListParser
> + , lispConfigParser
> + ) where
> +
> +import Control.Applicative ((*>), (<*), (<|>), pure)
> +import Control.Monad
> +import qualified Data.Attoparsec.Text as A
> +import qualified Data.Attoparsec.Combinator as AC
> +import Data.Attoparsec.Text (Parser)
> +import Data.Char (isSpace)
> +import Data.List
> +import qualified Data.Map as Map
> +import Data.Text (unpack)
> +
> +import Ganeti.BasicTypes
> +import Ganeti.Hypervisor.Xen.Types
> +
> +
> +-- | A parser for parsing generic config files written in the (LISP-like)
> +-- format that is the output of the @xm list --long@ command.
> +-- This parser only takes care of the syntactic parse, but does not care
> +-- about the semantics.
> +lispConfigParser :: Parser LispConfig
> +lispConfigParser =
> + A.skipSpace *>
> + ( listConfigP
> + <|> doubleP
> + <|> stringP
> + )
> + <* A.skipSpace
> + where listConfigP =
> + (A.char '(' *> lispConfigParser `AC.manyTill` A.char ')')
> + >>= pure . LCList
> + doubleP = A.double >>= pure . LCDouble
> + stringP =
> + A.takeWhile1 (
> + \c -> (not . isSpace) c
> + && (c /= ')')
> + && (c /= '(')
> + ) >>= (pure . LCString . unpack )
> +
> +-- | Find a configuration having the given string as its first element,
> +-- from a list of configurations.
> +findConf :: String -> [LispConfig] -> Result LispConfig
> +findConf key configs =
> + case find (isNamed key) configs of
> + (Just c) -> Ok c
> + _ -> Bad "Configuration not found"
> +
> +-- | Get the value of of a configuration having the given string as its
> +-- first element.
> +-- The value is the content of the configuration, discarding the name itself.
> +getValue :: (FromLispConfig a) => String -> [LispConfig] -> Result a
> +getValue key configs = findConf key configs >>= fromLispConfig
> +
> +-- | Extract the values of a configuration containing a list of them.
> +extractValues :: LispConfig -> Result [LispConfig]
> +extractValues c = tail `fmap` fromLispConfig c
> +
> +-- | Verify whether the given configuration has a certain name or not.fmap
> +-- The name of a configuration is its first parameter, if it is a string.
> +isNamed :: String -> LispConfig -> Bool
> +isNamed key (LCList (LCString x:_)) = x == key
> +isNamed _ _ = False
> +
> +-- | Parser for recognising the current state of a Xen domain.
> +parseState :: String -> ActualState
> +parseState s =
> + case s of
> + "r-----" -> ActualRunning
> + "-b----" -> ActualBlocked
> + "--p---" -> ActualPaused
> + "---s--" -> ActualShutdown
> + "----c-" -> ActualCrashed
> + "-----d" -> ActualDying
> + _ -> ActualUnknown
Coming back to our previous discussion about ActualUnknown: the only
thing I don't like is that ActualUnknown right now "swallows" and hides
the error message. OK for now, but it would be better to have it as an
argument to the ActualUnknown constructor.
> +-- | Extract the configuration data of a Xen domain from a generic LispConfig
> +-- data structure. Fail if the LispConfig does not represent a domain.
> +getDomainConfig :: LispConfig -> Result Domain
> +getDomainConfig configData = do
> + domainConf <-
> + if isNamed "domain" configData
> + then extractValues configData
> + else Bad $ "Not a domain configuration: " ++ show configData
> + domid <- getValue "domid" domainConf
> + name <- getValue "name" domainConf
> + cpuTime <- getValue "cpu_time" domainConf
> + state <- getValue "state" domainConf
> + let actualState = parseState state
> + return $ Domain domid name cpuTime actualState Nothing
> +
> +-- | A parser for parsing the output of the @xm list --long@ command.
> +-- It adds the semantic layer on top of lispConfigParser.
> +-- It returns a map of domains, with their name as the key.
> +-- FIXME: This is efficient under the assumption that only a few fields of
> the
> +-- domain configuration are actually needed. If many of them are required, a
> +-- parser able to directly extract the domain config would actually be
> better.
> +xmListParser :: Parser (Map.Map String Domain)
> +xmListParser = do
> + configs <- lispConfigParser `AC.manyTill` A.endOfInput
> + let domains = map getDomainConfig configs
> + foldResult m (Ok val) = Ok $ Map.insert (domName val) val m
> + foldResult _ (Bad msg) = Bad msg
> + case foldM foldResult Map.empty domains of
> + Ok d -> return d
> + Bad msg -> fail msg
> diff --git a/test/data/xen-xm-list-long-4.0.1.txt
> b/test/data/xen-xm-list-long-4.0.1.txt
> new file mode 100644
> index 0000000..404e98b
> --- /dev/null
> +++ b/test/data/xen-xm-list-long-4.0.1.txt
> @@ -0,0 +1,134 @@
> +(domain
> + (domid 0)
> + (cpu_weight 2048)
> + (cpu_cap 0)
> + (bootloader )
> + (on_crash restart)
> + (uuid 00000000-0000-0000-0000-000000000000)
> + (bootloader_args )
> + (vcpus 24)
> + (name Domain-0)
> + (cpus
> + ((0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23)
> + )
> + )
> + (on_reboot restart)
> + (on_poweroff destroy)
> + (maxmem 16777215)
> + (memory 1023)
> + (shadow_memory 0)
> + (features )
> + (on_xend_start ignore)
> + (on_xend_stop ignore)
> + (cpu_time 184000.41332)
> + (online_vcpus 1)
> + (image (linux (kernel ) (superpages 0) (nomigrate 0) (tsc_mode 0)))
> + (status 2)
> + (state r-----)
> +)
> +(domain
> + (domid 119)
> + (cpu_weight 256)
> + (cpu_cap 0)
> + (bootloader )
> + (on_crash restart)
> + (uuid e430b4b8-dc91-9390-dfe0-b83c138ea0aa)
> + (bootloader_args )
> + (vcpus 1)
> + (description )
> + (name instance1.example.com)
> + (cpus (()))
> + (on_reboot restart)
> + (on_poweroff destroy)
> + (maxmem 128)
> + (memory 128)
> + (shadow_memory 0)
> + (features )
> + (on_xend_start ignore)
> + (on_xend_stop ignore)
> + (start_time 1357749308.05)
> + (cpu_time 24.116146647)
> + (online_vcpus 1)
> + (image
> + (linux
> + (kernel /boot/vmlinuz-ganetixenu)
> + (args 'root=/dev/xvda1 ro')
> + (superpages 0)
> + (videoram 4)
> + (pci ())
> + (nomigrate 0)
> + (tsc_mode 0)
> + (notes
> + (HV_START_LOW 18446603336221196288)
> + (FEATURES '!writable_page_tables|pae_pgdir_above_4gb')
> + (VIRT_BASE 18446744071562067968)
> + (GUEST_VERSION 2.6)
> + (PADDR_OFFSET 0)
> + (GUEST_OS linux)
> + (HYPERCALL_PAGE 18446744071578849280)
> + (LOADER generic)
> + (SUSPEND_CANCEL 1)
> + (PAE_MODE yes)
> + (ENTRY 18446744071592116736)
> + (XEN_VERSION xen-3.0)
> + )
> + )
> + )
> + (status 2)
> + (state -b----)
> + (store_mfn 8836555)
> + (console_mfn 8735251)
> + (device
> + (vif
> + (bridge xen-br0)
> + (mac aa:00:00:30:8d:9d)
> + (script /etc/xen/scripts/vif-bridge)
> + (uuid f57c4758-cf0a-8227-6d13-fe26ece82d75)
> + (backend 0)
> + )
> + )
> + (device
> + (console
> + (protocol vt100)
> + (location 2)
> + (uuid 7695737a-ffc2-4e0d-7f6d-734143b8afc4)
> + )
> + )
> + (device
> + (vbd
> + (protocol x86_64-abi)
> + (uuid 409e1ff8-435a-4704-80bb-4bfe800d932e)
> + (bootable 1)
> + (dev sda:disk)
> + (uname
> + phy:/var/run/ganeti/instance-disks/instance1.example.com:0
> + )
> + (mode w)
> + (backend 0)
> + (VDI )
> + )
> + )
> +)
> diff --git a/test/hs/Test/Ganeti/Hypervisor/Xen/XmParser.hs
> b/test/hs/Test/Ganeti/Hypervisor/Xen/XmParser.hs
> new file mode 100644
> index 0000000..e781d8b
> --- /dev/null
> +++ b/test/hs/Test/Ganeti/Hypervisor/Xen/XmParser.hs
> @@ -0,0 +1,119 @@
> +{-# LANGUAGE TemplateHaskell #-}
> +{-# OPTIONS_GHC -fno-warn-orphans #-}
> +
> +{-| Unittests for @xm list --long@ parser -}
> +
> +{-
> +
> +Copyright (C) 2013 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.Hypervisor.Xen.XmParser
> + ( testHypervisor_Xen_XmParser
> + ) where
> +
> +import Test.HUnit
> +import Test.QuickCheck as QuickCheck hiding (Result)
> +
> +import Test.Ganeti.TestHelper
> +import Test.Ganeti.TestCommon
> +
> +import Control.Monad (liftM)
> +import qualified Data.Attoparsec.Text as A
> +import Data.Char (isAsciiUpper, isAsciiLower)
> +import qualified Data.Map as Map
> +import Data.Text (pack)
> +
> +import Ganeti.Hypervisor.Xen.Types
> +import Ganeti.Hypervisor.Xen.XmParser
> +{-# ANN module "HLint: ignore Use camelCase" #-}
Please one blank line before the annotation.
> +
> +-- | Generates an arbitrary non-empty string
(.)
> +-- Note that isAlpha is not used because it could allow the generation of
> +-- unicode characters, that we do not want.
> +nonEmptyString :: Gen String
> +nonEmptyString = listOf1 $
> + arbitrary `suchThat` (\c -> isAsciiUpper c || isAsciiLower c)
Same comment as on the other patch.
> +-- * Arbitraries
> +
> +-- | Arbitrary instance for generating configurations.
> +-- A completely arbitrary configuration would contain too many lists and its
> +-- size would be to big to be actually parsable in reasonable time.
> +-- This Arbitrary builds a random Config that is still of a reasonable size.
> +instance Arbitrary LispConfig where
> + arbitrary = frequency
> + [ (5, liftM LCString nonEmptyString)
> + , (5, liftM LCDouble arbitrary)
> + , (1, liftM LCList (choose(1,20) >>= (`vectorOf` arbitrary)))
> + ]
> +
> +-- * Helper functions for tests
> +
> +-- | Function for testing whether a domain configuration is parsed correctly.
> +testDomain :: String -> Map.Map String Domain -> Assertion
> +testDomain fileName expectedContent = do
> + fileContent <- readTestData fileName
> + case A.parseOnly xmListParser $ pack fileContent of
> + Left msg -> assertFailure $ "Parsing failed: " ++ msg
> + Right obtained -> assertEqual fileName expectedContent obtained
> +
> +-- | Determines whether two LispConfig are equal, with the exception of
> Double
> +-- values, that just need to be "almost equal".
> +-- Meant mainly for testing purposes, given that Double values may be
> slightly
> +-- rounded during parsing.
> +isAlmostEqual :: LispConfig -> LispConfig -> Bool
> +isAlmostEqual (LCList c1) (LCList c2) =
> + (length c1 == length c2) &&
> + foldr
> + (\current acc -> (acc && uncurry isAlmostEqual current))
> + True
> + (zip c1 c2)
> +isAlmostEqual (LCString s1) (LCString s2) = s1 == s2
> +isAlmostEqual (LCDouble d1) (LCDouble d2) = abs (d1-d2) <= 1e-12
> +isAlmostEqual _ _ = False
> +
> +-- | Function to serialize LispConfigs in such a way that they can be rebuilt
> +-- again by the lispConfigParser.
> +serializeConf :: LispConfig -> String
> +serializeConf (LCList c) = "(" ++ unwords (map serializeConf c) ++ ")"
> +serializeConf (LCString s) = s
> +serializeConf (LCDouble d) = show d
> +
> +-- | Test whether a randomly generated config can be parsed.
> +-- Implicitly, this also tests that the Show instance of Config is correct.
> +prop_config :: LispConfig -> Property
> +prop_config conf =
> + case A.parseOnly lispConfigParser . pack . serializeConf $ conf of
> + Left msg -> fail $ "Parsing failed: " ++ msg
> + Right obtained -> property $ isAlmostEqual obtained conf
> +
> +-- | Test a Xen 4.0.1 @xm list --long@ output.
> +case_xen401list :: Assertion
> +case_xen401list = testDomain "xen-xm-list-long-4.0.1.txt" $
> + Map.fromList
> + [ ("Domain-0", Domain 0 "Domain-0" 184000.41332 ActualRunning Nothing)
> + , ("instance1.example.com", Domain 119 "instance1.example.com"
> 24.116146647
> + ActualBlocked Nothing)
> + ]
> +
> +testSuite "Hypervisor/Xen/XmParser"
> + [ 'prop_config
> + , 'case_xen401list
> + ]
> diff --git a/test/hs/htest.hs b/test/hs/htest.hs
> index c2791f3..4358c85 100644
> --- a/test/hs/htest.hs
> +++ b/test/hs/htest.hs
> @@ -51,6 +51,7 @@ import Test.Ganeti.HTools.Loader
> import Test.Ganeti.HTools.Node
> import Test.Ganeti.HTools.PeerMap
> import Test.Ganeti.HTools.Types
> +import Test.Ganeti.Hypervisor.Xen.XmParser
> import Test.Ganeti.JSON
> import Test.Ganeti.Jobs
> import Test.Ganeti.JQueue
> @@ -103,6 +104,7 @@ allTests =
> , testHTools_Node
> , testHTools_PeerMap
> , testHTools_Types
> + , testHypervisor_Xen_XmParser
> , testJSON
> , testJobs
> , testJQueue
LGTM, thanks.
iustin
