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 \
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 = \
$(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 = \
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 \
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 \
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
--- /dev/null
+{-# 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"
--- /dev/null
+{-# 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
--- /dev/null
+(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 )
+ )
+ )
+)
--- /dev/null
+{-# 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
+ ]
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
, testHTools_Node
, testHTools_PeerMap
, testHTools_Types
+ , testHypervisor_Xen_XmParser
, testJSON
, testJobs
, testJQueue
projects / ganeti-local / commitdiff