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