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