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

   1 {-| Utility functions. -}
   2
   3 {-
   4
   5 Copyright (C) 2009, 2010, 2011, 2012 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   ) where
  47
  48 import Data.Char (toUpper, isAlphaNum, isDigit)
  49 import Data.Function (on)
  50 import Data.List
  51
  52 import Debug.Trace
  53
  54 import Ganeti.BasicTypes
  55 import System.IO
  56 import System.Exit
  57
  58 -- * Debug functions
  59
  60 -- | To be used only for debugging, breaks referential integrity.
  61 debug :: Show a => a -> a
  62 debug x = trace (show x) x
  63
  64 -- | Displays a modified form of the second parameter before returning
  65 -- it.
  66 debugFn :: Show b => (a -> b) -> a -> a
  67 debugFn fn x = debug (fn x) `seq` x
  68
  69 -- | Show the first parameter before returning the second one.
  70 debugXy :: Show a => a -> b -> b
  71 debugXy = seq . debug
  72
  73 -- * Miscellaneous
  74
  75 -- | Apply the function if condition holds, otherwise use default value.
  76 applyIf :: Bool -> (a -> a) -> a -> a
  77 applyIf b f x = if b then f x else x
  78
  79 -- | Comma-join a string list.
  80 commaJoin :: [String] -> String
  81 commaJoin = intercalate ","
  82
  83 -- | Split a list on a separator and return an array.
  84 sepSplit :: Eq a => a -> [a] -> [[a]]
  85 sepSplit sep s
  86   | null s    = []
  87   | null xs   = [x]
  88   | null ys   = [x,[]]
  89   | otherwise = x:sepSplit sep ys
  90   where (x, xs) = break (== sep) s
  91         ys = drop 1 xs
  92
  93 -- | Simple pluralize helper
  94 plural :: Int -> String -> String -> String
  95 plural 1 s _ = s
  96 plural _ _ p = p
  97
  98 -- | Ensure a value is quoted if needed.
  99 ensureQuoted :: String -> String
 100 ensureQuoted v = if not (all (\c -> isAlphaNum c || c == '.') v)
 101                  then '\'':v ++ "'"
 102                  else v
 103
 104 -- * Mathematical functions
 105
 106 -- Simple and slow statistical functions, please replace with better
 107 -- versions
 108
 109 -- | Standard deviation function.
 110 stdDev :: [Double] -> Double
 111 stdDev lst =
 112   -- first, calculate the list length and sum lst in a single step,
 113   -- for performance reasons
 114   let (ll', sx) = foldl' (\(rl, rs) e ->
 115                            let rl' = rl + 1
 116                                rs' = rs + e
 117                            in rl' `seq` rs' `seq` (rl', rs')) (0::Int, 0) lst
 118       ll = fromIntegral ll'::Double
 119       mv = sx / ll
 120       av = foldl' (\accu em -> let d = em - mv in accu + d * d) 0.0 lst
 121   in sqrt (av / ll) -- stddev
 122
 123 -- *  Logical functions
 124
 125 -- Avoid syntactic sugar and enhance readability. These functions are proposed
 126 -- by some for inclusion in the Prelude, and at the moment they are present
 127 -- (with various definitions) in the utility-ht package. Some rationale and
 128 -- discussion is available at <http://www.haskell.org/haskellwiki/If-then-else>
 129
 130 -- | \"if\" as a function, rather than as syntactic sugar.
 131 if' :: Bool -- ^ condition
 132     -> a    -- ^ \"then\" result
 133     -> a    -- ^ \"else\" result
 134     -> a    -- ^ \"then\" or "else" result depending on the condition
 135 if' True x _ = x
 136 if' _    _ y = y
 137
 138 -- * Parsing utility functions
 139
 140 -- | Parse results from readsPrec.
 141 parseChoices :: (Monad m, Read a) => String -> String -> [(a, String)] -> m a
 142 parseChoices _ _ ((v, ""):[]) = return v
 143 parseChoices name s ((_, e):[]) =
 144     fail $ name ++ ": leftover characters when parsing '"
 145            ++ s ++ "': '" ++ e ++ "'"
 146 parseChoices name s _ = fail $ name ++ ": cannot parse string '" ++ s ++ "'"
 147
 148 -- | Safe 'read' function returning data encapsulated in a Result.
 149 tryRead :: (Monad m, Read a) => String -> String -> m a
 150 tryRead name s = parseChoices name s $ reads s
 151
 152 -- | Format a table of strings to maintain consistent length.
 153 formatTable :: [[String]] -> [Bool] -> [[String]]
 154 formatTable vals numpos =
 155     let vtrans = transpose vals  -- transpose, so that we work on rows
 156                                  -- rather than columns
 157         mlens = map (maximum . map length) vtrans
 158         expnd = map (\(flds, isnum, ml) ->
 159                          map (\val ->
 160                                   let delta = ml - length val
 161                                       filler = replicate delta ' '
 162                                   in if delta > 0
 163                                      then if isnum
 164                                           then filler ++ val
 165                                           else val ++ filler
 166                                      else val
 167                              ) flds
 168                     ) (zip3 vtrans numpos mlens)
 169    in transpose expnd
 170
 171 -- | Constructs a printable table from given header and rows
 172 printTable :: String -> [String] -> [[String]] -> [Bool] -> String
 173 printTable lp header rows isnum =
 174   unlines . map ((++) lp . (:) ' ' . unwords) $
 175   formatTable (header:rows) isnum
 176
 177 -- | Converts a unit (e.g. m or GB) into a scaling factor.
 178 parseUnitValue :: (Monad m) => String -> m Rational
 179 parseUnitValue unit
 180   -- binary conversions first
 181   | null unit                     = return 1
 182   | unit == "m" || upper == "MIB" = return 1
 183   | unit == "g" || upper == "GIB" = return kbBinary
 184   | unit == "t" || upper == "TIB" = return $ kbBinary * kbBinary
 185   -- SI conversions
 186   | unit == "M" || upper == "MB"  = return mbFactor
 187   | unit == "G" || upper == "GB"  = return $ mbFactor * kbDecimal
 188   | unit == "T" || upper == "TB"  = return $ mbFactor * kbDecimal * kbDecimal
 189   | otherwise = fail $ "Unknown unit '" ++ unit ++ "'"
 190   where upper = map toUpper unit
 191         kbBinary = 1024 :: Rational
 192         kbDecimal = 1000 :: Rational
 193         decToBin = kbDecimal / kbBinary -- factor for 1K conversion
 194         mbFactor = decToBin * decToBin -- twice the factor for just 1K
 195
 196 -- | Tries to extract number and scale from the given string.
 197 --
 198 -- Input must be in the format NUMBER+ SPACE* [UNIT]. If no unit is
 199 -- specified, it defaults to MiB. Return value is always an integral
 200 -- value in MiB.
 201 parseUnit :: (Monad m, Integral a, Read a) => String -> m a
 202 parseUnit str =
 203   -- TODO: enhance this by splitting the unit parsing code out and
 204   -- accepting floating-point numbers
 205   case (reads str::[(Int, String)]) of
 206     [(v, suffix)] ->
 207       let unit = dropWhile (== ' ') suffix
 208       in do
 209         scaling <- parseUnitValue unit
 210         return $ truncate (fromIntegral v * scaling)
 211     _ -> fail $ "Can't parse string '" ++ str ++ "'"
 212
 213 -- | Unwraps a 'Result', exiting the program if it is a 'Bad' value,
 214 -- otherwise returning the actual contained value.
 215 exitIfBad :: String -> Result a -> IO a
 216 exitIfBad msg (Bad s) = exitErr (msg ++ ": " ++ s)
 217 exitIfBad _ (Ok v) = return v
 218
 219 -- | Exits immediately with an error message.
 220 exitErr :: String -> IO a
 221 exitErr errmsg = do
 222   hPutStrLn stderr $ "Error: " ++ errmsg
 223   exitWith (ExitFailure 1)
 224
 225 -- | Exits with an error message if the given boolean condition if true.
 226 exitWhen :: Bool -> String -> IO ()
 227 exitWhen True msg = exitErr msg
 228 exitWhen False _  = return ()
 229
 230 -- | Exits with an error message /unless/ the given boolean condition
 231 -- if true, the opposite of 'exitWhen'.
 232 exitUnless :: Bool -> String -> IO ()
 233 exitUnless cond = exitWhen (not cond)
 234
 235 -- | Helper for 'niceSort'. Computes the key element for a given string.
 236 extractKey :: [Either Integer String]  -- ^ Current (partial) key, reversed
 237            -> String                   -- ^ Remaining string
 238            -> ([Either Integer String], String)
 239 extractKey ek [] = (reverse ek, [])
 240 extractKey ek xs@(x:_) =
 241   let (span_fn, conv_fn) = if isDigit x
 242                              then (isDigit, Left . read)
 243                              else (not . isDigit, Right)
 244       (k, rest) = span span_fn xs
 245   in extractKey (conv_fn k:ek) rest
 246
 247 {-| Sort a list of strings based on digit and non-digit groupings.
 248
 249 Given a list of names @['a1', 'a10', 'a11', 'a2']@ this function
 250 will sort the list in the logical order @['a1', 'a2', 'a10', 'a11']@.
 251
 252 The sort algorithm breaks each name in groups of either only-digits or
 253 no-digits, and sorts based on each group.
 254
 255 Internally, this is not implemented via regexes (like the Python
 256 version), but via actual splitting of the string in sequences of
 257 either digits or everything else, and converting the digit sequences
 258 in /Left Integer/ and the non-digit ones in /Right String/, at which
 259 point sorting becomes trivial due to the built-in 'Either' ordering;
 260 we only need one extra step of dropping the key at the end.
 261
 262 -}
 263 niceSort :: [String] -> [String]
 264 niceSort = map snd . sort . map (\s -> (fst $ extractKey [] s, s))
 265
 266 -- | Key-version of 'niceSort'. We use 'sortBy' and @compare `on` fst@
 267 -- since we don't want to add an ordering constraint on the /a/ type,
 268 -- hence the need to only compare the first element of the /(key, a)/
 269 -- tuple.
 270 niceSortKey :: (a -> String) -> [a] -> [a]
 271 niceSortKey keyfn =
 272   map snd . sortBy (compare `on` fst) .
 273   map (\s -> (fst . extractKey [] $ keyfn s, s))