Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Utils.hs @ 88b58ed6

History | View | Annotate | Download (16.9 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
  , logWarningIfBad
47
  , rStripSpace
48
  , newUUID
49
  , getCurrentTime
50
  , getCurrentTimeUSec
51
  , clockTimeToString
52
  , chompPrefix
53
  , warn
54
  , wrap
55
  , trim
56
  , defaultHead
57
  , exitIfEmpty
58
  , splitEithers
59
  , recombineEithers
60
  , resolveAddr
61
  , setOwnerAndGroupFromNames
62
  , formatOrdinal
63
  ) where
64

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

    
71
import Debug.Trace
72
import Network.Socket
73

    
74
import Ganeti.BasicTypes
75
import qualified Ganeti.ConstantUtils as ConstantUtils
76
import Ganeti.Logging
77
import Ganeti.Runtime
78
import System.IO
79
import System.Exit
80
import System.Posix.Files
81
import System.Time
82

    
83
-- * Debug functions
84

    
85
-- | To be used only for debugging, breaks referential integrity.
86
debug :: Show a => a -> a
87
debug x = trace (show x) x
88

    
89
-- | Displays a modified form of the second parameter before returning
90
-- it.
91
debugFn :: Show b => (a -> b) -> a -> a
92
debugFn fn x = debug (fn x) `seq` x
93

    
94
-- | Show the first parameter before returning the second one.
95
debugXy :: Show a => a -> b -> b
96
debugXy = seq . debug
97

    
98
-- * Miscellaneous
99

    
100
-- | Apply the function if condition holds, otherwise use default value.
101
applyIf :: Bool -> (a -> a) -> a -> a
102
applyIf b f x = if b then f x else x
103

    
104
-- | Comma-join a string list.
105
commaJoin :: [String] -> String
106
commaJoin = intercalate ","
107

    
108
-- | Split a list on a separator and return an array.
109
sepSplit :: Eq a => a -> [a] -> [[a]]
110
sepSplit sep s
111
  | null s    = []
112
  | null xs   = [x]
113
  | null ys   = [x,[]]
114
  | otherwise = x:sepSplit sep ys
115
  where (x, xs) = break (== sep) s
116
        ys = drop 1 xs
117

    
118
-- | Simple pluralize helper
119
plural :: Int -> String -> String -> String
120
plural 1 s _ = s
121
plural _ _ p = p
122

    
123
-- | Ensure a value is quoted if needed.
124
ensureQuoted :: String -> String
125
ensureQuoted v = if not (all (\c -> isAlphaNum c || c == '.') v)
126
                 then '\'':v ++ "'"
127
                 else v
128

    
129
-- * Mathematical functions
130

    
131
-- Simple and slow statistical functions, please replace with better
132
-- versions
133

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

    
148
-- *  Logical functions
149

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

    
155
-- | \"if\" as a function, rather than as syntactic sugar.
156
if' :: Bool -- ^ condition
157
    -> a    -- ^ \"then\" result
158
    -> a    -- ^ \"else\" result
159
    -> a    -- ^ \"then\" or "else" result depending on the condition
160
if' True x _ = x
161
if' _    _ y = y
162

    
163
-- * Parsing utility functions
164

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

    
173
-- | Safe 'read' function returning data encapsulated in a Result.
174
tryRead :: (Monad m, Read a) => String -> String -> m a
175
tryRead name s = parseChoices name s $ reads s
176

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

    
196
-- | Constructs a printable table from given header and rows
197
printTable :: String -> [String] -> [[String]] -> [Bool] -> String
198
printTable lp header rows isnum =
199
  unlines . map ((++) lp . (:) ' ' . unwords) $
200
  formatTable (header:rows) isnum
201

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

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

    
238
-- | Unwraps a 'Result', exiting the program if it is a 'Bad' value,
239
-- otherwise returning the actual contained value.
240
exitIfBad :: String -> Result a -> IO a
241
exitIfBad msg (Bad s) = exitErr (msg ++ ": " ++ s)
242
exitIfBad _ (Ok v) = return v
243

    
244
-- | Exits immediately with an error message.
245
exitErr :: String -> IO a
246
exitErr errmsg = do
247
  hPutStrLn stderr $ "Error: " ++ errmsg
248
  exitWith (ExitFailure 1)
