Commit b8585908 authored by Michele Tartara's avatar Michele Tartara

Add Haskell parser for "xm list --long"

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: default avatarMichele Tartara <mtartara@google.com>
Reviewed-by: default avatarIustin Pop <iustin@google.com>
parent 332a83ca
......@@ -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 = \
......@@ -122,6 +126,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 = \
......@@ -517,6 +523,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 \
......@@ -566,6 +574,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 \
......@@ -1060,6 +1069,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
......
{-# 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)
-- | Data type representing a Xen Domain.
data Domain = Domain
{ domId :: Int
, domName :: String
, domCpuTime :: Double
, domState :: ActualState
, domIsHung :: Maybe Bool
} deriving (Show, Eq)
-- | 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)
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"
{-# LANGUAGE OverloadedStrings #-}
{-| 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
import Control.Monad
import qualified Data.Attoparsec.Combinator as AC
import qualified Data.Attoparsec.Text as A
import Data.Attoparsec.Text (Parser)
import Data.Char
import Data.List
import Data.Text (unpack)
import qualified Data.Map as Map
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.
-- Note: parsing the double requires checking for the next character in order
-- to prevent string like "9a" to be recognized as the number 9.
lispConfigParser :: Parser LispConfig
lispConfigParser =
A.skipSpace *>
( listConfigP
<|> doubleP
<|> stringP
)
<* A.skipSpace
where listConfigP = LCList <$> (A.char '(' *> liftA2 (++)
(many middleP)
(((:[]) <$> finalP) <|> (rparen *> pure [])))
doubleP = LCDouble <$> A.double <* A.skipSpace <* A.endOfInput
innerDoubleP = LCDouble <$> A.double
stringP = LCString . unpack <$> A.takeWhile1 (not . (\c -> isSpace c
|| c `elem` "()"))
wspace = AC.many1 A.space
rparen = A.skipSpace *> A.char ')'
finalP = listConfigP <* rparen
<|> innerDoubleP <* rparen
<|> stringP <* rparen
middleP = listConfigP <* wspace
<|> innerDoubleP <* wspace
<|> stringP <* wspace
-- | 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
-- | 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
(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 )
)
)
)
{-# 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.Text (pack)
import Data.Char
import qualified Data.Map as Map
import Ganeti.Hypervisor.Xen.Types
import Ganeti.Hypervisor.Xen.XmParser
{-# ANN module "HLint: ignore Use camelCase" #-}
-- * 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.
-- Avoid generating strings that might be interpreted as numbers.
instance Arbitrary LispConfig where
arbitrary = frequency
[ (5, liftM LCString (genName `suchThat` (not . canBeNumber)))
, (5, liftM LCDouble arbitrary)
, (1, liftM LCList (choose(1,20) >>= (`vectorOf` arbitrary)))
]
-- | Determines conservatively whether a string could be a number.
canBeNumber :: String -> Bool
canBeNumber [] = False
canBeNumber (c:[]) = canBeNumberChar c
canBeNumber (c:xs) = canBeNumberChar c && canBeNumber xs
-- | Determines whether a char can be part of the string representation of a
-- number (even in scientific notation).
canBeNumberChar :: Char -> Bool
canBeNumberChar c = isDigit c || (c `elem` "eE-")
-- * 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
]
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment