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