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 | 106 ++++++++++++++++ src/Ganeti/Hypervisor/Xen/XmListParser.hs | 128 ++++++++++++++++++++ src/Ganeti/Objects.hs | 23 ++++ test/data/xen-xm-list-long-3.0.txt | 134 +++++++++++++++++++++ test/hs/Test/Ganeti/Hypervisor/Xen/XmListParser.hs | 93 ++++++++++++++ test/hs/htest.hs | 2 + 7 files changed, 496 insertions(+) create mode 100644 src/Ganeti/Hypervisor/Xen/Types.hs create mode 100644 src/Ganeti/Hypervisor/Xen/XmListParser.hs create mode 100644 test/data/xen-xm-list-long-3.0.txt create mode 100644 test/hs/Test/Ganeti/Hypervisor/Xen/XmListParser.hs diff --git a/Makefile.am b/Makefile.am index 92fc57c..9af1f87 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/XmListParser.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/XmListParser.hs \ test/hs/Test/Ganeti/JSON.hs \ test/hs/Test/Ganeti/Jobs.hs \ test/hs/Test/Ganeti/JQueue.hs \ @@ -1043,6 +1052,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-3.0.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..3b10b30 --- /dev/null +++ b/src/Ganeti/Hypervisor/Xen/Types.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE OverloadedStrings, 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 + ( Config(..) + , Domain(..) + , FromConfig(..) + , isAlmostEqual + ) where + +import Ganeti.BasicTypes +import Ganeti.Objects + +-- | Data type representing configuration data as produced by the +-- "xm list --long" command. +data Config = List [Config] + | String String + | Double Double + deriving (Eq) + +-- | The Show instance for Config +instance Show Config where + show (List c) = "(" ++ unwords (map show c) ++ ")" + show (String s) = s + show (Double d) = show d + + +-- | Determines whether two Config 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 :: Config -> Config -> Bool +isAlmostEqual (List c1) (List c2) = + (length c1 == length c2) && + foldr + (\current acc -> (acc && uncurry isAlmostEqual current)) + True + (zip c1 c2) +isAlmostEqual (String s1) (String s2) = s1 == s2 +isAlmostEqual (Double d1) (Double d2) = abs (d1-d2) <= 1e-12 +isAlmostEqual _ _ = False + +-- | 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 Config. +class FromConfig a where + fromConfig :: Config -> Result a + +-- | Instance of FromConfig for Int. +instance FromConfig Int where + fromConfig (Double d) = Ok $ floor d + fromConfig (List (String _:Double d:[])) = Ok $ floor d + fromConfig c = + Bad $ "Unable to extract a Int from this configuration: " + ++ show c + +-- | Instance of FromConfig for Double. +instance FromConfig Double where + fromConfig (Double d) = Ok d + fromConfig (List (String _:Double d:[])) = Ok d + fromConfig c = + Bad $ "Unable to extract a Double from this configuration: " + ++ show c + +-- | Instance of FromConfig for String +instance FromConfig String where + fromConfig (String s) = Ok s + fromConfig (List (String _:String s:[])) = Ok s + fromConfig c = + Bad $ "Unable to extract a String from this configuration: " + ++ show c + +-- | Instance of FromConfig for [Config] +instance FromConfig [Config] where + fromConfig (List l) = Ok l + fromConfig c = + Bad $ "Unable to extract a List from this configuration: " + ++ show c diff --git a/src/Ganeti/Hypervisor/Xen/XmListParser.hs b/src/Ganeti/Hypervisor/Xen/XmListParser.hs new file mode 100644 index 0000000..3ef5def --- /dev/null +++ b/src/Ganeti/Hypervisor/Xen/XmListParser.hs @@ -0,0 +1,128 @@ +{-# 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.XmListParser (xmListParser, configParser) where + +import Control.Applicative ((*>), (<*), (<|>), pure) +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 +import Ganeti.Objects + +-- | 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. +configParser :: Parser Config +configParser = + A.skipSpace *> + ( configP + <|> doubleP + <|> stringP + ) + <* A.skipSpace + where configP = + (A.char '(' *> configParser `AC.manyTill` A.char ')') + >>= pure . List + doubleP = A.double >>= pure . Double + stringP = + A.takeWhile1 ( + \c -> (not . isSpace) c + && (c /= ')') + && (c /= '(') + ) >>= (pure . String . unpack ) + +-- | Find a configuration having the given string as its first element, +-- from a list of configurations. +findConf :: String -> [Config] -> Result Config +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 :: (FromConfig a) => String -> [Config] -> Result a +getValue key configs = findConf key configs >>= fromConfig + +-- | Extract the values of a configuration containing a list of them. +extractValues :: Config -> Result [Config] +extractValues c = fmap tail $ fromConfig c + +-- | Verify whether the given configuration has a certain name or not. +-- The name of a configuration is its first parameter, if it is a string. +isNamed :: String -> Config -> Bool +isNamed key (List (String x:_)) = x == key +isNamed _ _ = False + +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 Config +-- data structure. Fail if the Config does not represent a domain. +getDomainConfig :: Config -> 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 configParser. +-- 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 <- configParser `AC.manyTill` A.endOfInput + let domains = map getDomainConfig configs + foldResult (Ok val) (Ok m) = Ok $ Map.insert (domName val) val m + foldResult _ badMap@(Bad _) = badMap + foldResult (Bad msg) _ = Bad msg + case foldr foldResult (Ok Map.empty) domains of + (Ok d) -> return d + (Bad msg) -> fail msg diff --git a/src/Ganeti/Objects.hs b/src/Ganeti/Objects.hs index 26ccea6..5e2ec44 100644 --- a/src/Ganeti/Objects.hs +++ b/src/Ganeti/Objects.hs @@ -51,6 +51,7 @@ module Ganeti.Objects , allBeParamFields , AdminState(..) , adminStateFromRaw + , ActualState(..) , Instance(..) , toDictInstance , PartialNDParams(..) @@ -376,6 +377,28 @@ $(declareSADT "AdminState" ]) $(makeJSONInstance ''AdminState) +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 JSON ActualState where + showJSON ActualRunning = showJSON "running" + showJSON ActualBlocked = showJSON "blocked" + showJSON ActualPaused = showJSON "paused" + showJSON ActualShutdown = showJSON "shutdown" + showJSON ActualCrashed = showJSON "crashed" + showJSON ActualDying = showJSON "dying" + showJSON ActualHung = showJSON "hung" + showJSON ActualUnknown = showJSON "unknown" + + readJSON = error "JSON read instance not implemented for type ActualState" + $(buildParam "Be" "bep" [ simpleField "minmem" [t| Int |] , simpleField "maxmem" [t| Int |] diff --git a/test/data/xen-xm-list-long-3.0.txt b/test/data/xen-xm-list-long-3.0.txt new file mode 100644 index 0000000..404e98b --- /dev/null +++ b/test/data/xen-xm-list-long-3.0.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/XmListParser.hs b/test/hs/Test/Ganeti/Hypervisor/Xen/XmListParser.hs new file mode 100644 index 0000000..b37a18e --- /dev/null +++ b/test/hs/Test/Ganeti/Hypervisor/Xen/XmListParser.hs @@ -0,0 +1,93 @@ +{-# 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.XmListParser (testHypervisor_Xen_XmListParser) 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.XmListParser (configParser, xmListParser) +import Ganeti.Objects (ActualState(..)) + +{-# ANN module "HLint: ignore Use camelCase" #-} + +-- | 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) + +-- | 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 Config where + arbitrary = frequency + [ (5, liftM String nonEmptyString) + , (5, liftM Double arbitrary) + , (1, liftM List (choose(1,20) >>= (`vectorOf` arbitrary))) + ] + +-- | Test whether a randomly generated config can be parsed. +-- Implicitly, this also tests that the Show instance of Config is correct. +prop_config :: Config -> Property +prop_config conf = + case A.parseOnly configParser . pack . show $ conf of + Left msg -> fail $ "Parsing failed: " ++ msg + Right obtained -> property $ isAlmostEqual obtained conf + +-- | 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 + +-- Test a Xen 3.0 "xm list --long" output +case_xen30 :: Assertion +case_xen30 = testDomain "xen-xm-list-long-3.0.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/XmListParser" + [ 'prop_config + , 'case_xen30 + ] diff --git a/test/hs/htest.hs b/test/hs/htest.hs index d7848aa..222eca8 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.XmListParser import Test.Ganeti.JSON import Test.Ganeti.Jobs import Test.Ganeti.JQueue @@ -102,6 +103,7 @@ allTests = , testHTools_Node , testHTools_PeerMap , testHTools_Types + , testHypervisor_Xen_XmListParser , testJSON , testJobs , testJQueue -- 1.8.1
