code.grnet.gr Git - ganeti-local/blob - src/Ganeti/Hypervisor/Xen/XmParser.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-| Parser for the output of the @xm list --long@ command of Xen
   3
   4 -}
   5 {-
   6
   7 Copyright (C) 2013 Google Inc.
   8
   9 This program is free software; you can redistribute it and/or modify
  10 it under the terms of the GNU General Public License as published by
  11 the Free Software Foundation; either version 2 of the License, or
  12 (at your option) any later version.
  13
  14 This program is distributed in the hope that it will be useful, but
  15 WITHOUT ANY WARRANTY; without even the implied warranty of
  16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 General Public License for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with this program; if not, write to the Free Software
  21 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  22 02110-1301, USA.
  23
  24 -}
  25 module Ganeti.Hypervisor.Xen.XmParser
  26   ( xmListParser
  27   , lispConfigParser
  28   ) where
  29
  30 import Control.Applicative
  31 import Control.Monad
  32 import qualified Data.Attoparsec.Combinator as AC
  33 import qualified Data.Attoparsec.Text as A
  34 import Data.Attoparsec.Text (Parser)
  35 import Data.Char
  36 import Data.List
  37 import Data.Text (unpack)
  38 import qualified Data.Map as Map
  39
  40 import Ganeti.BasicTypes
  41 import Ganeti.Hypervisor.Xen.Types
  42
  43 -- | A parser for parsing generic config files written in the (LISP-like)
  44 -- format that is the output of the @xm list --long@ command.
  45 -- This parser only takes care of the syntactic parse, but does not care
  46 -- about the semantics.
  47 -- Note: parsing the double requires checking for the next character in order
  48 -- to prevent string like "9a" to be recognized as the number 9.
  49 lispConfigParser :: Parser LispConfig
  50 lispConfigParser =
  51   A.skipSpace *>
  52     (   listConfigP
  53     <|> doubleP
  54     <|> stringP
  55     )
  56   <* A.skipSpace
  57     where listConfigP = LCList <$> (A.char '(' *> liftA2 (++)
  58             (many middleP)
  59             (((:[]) <$> finalP) <|> (rparen *> pure [])))
  60           doubleP = LCDouble <$> A.double <* A.skipSpace <* A.endOfInput
  61           innerDoubleP = LCDouble <$> A.double
  62           stringP = LCString . unpack <$> A.takeWhile1 (not . (\c -> isSpace c
  63             || c `elem` "()"))
  64           wspace = AC.many1 A.space
  65           rparen = A.skipSpace *> A.char ')'
  66           finalP =   listConfigP <* rparen
  67                  <|> innerDoubleP <* rparen
  68                  <|> stringP <* rparen
  69           middleP =   listConfigP <* wspace
  70                   <|> innerDoubleP <* wspace
  71                   <|> stringP <* wspace
  72
  73
  74 -- | Find a configuration having the given string as its first element,
  75 -- from a list of configurations.
  76 findConf :: String -> [LispConfig] -> Result LispConfig
  77 findConf key configs =
  78   case find (isNamed key) configs of
  79     (Just c) -> Ok c
  80     _ -> Bad "Configuration not found"
  81
  82 -- | Get the value of of a configuration having the given string as its
  83 -- first element.
  84 -- The value is the content of the configuration, discarding the name itself.
  85 getValue :: (FromLispConfig a) => String -> [LispConfig] -> Result a
  86 getValue key configs = findConf key configs >>= fromLispConfig
  87
  88 -- | Extract the values of a configuration containing a list of them.
  89 extractValues :: LispConfig -> Result [LispConfig]
  90 extractValues c = tail `fmap` fromLispConfig c
  91
  92 -- | Verify whether the given configuration has a certain name or not.fmap
  93 -- The name of a configuration is its first parameter, if it is a string.
  94 isNamed :: String -> LispConfig -> Bool
  95 isNamed key (LCList (LCString x:_)) = x == key
  96 isNamed _ _ = False
  97
  98 -- | Parser for recognising the current state of a Xen domain.
  99 parseState :: String -> ActualState
 100 parseState s =
 101   case s of
 102     "r-----" -> ActualRunning
 103     "-b----" -> ActualBlocked
 104     "--p---" -> ActualPaused
 105     "---s--" -> ActualShutdown
 106     "----c-" -> ActualCrashed
 107     "-----d" -> ActualDying
 108     _ -> ActualUnknown
 109
 110 -- | Extract the configuration data of a Xen domain from a generic LispConfig
 111 -- data structure. Fail if the LispConfig does not represent a domain.
 112 getDomainConfig :: LispConfig -> Result Domain
 113 getDomainConfig configData = do
 114   domainConf <-
 115     if isNamed "domain" configData
 116       then extractValues configData
 117       else Bad $ "Not a domain configuration: " ++ show configData
 118   domid <- getValue "domid" domainConf
 119   name <- getValue "name" domainConf
 120   cpuTime <- getValue "cpu_time" domainConf
 121   state <- getValue "state" domainConf
 122   let actualState = parseState state
 123   return $ Domain domid name cpuTime actualState Nothing
 124
 125 -- | A parser for parsing the output of the @xm list --long@ command.
 126 -- It adds the semantic layer on top of lispConfigParser.
 127 -- It returns a map of domains, with their name as the key.
 128 -- FIXME: This is efficient under the assumption that only a few fields of the
 129 -- domain configuration are actually needed. If many of them are required, a
 130 -- parser able to directly extract the domain config would actually be better.
 131 xmListParser :: Parser (Map.Map String Domain)
 132 xmListParser = do
 133   configs <- lispConfigParser `AC.manyTill` A.endOfInput
 134   let domains = map getDomainConfig configs
 135       foldResult m (Ok val) = Ok $ Map.insert (domName val) val m
 136       foldResult _ (Bad msg) = Bad msg
 137   case foldM foldResult Map.empty domains of
 138     Ok d -> return d
 139     Bad msg -> fail msg