Synnefo » snf-ganeti

	src/Ganeti/Hypervisor \

	src/Ganeti/Hypervisor/Xen \

	test/hs/Test/Ganeti/Hypervisor \

	test/hs/Test/Ganeti/Hypervisor/Xen \

	$(APIDOC_HS_DIR)/Ganeti/Hypervisor \

	$(APIDOC_HS_DIR)/Ganeti/Hypervisor/Xen \

	src/Ganeti/Hypervisor/Xen/XmParser.hs \

	src/Ganeti/Hypervisor/Xen/Types.hs \

	test/hs/Test/Ganeti/Hypervisor/Xen/XmParser.hs \

	test/data/xen-xm-list-long-4.0.1.txt \

{-# 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

          ]

import Test.Ganeti.Hypervisor.Xen.XmParser

  , testHypervisor_Xen_XmParser