249

    
250
-- | Exits with an error message if the given boolean condition if true.
251
exitWhen :: Bool -> String -> IO ()
252
exitWhen True msg = exitErr msg
253
exitWhen False _  = return ()
254

    
255
-- | Exits with an error message /unless/ the given boolean condition
256
-- if true, the opposite of 'exitWhen'.
257
exitUnless :: Bool -> String -> IO ()
258
exitUnless cond = exitWhen (not cond)
259

    
260
-- | Unwraps a 'Result', logging a warning message and then returning a default
261
-- value if it is a 'Bad' value, otherwise returning the actual contained value.
262
logWarningIfBad :: String -> a -> Result a -> IO a
263
logWarningIfBad msg defVal (Bad s) = do
264
  logWarning $ msg ++ ": " ++ s
265
  return defVal
266
logWarningIfBad _ _ (Ok v) = return v
267

    
268
-- | Print a warning, but do not exit.
269
warn :: String -> IO ()
270
warn = hPutStrLn stderr . (++) "Warning: "
271

    
272
-- | Helper for 'niceSort'. Computes the key element for a given string.
273
extractKey :: [Either Integer String]  -- ^ Current (partial) key, reversed
274
           -> String                   -- ^ Remaining string
275
           -> ([Either Integer String], String)
276
extractKey ek [] = (reverse ek, [])
277
extractKey ek xs@(x:_) =
278
  let (span_fn, conv_fn) = if isDigit x
279
                             then (isDigit, Left . read)
280
                             else (not . isDigit, Right)
281
      (k, rest) = span span_fn xs
282
  in extractKey (conv_fn k:ek) rest
283

    
284
{-| Sort a list of strings based on digit and non-digit groupings.
285

    
286
Given a list of names @['a1', 'a10', 'a11', 'a2']@ this function
287
will sort the list in the logical order @['a1', 'a2', 'a10', 'a11']@.
288

    
289
The sort algorithm breaks each name in groups of either only-digits or
290
no-digits, and sorts based on each group.
291

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

    
299
-}
300
niceSort :: [String] -> [String]
301
niceSort = niceSortKey id
302

    
303
-- | Key-version of 'niceSort'. We use 'sortBy' and @compare `on` fst@
304
-- since we don't want to add an ordering constraint on the /a/ type,
305
-- hence the need to only compare the first element of the /(key, a)/
306
-- tuple.
307
niceSortKey :: (a -> String) -> [a] -> [a]
308
niceSortKey keyfn =
309
  map snd . sortBy (compare `on` fst) .
310
  map (\s -> (fst . extractKey [] $ keyfn s, s))
311

    
312
-- | Strip space characthers (including newline). As this is
313
-- expensive, should only be run on small strings.
314
rStripSpace :: String -> String
315
rStripSpace = reverse . dropWhile isSpace . reverse
316

    
317
-- | Returns a random UUID.
318
-- This is a Linux-specific method as it uses the /proc filesystem.
319
newUUID :: IO String
320
newUUID = do
321
  contents <- readFile ConstantUtils.randomUuidFile
322
  return $! rStripSpace $ take 128 contents
323

    
324
-- | Returns the current time as an 'Integer' representing the number
325
-- of seconds from the Unix epoch.
326
getCurrentTime :: IO Integer
327
getCurrentTime = do
328
  TOD ctime _ <- getClockTime
329
  return ctime
330

    
331
-- | Returns the current time as an 'Integer' representing the number
332
-- of microseconds from the Unix epoch (hence the need for 'Integer').
333
getCurrentTimeUSec :: IO Integer
334
getCurrentTimeUSec = do
335
  TOD ctime pico <- getClockTime
336
  -- pico: 10^-12, micro: 10^-6, so we have to shift seconds left and
337
  -- picoseconds right
338
  return $ ctime * 1000000 + pico `div` 1000000
339

    
340
-- | Convert a ClockTime into a (seconds-only) timestamp.
341
clockTimeToString :: ClockTime -> String
342
clockTimeToString (TOD t _) = show t
343

    
344
{-| Strip a prefix from a string, allowing the last character of the prefix
345
(which is assumed to be a separator) to be absent from the string if the string
346
terminates there.
347

    
348
\>>> chompPrefix \"foo:bar:\" \"a:b:c\"
349
Nothing
350

    
351
\>>> chompPrefix \"foo:bar:\" \"foo:bar:baz\"
352
Just \"baz\"
353

    
354
\>>> chompPrefix \"foo:bar:\" \"foo:bar:\"
355
Just \"\"
356

    
357
\>>> chompPrefix \"foo:bar:\" \"foo:bar\"
358
Just \"\"
359

    
360
\>>> chompPrefix \"foo:bar:\" \"foo:barbaz\"
361
Nothing
362
-}
363
chompPrefix :: String -> String -> Maybe String
364
chompPrefix pfx str =
365
  if pfx `isPrefixOf` str || str == init pfx
