Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Utils.hs @ a39cd547

History | View | Annotate | Download (15.6 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
  , getCurrentTime
49
  , getCurrentTimeUSec
50
  , clockTimeToString
51
  , chompPrefix
52
  , warn
53
  , wrap
54
  , trim
55
  , defaultHead
56
  , exitIfEmpty
57
  , splitEithers
58
  , recombineEithers
59
  , setOwnerAndGroupFromNames
60
  ) where
61

    
62
import Data.Char (toUpper, isAlphaNum, isDigit, isSpace)
63
import Data.Function (on)
64
import Data.List
65
import qualified Data.Map as M
66
import Control.Monad (foldM)
67

    
68
import Debug.Trace
69

    
70
import Ganeti.BasicTypes
71
import qualified Ganeti.Constants as C
72
import Ganeti.Runtime
73
import System.IO
74
import System.Exit
75
import System.Posix.Files
76
import System.Time
77

    
78
-- * Debug functions
79

    
80
-- | To be used only for debugging, breaks referential integrity.
81
debug :: Show a => a -> a
82
debug x = trace (show x) x
83

    
84
-- | Displays a modified form of the second parameter before returning
85
-- it.
86
debugFn :: Show b => (a -> b) -> a -> a
87
debugFn fn x = debug (fn x) `seq` x
88

    
89
-- | Show the first parameter before returning the second one.
90
debugXy :: Show a => a -> b -> b
91
debugXy = seq . debug
92

    
93
-- * Miscellaneous
94

    
95
-- | Apply the function if condition holds, otherwise use default value.
96
applyIf :: Bool -> (a -> a) -> a -> a
97
applyIf b f x = if b then f x else x
98

    
99
-- | Comma-join a string list.
100
commaJoin :: [String] -> String
101
commaJoin = intercalate ","
102

    
103
-- | Split a list on a separator and return an array.
104
sepSplit :: Eq a => a -> [a] -> [[a]]
105
sepSplit sep s
106
  | null s    = []
107
  | null xs   = [x]
108
  | null ys   = [x,[]]
109
  | otherwise = x:sepSplit sep ys
110
  where (x, xs) = break (== sep) s
111
        ys = drop 1 xs
112

    
113
-- | Simple pluralize helper
114
plural :: Int -> String -> String -> String
115
plural 1 s _ = s
116
plural _ _ p = p
117

    
118
-- | Ensure a value is quoted if needed.
119
ensureQuoted :: String -> String
120
ensureQuoted v = if not (all (\c -> isAlphaNum c || c == '.') v)
121
                 then '\'':v ++ "'"
122
                 else v
123

    
124
-- * Mathematical functions
125

    
126
-- Simple and slow statistical functions, please replace with better
127
-- versions
128

    
129
-- | Standard deviation function.
130
stdDev :: [Double] -> Double
131
stdDev lst =
132
  -- first, calculate the list length and sum lst in a single step,
133
  -- for performance reasons
