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