Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Utils.hs @ 06fd57e5

History | View | Annotate | Download (16.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
  , 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
  ) where
63

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

    
70
import Debug.Trace
71
import Network.Socket
72

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

    
82
-- * Debug functions
83

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

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

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

    
97
-- * Miscellaneous
98

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

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

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

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

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

    
128
-- * Mathematical functions
129

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

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

    
147
-- *  Logical functions
148

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

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

    
162
-- * Parsing utility functions
163

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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