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