Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Utils.hs @ a7f0953a

History | View | Annotate | Download (10.5 kB)

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