366
    then Just $ drop (length pfx) str
367
    else Nothing
368

    
369
-- | Breaks a string in lines with length \<= maxWidth.
370
--
371
-- NOTE: The split is OK if:
372
--
373
-- * It doesn't break a word, i.e. the next line begins with space
374
--   (@isSpace . head $ rest@) or the current line ends with space
375
--   (@null revExtra@);
376
--
377
-- * It breaks a very big word that doesn't fit anyway (@null revLine@).
378
wrap :: Int      -- ^ maxWidth
379
     -> String   -- ^ string that needs wrapping
380
     -> [String] -- ^ string \"broken\" in lines
381
wrap maxWidth = filter (not . null) . map trim . wrap0
382
  where wrap0 :: String -> [String]
383
        wrap0 text
384
          | length text <= maxWidth = [text]
385
          | isSplitOK               = line : wrap0 rest
386
          | otherwise               = line' : wrap0 rest'
387
          where (line, rest) = splitAt maxWidth text
388
                (revExtra, revLine) = break isSpace . reverse $ line
389
                (line', rest') = (reverse revLine, reverse revExtra ++ rest)
390
                isSplitOK =
391
                  null revLine || null revExtra || startsWithSpace rest
392
                startsWithSpace (x:_) = isSpace x
393
                startsWithSpace _     = False
394

    
395
-- | Removes surrounding whitespace. Should only be used in small
396
-- strings.
397
trim :: String -> String
398
trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
399

    
400
-- | A safer head version, with a default value.
401
defaultHead :: a -> [a] -> a
402
defaultHead def []    = def
403
defaultHead _   (x:_) = x
404

    
405
-- | A 'head' version in the I/O monad, for validating parameters
406
-- without which we cannot continue.
407
exitIfEmpty :: String -> [a] -> IO a
408
exitIfEmpty _ (x:_) = return x
409
exitIfEmpty s []    = exitErr s
410

    
411
-- | Split an 'Either' list into two separate lists (containing the
412
-- 'Left' and 'Right' elements, plus a \"trail\" list that allows
413
-- recombination later.
414
--
415
-- This is splitter; for recombination, look at 'recombineEithers'.
416
-- The sum of \"left\" and \"right\" lists should be equal to the
417
-- original list length, and the trail list should be the same length
418
-- as well. The entries in the resulting lists are reversed in
419
-- comparison with the original list.
420
splitEithers :: [Either a b] -> ([a], [b], [Bool])
421
splitEithers = foldl' splitter ([], [], [])
422
  where splitter (l, r, t) e =
423
          case e of
424
            Left  v -> (v:l, r, False:t)
425
            Right v -> (l, v:r, True:t)
426

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

    
452
-- | Default hints for the resolver
453
resolveAddrHints :: Maybe AddrInfo
454
resolveAddrHints =
455
  Just defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV] }
456

    
457
-- | Resolves a numeric address.
458
resolveAddr :: Int -> String -> IO (Result (Family, SockAddr))
459
resolveAddr port str = do
460
  resolved <- getAddrInfo resolveAddrHints (Just str) (Just (show port))
461
  return $ case resolved of
462
             [] -> Bad "Invalid results from lookup?"
463
             best:_ -> Ok (addrFamily best, addrAddress best)
464

    
465
-- | Set the owner and the group of a file (given as names, not numeric id).
466
setOwnerAndGroupFromNames :: FilePath -> GanetiDaemon -> GanetiGroup -> IO ()
467
setOwnerAndGroupFromNames filename daemon dGroup = do
468
  -- TODO: it would be nice to rework this (or getEnts) so that runtimeEnts
469
  -- is read only once per daemon startup, and then cached for further usage.
470
  runtimeEnts <- getEnts
471
  ents <- exitIfBad "Can't find required user/groups" runtimeEnts
472
  -- note: we use directly ! as lookup failures shouldn't happen, due
473
  -- to the map construction
474
  let uid = fst ents M.! daemon
475
  let gid = snd ents M.! dGroup
476
  setOwnerAndGroup filename uid gid
477

    
478
-- | Formats an integral number, appending a suffix.
479
formatOrdinal :: (Integral a, Show a) => a -> String
480
formatOrdinal num
481
  | num > 10 && num < 20 = suffix "th"
482
  | tens == 1            = suffix "st"
483
  | tens == 2            = suffix "nd"
484
  | tens == 3            = suffix "rd"
485
  | otherwise            = suffix "th"
486
  where tens     = num `mod` 10
487
        suffix s = show num ++ s