code.grnet.gr Git - ganeti-local/blob - src/Ganeti/Utils.hs

   1 {-| Utility functions. -}
   2
   3 {-
   4
   5 Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
   6
   7 This program is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2 of the License, or
  10 (at your option) any later version.
  11
  12 This program is distributed in the hope that it will be useful, but
  13 WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with this program; if not, write to the Free Software
  19 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  20 02110-1301, USA.
  21
  22 -}
  23
  24 module Ganeti.Utils
  25   ( debug
  26   , debugFn
  27   , debugXy
  28   , sepSplit
  29   , stdDev
  30   , if'
  31   , select
  32   , applyIf
  33   , commaJoin
  34   , ensureQuoted
  35   , tryRead
  36   , formatTable
  37   , printTable
  38   , parseUnit
  39   , plural
  40   , niceSort
  41   , niceSortKey
  42   , exitIfBad
  43   , exitErr
  44   , exitWhen
  45   , exitUnless
  46   , logWarningIfBad
  47   , rStripSpace
  48   , newUUID
  49   , getCurrentTime
  50   , getCurrentTimeUSec
  51   , clockTimeToString
  52   , chompPrefix
  53   , warn
  54   , wrap
  55   , trim
  56   , defaultHead
  57   , exitIfEmpty
  58   , splitEithers
  59   , recombineEithers
  60   , setOwnerAndGroupFromNames
  61   ) where
  62
  63 import Data.Char (toUpper, isAlphaNum, isDigit, isSpace)
  64 import Data.Function (on)
  65 import Data.List
  66 import qualified Data.Map as M
  67 import Control.Monad (foldM)
  68
  69 import Debug.Trace
  70
  71 import Ganeti.BasicTypes
  72 import qualified Ganeti.Constants as C
  73 import Ganeti.Logging
  74 import Ganeti.Runtime
  75 import System.IO
  76 import System.Exit
  77 import System.Posix.Files
  78 import System.Time
  79
  80 -- * Debug functions
  81
  82 -- | To be used only for debugging, breaks referential integrity.
  83 debug :: Show a => a -> a
  84 debug x = trace (show x) x
  85
  86 -- | Displays a modified form of the second parameter before returning
  87 -- it.
  88 debugFn :: Show b => (a -> b) -> a -> a
  89 debugFn fn x = debug (fn x) `seq` x
  90
  91 -- | Show the first parameter before returning the second one.
  92 debugXy :: Show a => a -> b -> b
  93 debugXy = seq . debug
  94
  95 -- * Miscellaneous
  96
  97 -- | Apply the function if condition holds, otherwise use default value.
  98 applyIf :: Bool -> (a -> a) -> a -> a
  99 applyIf b f x = if b then f x else x
 100
 101 -- | Comma-join a string list.
 102 commaJoin :: [String] -> String
 103 commaJoin = intercalate ","
 104
 105 -- | Split a list on a separator and return an array.
 106 sepSplit :: Eq a => a -> [a] -> [[a]]
 107 sepSplit sep s
 108   | null s    = []
 109   | null xs   = [x]
 110   | null ys   = [x,[]]
 111   | otherwise = x:sepSplit sep ys
 112   where (x, xs) = break (== sep) s
 113         ys = drop 1 xs
 114
 115 -- | Simple pluralize helper
 116 plural :: Int -> String -> String -> String
 117 plural 1 s _ = s
 118 plural _ _ p = p
 119
 120 -- | Ensure a value is quoted if needed.
 121 ensureQuoted :: String -> String
 122 ensureQuoted v = if not (all (\c -> isAlphaNum c || c == '.') v)
 123                  then '\'':v ++ "'"
 124                  else v
 125
 126 -- * Mathematical functions
 127
 128 -- Simple and slow statistical functions, please replace with better
 129 -- versions
 130
 131 -- | Standard deviation function.
 132 stdDev :: [Double] -> Double
 133 stdDev lst =
 134   -- first, calculate the list length and sum lst in a single step,
 135   -- for performance reasons
 136   let (ll', sx) = foldl' (\(rl, rs) e ->
 137                            let rl' = rl + 1
 138                                rs' = rs + e
 139                            in rl' `seq` rs' `seq` (rl', rs')) (0::Int, 0) lst
 140       ll = fromIntegral ll'::Double
 141       mv = sx / ll
 142       av = foldl' (\accu em -> let d = em - mv in accu + d * d) 0.0 lst
 143   in sqrt (av / ll) -- stddev
 144
 145 -- *  Logical functions
 146
 147 -- Avoid syntactic sugar and enhance readability. These functions are proposed
 148 -- by some for inclusion in the Prelude, and at the moment they are present
 149 -- (with various definitions) in the utility-ht package. Some rationale and
 150 -- discussion is available at <http://www.haskell.org/haskellwiki/If-then-else>
 151
 152 -- | \"if\" as a function, rather than as syntactic sugar.
 153 if' :: Bool -- ^ condition
 154     -> a    -- ^ \"then\" result
 155     -> a    -- ^ \"else\" result
 156     -> a    -- ^ \"then\" or "else" result depending on the condition
 157 if' True x _ = x
 158 if' _    _ y = y
 159
 160 -- * Parsing utility functions
 161
 162 -- | Parse results from readsPrec.
 163 parseChoices :: (Monad m, Read a) => String -> String -> [(a, String)] -> m a
 164 parseChoices _ _ ((v, ""):[]) = return v
 165 parseChoices name s ((_, e):[]) =
 166     fail $ name ++ ": leftover characters when parsing '"
 167            ++ s ++ "': '" ++ e ++ "'"
 168 parseChoices name s _ = fail $ name ++ ": cannot parse string '" ++ s ++ "'"
 169
 170 -- | Safe 'read' function returning data encapsulated in a Result.
 171 tryRead :: (Monad m, Read a) => String -> String -> m a
 172 tryRead name s = parseChoices name s $ reads s
 173
 174 -- | Format a table of strings to maintain consistent length.
 175 formatTable :: [[String]] -> [Bool] -> [[String]]
 176 formatTable vals numpos =
 177     let vtrans = transpose vals  -- transpose, so that we work on rows
 178                                  -- rather than columns
 179         mlens = map (maximum . map length) vtrans
 180         expnd = map (\(flds, isnum, ml) ->
 181                          map (\val ->
 182                                   let delta = ml - length val
 183                                       filler = replicate delta ' '
 184                                   in if delta > 0
 185                                      then if isnum
 186                                           then filler ++ val
 187                                           else val ++ filler
 188                                      else val
 189                              ) flds
 190                     ) (zip3 vtrans numpos mlens)
 191    in transpose expnd
 192
 193 -- | Constructs a printable table from given header and rows
 194 printTable :: String -> [String] -> [[String]] -> [Bool] -> String
 195 printTable lp header rows isnum =
 196   unlines . map ((++) lp . (:) ' ' . unwords) $
 197   formatTable (header:rows) isnum
 198
 199 -- | Converts a unit (e.g. m or GB) into a scaling factor.
 200 parseUnitValue :: (Monad m) => String -> m Rational
 201 parseUnitValue unit
 202   -- binary conversions first
 203   | null unit                     = return 1
 204   | unit == "m" || upper == "MIB" = return 1
 205   | unit == "g" || upper == "GIB" = return kbBinary
 206   | unit == "t" || upper == "TIB" = return $ kbBinary * kbBinary
 207   -- SI conversions
 208   | unit == "M" || upper == "MB"  = return mbFactor
 209   | unit == "G" || upper == "GB"  = return $ mbFactor * kbDecimal
 210   | unit == "T" || upper == "TB"  = return $ mbFactor * kbDecimal * kbDecimal
 211   | otherwise = fail $ "Unknown unit '" ++ unit ++ "'"
 212   where upper = map toUpper unit
 213         kbBinary = 1024 :: Rational
 214         kbDecimal = 1000 :: Rational
 215         decToBin = kbDecimal / kbBinary -- factor for 1K conversion
 216         mbFactor = decToBin * decToBin -- twice the factor for just 1K
 217
 218 -- | Tries to extract number and scale from the given string.
 219 --
 220 -- Input must be in the format NUMBER+ SPACE* [UNIT]. If no unit is
 221 -- specified, it defaults to MiB. Return value is always an integral
 222 -- value in MiB.
 223 parseUnit :: (Monad m, Integral a, Read a) => String -> m a
 224 parseUnit str =
 225   -- TODO: enhance this by splitting the unit parsing code out and
 226   -- accepting floating-point numbers
 227   case (reads str::[(Int, String)]) of
 228     [(v, suffix)] ->
 229       let unit = dropWhile (== ' ') suffix
 230       in do
 231         scaling <- parseUnitValue unit
 232         return $ truncate (fromIntegral v * scaling)
 233     _ -> fail $ "Can't parse string '" ++ str ++ "'"
 234
 235 -- | Unwraps a 'Result', exiting the program if it is a 'Bad' value,
 236 -- otherwise returning the actual contained value.
 237 exitIfBad :: String -> Result a -> IO a
 238 exitIfBad msg (Bad s) = exitErr (msg ++ ": " ++ s)
 239 exitIfBad _ (Ok v) = return v
 240
 241 -- | Exits immediately with an error message.
 242 exitErr :: String -> IO a
 243 exitErr errmsg = do
 244   hPutStrLn stderr $ "Error: " ++ errmsg
 245   exitWith (ExitFailure 1)
 246
 247 -- | Exits with an error message if the given boolean condition if true.
 248 exitWhen :: Bool -> String -> IO ()
 249 exitWhen True msg = exitErr msg
 250 exitWhen False _  = return ()
 251
 252 -- | Exits with an error message /unless/ the given boolean condition
 253 -- if true, the opposite of 'exitWhen'.
 254 exitUnless :: Bool -> String -> IO ()
 255 exitUnless cond = exitWhen (not cond)
 256
 257 -- | Unwraps a 'Result', logging a warning message and then returning a default
 258 -- value if it is a 'Bad' value, otherwise returning the actual contained value.
 259 logWarningIfBad :: String -> a -> Result a -> IO a
 260 logWarningIfBad msg defVal (Bad s) = do
 261   logWarning $ msg ++ ": " ++ s
 262   return defVal
 263 logWarningIfBad _ _ (Ok v) = return v
 264
 265 -- | Print a warning, but do not exit.
 266 warn :: String -> IO ()
 267 warn = hPutStrLn stderr . (++) "Warning: "
 268
 269 -- | Helper for 'niceSort'. Computes the key element for a given string.
 270 extractKey :: [Either Integer String]  -- ^ Current (partial) key, reversed
 271            -> String                   -- ^ Remaining string
 272            -> ([Either Integer String], String)
 273 extractKey ek [] = (reverse ek, [])
 274 extractKey ek xs@(x:_) =
 275   let (span_fn, conv_fn) = if isDigit x
 276                              then (isDigit, Left . read)
 277                              else (not . isDigit, Right)
 278       (k, rest) = span span_fn xs
 279   in extractKey (conv_fn k:ek) rest
 280
 281 {-| Sort a list of strings based on digit and non-digit groupings.
 282
 283 Given a list of names @['a1', 'a10', 'a11', 'a2']@ this function
 284 will sort the list in the logical order @['a1', 'a2', 'a10', 'a11']@.
 285
 286 The sort algorithm breaks each name in groups of either only-digits or
 287 no-digits, and sorts based on each group.
 288
 289 Internally, this is not implemented via regexes (like the Python
 290 version), but via actual splitting of the string in sequences of
 291 either digits or everything else, and converting the digit sequences
 292 in /Left Integer/ and the non-digit ones in /Right String/, at which
 293 point sorting becomes trivial due to the built-in 'Either' ordering;
 294 we only need one extra step of dropping the key at the end.
 295
 296 -}
 297 niceSort :: [String] -> [String]
 298 niceSort = niceSortKey id
 299
 300 -- | Key-version of 'niceSort'. We use 'sortBy' and @compare `on` fst@
 301 -- since we don't want to add an ordering constraint on the /a/ type,
 302 -- hence the need to only compare the first element of the /(key, a)/
 303 -- tuple.
 304 niceSortKey :: (a -> String) -> [a] -> [a]
 305 niceSortKey keyfn =
 306   map snd . sortBy (compare `on` fst) .
 307   map (\s -> (fst . extractKey [] $ keyfn s, s))
 308
 309 -- | Strip space characthers (including newline). As this is
 310 -- expensive, should only be run on small strings.
 311 rStripSpace :: String -> String
 312 rStripSpace = reverse . dropWhile isSpace . reverse
 313
 314 -- | Returns a random UUID.
 315 -- This is a Linux-specific method as it uses the /proc filesystem.
 316 newUUID :: IO String
 317 newUUID = do
 318   contents <- readFile C.randomUuidFile
 319   return $! rStripSpace $ take 128 contents
 320
 321 -- | Returns the current time as an 'Integer' representing the number
 322 -- of seconds from the Unix epoch.
 323 getCurrentTime :: IO Integer
 324 getCurrentTime = do
 325   TOD ctime _ <- getClockTime
 326   return ctime
 327
 328 -- | Returns the current time as an 'Integer' representing the number
 329 -- of microseconds from the Unix epoch (hence the need for 'Integer').
 330 getCurrentTimeUSec :: IO Integer
 331 getCurrentTimeUSec = do
 332   TOD ctime pico <- getClockTime
 333   -- pico: 10^-12, micro: 10^-6, so we have to shift seconds left and
 334   -- picoseconds right
 335   return $ ctime * 1000000 + pico `div` 1000000
 336
 337 -- | Convert a ClockTime into a (seconds-only) timestamp.
 338 clockTimeToString :: ClockTime -> String
 339 clockTimeToString (TOD t _) = show t
 340
 341 {-| Strip a prefix from a string, allowing the last character of the prefix
 342 (which is assumed to be a separator) to be absent from the string if the string
 343 terminates there.
 344
 345 \>>> chompPrefix \"foo:bar:\" \"a:b:c\"
 346 Nothing
 347
 348 \>>> chompPrefix \"foo:bar:\" \"foo:bar:baz\"
 349 Just \"baz\"
 350
 351 \>>> chompPrefix \"foo:bar:\" \"foo:bar:\"
 352 Just \"\"
 353
 354 \>>> chompPrefix \"foo:bar:\" \"foo:bar\"
 355 Just \"\"
 356
 357 \>>> chompPrefix \"foo:bar:\" \"foo:barbaz\"
 358 Nothing
 359 -}
 360 chompPrefix :: String -> String -> Maybe String
 361 chompPrefix pfx str =
 362   if pfx `isPrefixOf` str || str == init pfx
 363     then Just $ drop (length pfx) str
 364     else Nothing
 365
 366 -- | Breaks a string in lines with length \<= maxWidth.
 367 --
 368 -- NOTE: The split is OK if:
 369 --
 370 -- * It doesn't break a word, i.e. the next line begins with space
 371 --   (@isSpace . head $ rest@) or the current line ends with space
 372 --   (@null revExtra@);
 373 --
 374 -- * It breaks a very big word that doesn't fit anyway (@null revLine@).
 375 wrap :: Int      -- ^ maxWidth
 376      -> String   -- ^ string that needs wrapping
 377      -> [String] -- ^ string \"broken\" in lines
 378 wrap maxWidth = filter (not . null) . map trim . wrap0
 379   where wrap0 :: String -> [String]
 380         wrap0 text
 381           | length text <= maxWidth = [text]
 382           | isSplitOK               = line : wrap0 rest
 383           | otherwise               = line' : wrap0 rest'
 384           where (line, rest) = splitAt maxWidth text
 385                 (revExtra, revLine) = break isSpace . reverse $ line
 386                 (line', rest') = (reverse revLine, reverse revExtra ++ rest)
 387                 isSplitOK =
 388                   null revLine || null revExtra || startsWithSpace rest
 389                 startsWithSpace (x:_) = isSpace x
 390                 startsWithSpace _     = False
 391
 392 -- | Removes surrounding whitespace. Should only be used in small
 393 -- strings.
 394 trim :: String -> String
 395 trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 396
 397 -- | A safer head version, with a default value.
 398 defaultHead :: a -> [a] -> a
 399 defaultHead def []    = def
 400 defaultHead _   (x:_) = x
 401
 402 -- | A 'head' version in the I/O monad, for validating parameters
 403 -- without which we cannot continue.
 404 exitIfEmpty :: String -> [a] -> IO a
 405 exitIfEmpty _ (x:_) = return x
 406 exitIfEmpty s []    = exitErr s
 407
 408 -- | Split an 'Either' list into two separate lists (containing the
 409 -- 'Left' and 'Right' elements, plus a \"trail\" list that allows
 410 -- recombination later.
 411 --
 412 -- This is splitter; for recombination, look at 'recombineEithers'.
 413 -- The sum of \"left\" and \"right\" lists should be equal to the
 414 -- original list length, and the trail list should be the same length
 415 -- as well. The entries in the resulting lists are reversed in
 416 -- comparison with the original list.
 417 splitEithers :: [Either a b] -> ([a], [b], [Bool])
 418 splitEithers = foldl' splitter ([], [], [])
 419   where splitter (l, r, t) e =
 420           case e of
 421             Left  v -> (v:l, r, False:t)
 422             Right v -> (l, v:r, True:t)
 423
 424 -- | Recombines two \"left\" and \"right\" lists using a \"trail\"
 425 -- list into a single 'Either' list.
 426 --
 427 -- This is the counterpart to 'splitEithers'. It does the opposite
 428 -- transformation, and the output list will be the reverse of the
 429 -- input lists. Since 'splitEithers' also reverses the lists, calling
 430 -- these together will result in the original list.
 431 --
 432 -- Mismatches in the structure of the lists (e.g. inconsistent
 433 -- lengths) are represented via 'Bad'; normally this function should
 434 -- not fail, if lists are passed as generated by 'splitEithers'.
 435 recombineEithers :: (Show a, Show b) =>
 436                     [a] -> [b] -> [Bool] -> Result [Either a b]
 437 recombineEithers lefts rights trail =
 438   foldM recombiner ([], lefts, rights) trail >>= checker
 439     where checker (eithers, [], []) = Ok eithers
 440           checker (_, lefts', rights') =
 441             Bad $ "Inconsistent results after recombination, l'=" ++
 442                 show lefts' ++ ", r'=" ++ show rights'
 443           recombiner (es, l:ls, rs) False = Ok (Left l:es,  ls, rs)
 444           recombiner (es, ls, r:rs) True  = Ok (Right r:es, ls, rs)
 445           recombiner (_,  ls, rs) t = Bad $ "Inconsistent trail log: l=" ++
 446                                       show ls ++ ", r=" ++ show rs ++ ",t=" ++
 447                                       show t
 448
 449 -- | Set the owner and the group of a file (given as names, not numeric id).
 450 setOwnerAndGroupFromNames :: FilePath -> GanetiDaemon -> GanetiGroup -> IO ()
 451 setOwnerAndGroupFromNames filename daemon dGroup = do
 452   -- TODO: it would be nice to rework this (or getEnts) so that runtimeEnts
 453   -- is read only once per daemon startup, and then cached for further usage.
 454   runtimeEnts <- getEnts
 455   ents <- exitIfBad "Can't find required user/groups" runtimeEnts
 456   -- note: we use directly ! as lookup failures shouldn't happen, due
 457   -- to the map construction
 458   let uid = fst ents M.! daemon
 459   let gid = snd ents M.! dGroup
 460   setOwnerAndGroup filename uid gid