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   , xmUptimeParser
  29   , uptimeLineParser
  30   ) where
  31
  32 import Control.Applicative
  33 import Control.Monad
  34 import qualified Data.Attoparsec.Combinator as AC
  35 import qualified Data.Attoparsec.Text as A
  36 import Data.Attoparsec.Text (Parser)
  37 import Data.Char
  38 import Data.List
  39 import Data.Text (unpack)
  40 import qualified Data.Map as Map
  41
  42 import Ganeti.BasicTypes
  43 import Ganeti.Hypervisor.Xen.Types
  44
  45 -- | A parser for parsing generic config files written in the (LISP-like)
  46 -- format that is the output of the @xm list --long@ command.
  47 -- This parser only takes care of the syntactic parse, but does not care
  48 -- about the semantics.
  49 -- Note: parsing the double requires checking for the next character in order
  50 -- to prevent string like "9a" to be recognized as the number 9.
  51 lispConfigParser :: Parser LispConfig
  52 lispConfigParser =
  53   A.skipSpace *>
  54     (   listConfigP
  55     <|> doubleP
  56     <|> stringP
  57     )
  58   <* A.skipSpace
  59     where listConfigP = LCList <$> (A.char '(' *> liftA2 (++)
  60             (many middleP)
  61             (((:[]) <$> finalP) <|> (rparen *> pure [])))
  62           doubleP = LCDouble <$> A.double <* A.skipSpace <* A.endOfInput
  63           innerDoubleP = LCDouble <$> A.double
  64           stringP = LCString . unpack <$> A.takeWhile1 (not . (\c -> isSpace c
  65             || c `elem` "()"))
  66           wspace = AC.many1 A.space
  67           rparen = A.skipSpace *> A.char ')'
  68           finalP =   listConfigP <* rparen
  69                  <|> innerDoubleP <* rparen
  70                  <|> stringP <* rparen
  71           middleP =   listConfigP <* wspace
  72                   <|> innerDoubleP <* wspace
  73                   <|> stringP <* wspace
  74
  75
  76 -- | Find a configuration having the given string as its first element,
  77 -- from a list of configurations.
  78 findConf :: String -> [LispConfig] -> Result LispConfig
  79 findConf key configs =
  80   case find (isNamed key) configs of
  81     (Just c) -> Ok c
  82     _ -> Bad "Configuration not found"
  83
  84 -- | Get the value of of a configuration having the given string as its
  85 -- first element.
  86 -- The value is the content of the configuration, discarding the name itself.
  87 getValue :: (FromLispConfig a) => String -> [LispConfig] -> Result a
  88 getValue key configs = findConf key configs >>= fromLispConfig
  89
  90 -- | Extract the values of a configuration containing a list of them.
  91 extractValues :: LispConfig -> Result [LispConfig]
  92 extractValues c = tail `fmap` fromLispConfig c
  93
  94 -- | Verify whether the given configuration has a certain name or not.fmap
  95 -- The name of a configuration is its first parameter, if it is a string.
  96 isNamed :: String -> LispConfig -> Bool
  97 isNamed key (LCList (LCString x:_)) = x == key
  98 isNamed _ _ = False
  99
 100 -- | Parser for recognising the current state of a Xen domain.
 101 parseState :: String -> ActualState
 102 parseState s =
 103   case s of
 104     "r-----" -> ActualRunning
 105     "-b----" -> ActualBlocked
 106     "--p---" -> ActualPaused
 107     "---s--" -> ActualShutdown
 108     "----c-" -> ActualCrashed
 109     "-----d" -> ActualDying
 110     _ -> ActualUnknown
 111
 112 -- | Extract the configuration data of a Xen domain from a generic LispConfig
 113 -- data structure. Fail if the LispConfig does not represent a domain.
 114 getDomainConfig :: LispConfig -> Result Domain
 115 getDomainConfig configData = do
 116   domainConf <-
 117     if isNamed "domain" configData
 118       then extractValues configData
 119       else Bad $ "Not a domain configuration: " ++ show configData
 120   domid <- getValue "domid" domainConf
 121   name <- getValue "name" domainConf
 122   cpuTime <- getValue "cpu_time" domainConf
 123   state <- getValue "state" domainConf
 124   let actualState = parseState state
 125   return $ Domain domid name cpuTime actualState Nothing
 126
 127 -- | A parser for parsing the output of the @xm list --long@ command.
 128 -- It adds the semantic layer on top of lispConfigParser.
 129 -- It returns a map of domains, with their name as the key.
 130 -- FIXME: This is efficient under the assumption that only a few fields of the
 131 -- domain configuration are actually needed. If many of them are required, a
 132 -- parser able to directly extract the domain config would actually be better.
 133 xmListParser :: Parser (Map.Map String Domain)
 134 xmListParser = do
 135   configs <- lispConfigParser `AC.manyTill` A.endOfInput
 136   let domains = map getDomainConfig configs
 137       foldResult m (Ok val) = Ok $ Map.insert (domName val) val m
 138       foldResult _ (Bad msg) = Bad msg
 139   case foldM foldResult Map.empty domains of
 140     Ok d -> return d
 141     Bad msg -> fail msg
 142
 143 -- | A parser for parsing the output of the @xm uptime@ command.
 144 xmUptimeParser :: Parser (Map.Map Int UptimeInfo)
 145 xmUptimeParser = do
 146   _ <- headerParser
 147   uptimes <- uptimeLineParser `AC.manyTill` A.endOfInput
 148   return $ Map.fromList [(uInfoID u, u) | u <- uptimes]
 149     where headerParser = A.string "Name" <* A.skipSpace <* A.string "ID"
 150             <* A.skipSpace <* A.string "Uptime" <* A.skipSpace
 151
 152 -- | A helper for parsing a single line of the @xm uptime@ output.
 153 uptimeLineParser :: Parser UptimeInfo
 154 uptimeLineParser = do
 155   name <- A.takeTill isSpace <* A.skipSpace
 156   idNum <- A.decimal <* A.skipSpace
 157   uptime <- A.takeTill (`elem` "\n\r") <* A.skipSpace
 158   return . UptimeInfo (unpack name) idNum $ unpack uptime