134
  let (ll', sx) = foldl' (\(rl, rs) e ->
135
                           let rl' = rl + 1
136
                               rs' = rs + e
137
                           in rl' `seq` rs' `seq` (rl', rs')) (0::Int, 0) lst
138
      ll = fromIntegral ll'::Double
139
      mv = sx / ll
140
      av = foldl' (\accu em -> let d = em - mv in accu + d * d) 0.0 lst
141
  in sqrt (av / ll) -- stddev
142

    
143
-- *  Logical functions
144

    
145
-- Avoid syntactic sugar and enhance readability. These functions are proposed
146
-- by some for inclusion in the Prelude, and at the moment they are present
147
-- (with various definitions) in the utility-ht package. Some rationale and
148
-- discussion is available at <http://www.haskell.org/haskellwiki/If-then-else>
149

    
150
-- | \"if\" as a function, rather than as syntactic sugar.
151
if' :: Bool -- ^ condition
152
    -> a    -- ^ \"then\" result
153
    -> a    -- ^ \"else\" result
154
    -> a    -- ^ \"then\" or "else" result depending on the condition
155
if' True x _ = x
156
if' _    _ y = y
157

    
158
-- * Parsing utility functions
159

    
160
-- | Parse results from readsPrec.
161
parseChoices :: (Monad m, Read a) => String -> String -> [(a, String)] -> m a
162
parseChoices _ _ ((v, ""):[]) = return v
163
parseChoices name s ((_, e):[]) =
164
    fail $ name ++ ": leftover characters when parsing '"
165
           ++ s ++ "': '" ++ e ++ "'"
166
parseChoices name s _ = fail $ name ++ ": cannot parse string '" ++ s ++ "'"
167

    
168
-- | Safe 'read' function returning data encapsulated in a Result.
169
tryRead :: (Monad m, Read a) => String -> String -> m a
170
tryRead name s = parseChoices name s $ reads s
171

    
172
-- | Format a table of strings to maintain consistent length.
173
formatTable :: [[String]] -> [Bool] -> [[String]]
174
formatTable vals numpos =
175
    let vtrans = transpose vals  -- transpose, so that we work on rows
176
                                 -- rather than columns
177
        mlens = map (maximum . map length) vtrans
178
        expnd = map (\(flds, isnum, ml) ->
179
                         map (\val ->
180
                                  let delta = ml - length val
181
                                      filler = replicate delta ' '
182
                                  in if delta > 0
183
                                     then if isnum
184
                                          then filler ++ val
185
                                          else val ++ filler
186
                                     else val
187
                             ) flds
188
                    ) (zip3 vtrans numpos mlens)
189
   in transpose expnd
190

    
191
-- | Constructs a printable table from given header and rows
192
printTable :: String -> [String] -> [[String]] -> [Bool] -> String
193
printTable lp header rows isnum =
194
  unlines . map ((++) lp . (:) ' ' . unwords) $
195
  formatTable (header:rows) isnum
196

    
197
-- | Converts a unit (e.g. m or GB) into a scaling factor.
198
parseUnitValue :: (Monad m) => String -> m Rational
199
parseUnitValue unit
200
  -- binary conversions first
201
  | null unit                     = return 1
202
  | unit == "m" || upper == "MIB" = return 1
203
  | unit == "g" || upper == "GIB" = return kbBinary
204
  | unit == "t" || upper == "TIB" = return $ kbBinary * kbBinary
205
  -- SI conversions
206
  | unit == "M" || upper == "MB"  = return mbFactor
207
  | unit == "G" || upper == "GB"  = return $ mbFactor * kbDecimal
208
  | unit == "T" || upper == "TB"  = return $ mbFactor * kbDecimal * kbDecimal
209
  | otherwise = fail $ "Unknown unit '" ++ unit ++ "'"
210
  where upper = map toUpper unit
211
        kbBinary = 1024 :: Rational
212
        kbDecimal = 1000 :: Rational
213
        decToBin = kbDecimal / kbBinary -- factor for 1K conversion
214
        mbFactor = decToBin * decToBin -- twice the factor for just 1K
215

    
216
-- | Tries to extract number and scale from the given string.
217
--
218
-- Input must be in the format NUMBER+ SPACE* [UNIT]. If no unit is
219
-- specified, it defaults to MiB. Return value is always an integral
220
-- value in MiB.
221
parseUnit :: (Monad m, Integral a, Read a) => String -> m a
222
parseUnit str =
223
  -- TODO: enhance this by splitting the unit parsing code out and
224
  -- accepting floating-point numbers
225
  case (reads str::[(Int, String)]) of
226
    [(v, suffix)] ->
227
      let unit = dropWhile (== ' ') suffix
228
      in do
229
        scaling <- parseUnitValue unit
230
        return $ truncate (fromIntegral v * scaling)
231
    _ -> fail $ "Can't parse string '" ++ str ++ "'"
232

    
233
-- | Unwraps a 'Result', exiting the program if it is a 'Bad' value,
234
-- otherwise returning the actual contained value.
235
exitIfBad :: String -> Result a -> IO a
236
exitIfBad msg (Bad s) = exitErr (msg ++ ": " ++ s)
237
exitIfBad _ (Ok v) = return v
238

    
239
-- | Exits immediately with an error message.
240
exitErr :: String -> IO a
241
exitErr errmsg = do
242
  hPutStrLn stderr $ "Error: " ++ errmsg
243
  exitWith (ExitFailure 1)
244

    
245
-- | Exits with an error message if the given boolean condition if true.
246
exitWhen :: Bool -> String -> IO ()
247
exitWhen True msg = exitErr msg
248
exitWhen False _  = return ()
249

    
250
-- | Exits with an error message /unless/ the given boolean condition
251
-- if true, the opposite of 'exitWhen'.
252
exitUnless :: Bool -> String -> IO ()
253
exitUnless cond = exitWhen (not cond)
254

    
255
-- | Print a warning, but do not exit.
256
warn :: String -> IO ()
257
warn = hPutStrLn stderr . (++) "Warning: "
258

    
259
-- | Helper for 'niceSort'. Computes the key element for a given string.
260
extractKey :: [Either Integer String]  -- ^ Current (partial) key, reversed
261
           -> String                   -- ^ Remaining string
262
           -> ([Either Integer String], String)
263
extractKey ek [] = (reverse ek, [])
264
extractKey ek xs@(x:_) =
265
  let (span_fn, conv_fn) = if isDigit x
266
                             then (isDigit, Left . read)
267
                             else (not . isDigit, Right)
268
      (k, rest) = span span_fn xs
269
  in extractKey (conv_fn k:ek) rest
270

    
271
{-| Sort a list of strings based on digit and non-digit groupings.
272

    
273
Given a list of names @['a1', 'a10', 'a11', 'a2']@ this function
274
will sort the list in the logical order @['a1', 'a2', 'a10', 'a11']@.
275

    
276
The sort algorithm breaks each name in groups of either only-digits or
277
no-digits, and sorts based on each group.
278

    
279
Internally, this is not implemented via regexes (like the Python
280
version), but via actual splitting of the string in sequences of
281
either digits or everything else, and converting the digit sequences
282
in /Left Integer/ and the non-digit ones in /Right String/, at which
283
point sorting becomes trivial due to the built-in 'Either' ordering;
284
we only need one extra step of dropping the key at the end.
285

    
286
-}
287
niceSort :: [String] -> [String]
288
niceSort = niceSortKey id
289

    
290
-- | Key-version of 'niceSort'. We use 'sortBy' and @compare `on` fst@
291
-- since we don't want to add an ordering constraint on the /a/ type,
292
-- hence the need to only compare the first element of the /(key, a)/
293
-- tuple.
294
niceSortKey :: (a -> String) -> [a] -> [a]
295
niceSortKey keyfn =
296
  map snd . sortBy (compare `on` fst) .
297
  map (\s -> (fst . extractKey [] $ keyfn s, s))
298

    
299
-- | Strip space characthers (including newline). As this is
300
-- expensive, should only be run on small strings.
301
rStripSpace :: String -> String
302
rStripSpace = reverse . dropWhile isSpace . reverse
303

    
304
-- | Returns a random UUID.
305
-- This is a Linux-specific method as it uses the /proc filesystem.
306
newUUID :: IO String
307
newUUID = do
308
  contents <- readFile C.randomUuidFile
309
  return $! rStripSpace $ take 128 contents
310

    
311
-- | Returns the current time as an 'Integer' representing the number
312
-- of seconds from the Unix epoch.
313
getCurrentTime :: IO Integer
314
getCurrentTime = do
315
  TOD ctime _ <- getClockTime
316
  return ctime
317

    
318
-- | Returns the current time as an 'Integer' representing the number
319
-- of microseconds from the Unix epoch (hence the need for 'Integer').
320
getCurrentTimeUSec :: IO Integer
321
getCurrentTimeUSec = do
322
  TOD ctime pico <- getClockTime
323
  -- pico: 10^-12, micro: 10^-6, so we have to shift seconds left and
324
  -- picoseconds right
325
  return $ ctime * 1000000 + pico `div` 1000000
326

    
327
-- | Convert a ClockTime into a (seconds-only) timestamp.
328
clockTimeToString :: ClockTime -> String
329
clockTimeToString (TOD t _) = show t
330

    
331
{-| Strip a prefix from a string, allowing the last character of the prefix
332
(which is assumed to be a separator) to be absent from the string if the string
333
terminates there.
334

    
335
\>>> chompPrefix \"foo:bar:\" \"a:b:c\"
336
Nothing
337

    
338
\>>> chompPrefix \"foo:bar:\" \"foo:bar:baz\"
339
Just \"baz\"
340

    
341
\>>> chompPrefix \"foo:bar:\" \"foo:bar:\"
342
Just \"\"
343

    
344
\>>> chompPrefix \"foo:bar:\" \"foo:bar\"
345
Just \"\"
346

    
347
\>>> chompPrefix \"foo:bar:\" \"foo:barbaz\"
348
Nothing
349
-}
350
chompPrefix :: String -> String -> Maybe String
351
chompPrefix pfx str =
352
  if pfx `isPrefixOf` str || str == init pfx
353
    then Just $ drop (length pfx) str
354
    else Nothing
355

    
356
-- | Breaks a string in lines with length \<= maxWidth.
357
--
358
-- NOTE: The split is OK if:
359
--
360
-- * It doesn't break a word, i.e. the next line begins with space
361
--   (@isSpace . head $ rest@) or the current line ends with space
362
--   (@null revExtra@);
363
--
364
-- * It breaks a very big word that doesn't fit anyway (@null revLine@).
365
wrap :: Int      -- ^ maxWidth
366
     -> String   -- ^ string that needs wrapping
367
     -> [String] -- ^ string \"broken\" in lines
368
wrap maxWidth = filter (not . null) . map trim . wrap0
369
  where wrap0 :: String -> [String]
370
        wrap0 text
371
          | length text <= maxWidth = [text]
372
          | isSplitOK               = line : wrap0 rest
373
          | otherwise               = line' : wrap0 rest'
374
          where (line, rest) = splitAt maxWidth text
375
                (revExtra, revLine) = break isSpace . reverse $ line
376
                (line', rest') = (reverse revLine, reverse revExtra ++ rest)
377
                isSplitOK =
378
                  null revLine || null revExtra || startsWithSpace rest
379
                startsWithSpace (x:_) = isSpace x
380
                startsWithSpace _     = False
381

    
382
-- | Removes surrounding whitespace. Should only be used in small
383
-- strings.
384
trim :: String -> String
385
trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
386

    
387
-- | A safer head version, with a default value.
388
defaultHead :: a -> [a] -> a
389
defaultHead def []    = def
390
defaultHead _   (x:_) = x
391

    
392
-- | A 'head' version in the I/O monad, for validating parameters
393
-- without which we cannot continue.
394
exitIfEmpty :: String -> [a] -> IO a
395
exitIfEmpty _ (x:_) = return x
396
exitIfEmpty s []    = exitErr s
397

    
398
-- | Split an 'Either' list into two separate lists (containing the
399
-- 'Left' and 'Right' elements, plus a \"trail\" list that allows
400
-- recombination later.
401
--
402
-- This is splitter; for recombination, look at 'recombineEithers'.
403
-- The sum of \"left\" and \"right\" lists should be equal to the
404
-- original list length, and the trail list should be the same length
405
-- as well. The entries in the resulting lists are reversed in
406
-- comparison with the original list.
407
splitEithers :: [Either a b] -> ([a], [b], [Bool])
408
splitEithers = foldl' splitter ([], [], [])
409
  where splitter (l, r, t) e =
410
          case e of
411
            Left  v -> (v:l, r, False:t)
412
            Right v -> (l, v:r, True:t)
413

    
414
-- | Recombines two \"left\" and \"right\" lists using a \"trail\"
415
-- list into a single 'Either' list.
416
--
417
-- This is the counterpart to 'splitEithers'. It does the opposite
418
-- transformation, and the output list will be the reverse of the
419
-- input lists. Since 'splitEithers' also reverses the lists, calling
420
-- these together will result in the original list.
421
--
422
-- Mismatches in the structure of the lists (e.g. inconsistent
423
-- lengths) are represented via 'Bad'; normally this function should
424
-- not fail, if lists are passed as generated by 'splitEithers'.
425
recombineEithers :: (Show a, Show b) =>
426
                    [a] -> [b] -> [Bool] -> Result [Either a b]
427
recombineEithers lefts rights trail =
428
  foldM recombiner ([], lefts, rights) trail >>= checker
429
    where checker (eithers, [], []) = Ok eithers
430
          checker (_, lefts', rights') =
431
            Bad $ "Inconsistent results after recombination, l'=" ++
432
                show lefts' ++ ", r'=" ++ show rights'
433
          recombiner (es, l:ls, rs) False = Ok (Left l:es,  ls, rs)
434
          recombiner (es, ls, r:rs) True  = Ok (Right r:es, ls, rs)
435
          recombiner (_,  ls, rs) t = Bad $ "Inconsistent trail log: l=" ++
436
                                      show ls ++ ", r=" ++ show rs ++ ",t=" ++
437
                                      show t
438

    
439
-- | Set the owner and the group of a file (given as names, not numeric id).
440
setOwnerAndGroupFromNames :: FilePath -> GanetiDaemon -> GanetiGroup -> IO ()
441
setOwnerAndGroupFromNames filename daemon dGroup = do
442
  -- TODO: it would be nice to rework this (or getEnts) so that runtimeEnts
443
  -- is read only once per daemon startup, and then cached for further usage.
444
  runtimeEnts <- getEnts
445
  ents <- exitIfBad "Can't find required user/groups" runtimeEnts
446
  -- note: we use directly ! as lookup failures shouldn't happen, due
447
  -- to the map construction
448
  let uid = fst ents M.! daemon
449
  let gid = snd ents M.! dGroup
450
  setOwnerAndGroup filename uid gid