Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Utils.hs @ e817723c

History | View | Annotate | Download (18.4 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
  , monadicThe
62
  , setOwnerAndGroupFromNames
63
  , formatOrdinal
64
  , atomicWriteFile
65
  , tryAndLogIOError
66
  , lockFile
67
  ) where
68

    
69
import Control.Exception (try)
70
import Data.Char (toUpper, isAlphaNum, isDigit, isSpace)
71
import Data.Function (on)
72
import Data.List
73
import qualified Data.Map as M
74
import Control.Monad (foldM, liftM)
75
import System.Directory (renameFile)
76
import System.FilePath.Posix (takeDirectory, takeBaseName)
77

    
78
import Debug.Trace
79
import Network.Socket
80

    
81
import Ganeti.BasicTypes
82
import qualified Ganeti.ConstantUtils as ConstantUtils
83
import Ganeti.Logging
84
import Ganeti.Runtime
85
import System.IO
86
import System.Exit
87
import System.Posix.Files
88
import System.Posix.IO
89
import System.Time
90

    
91
-- * Debug functions
92

    
93
-- | To be used only for debugging, breaks referential integrity.
94
debug :: Show a => a -> a
95
debug x = trace (show x) x
96

    
97
-- | Displays a modified form of the second parameter before returning
98
-- it.
99
debugFn :: Show b => (a -> b) -> a -> a
100
debugFn fn x = debug (fn x) `seq` x
101

    
102
-- | Show the first parameter before returning the second one.
103
debugXy :: Show a => a -> b -> b
104
debugXy = seq . debug
105

    
106
-- * Miscellaneous
107

    
108
-- | Apply the function if condition holds, otherwise use default value.
109
applyIf :: Bool -> (a -> a) -> a -> a
110
applyIf b f x = if b then f x else x
111

    
112
-- | Comma-join a string list.
113
commaJoin :: [String] -> String
114
commaJoin = intercalate ","
115

    
116
-- | Split a list on a separator and return an array.
117
sepSplit :: Eq a => a -> [a] -> [[a]]
118
sepSplit sep s
119
  | null s    = []
120
  | null xs   = [x]
121
  | null ys   = [x,[]]
122
  | otherwise = x:sepSplit sep ys
123
  where (x, xs) = break (== sep) s
124
        ys = drop 1 xs
125

    
126
-- | Simple pluralize helper
127
plural :: Int -> String -> String -> String
128
plural 1 s _ = s
129
plural _ _ p = p
130

    
131
-- | Ensure a value is quoted if needed.
132
ensureQuoted :: String -> String
133
ensureQuoted v = if not (all (\c -> isAlphaNum c || c == '.') v)
134
                 then '\'':v ++ "'"
135
                 else v
136

    
137
-- * Mathematical functions
138

    
139
-- Simple and slow statistical functions, please replace with better
140
-- versions
141

    
142
-- | Standard deviation function.
143
stdDev :: [Double] -> Double
144
stdDev lst =
145
  -- first, calculate the list length and sum lst in a single step,
146
  -- for performance reasons
147
  let (ll', sx) = foldl' (\(rl, rs) e ->
148
                           let rl' = rl + 1
149
                               rs' = rs + e
150
                           in rl' `seq` rs' `seq` (rl', rs')) (0::Int, 0) lst
151
      ll = fromIntegral ll'::Double
152
      mv = sx / ll
153
      av = foldl' (\accu em -> let d = em - mv in accu + d * d) 0.0 lst
154
  in sqrt (av / ll) -- stddev
155

    
156
-- *  Logical functions
157

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

    
163
-- | \"if\" as a function, rather than as syntactic sugar.
164
if' :: Bool -- ^ condition
165
    -> a    -- ^ \"then\" result
166
    -> a    -- ^ \"else\" result
167
    -> a    -- ^ \"then\" or "else" result depending on the condition
168
if' True x _ = x
169
if' _    _ y = y
170

    
171
-- * Parsing utility functions
172

    
173
-- | Parse results from readsPrec.
174
parseChoices :: (Monad m, Read a) => String -> String -> [(a, String)] -> m a
175
parseChoices _ _ ((v, ""):[]) = return v
176
parseChoices name s ((_, e):[]) =
177
    fail $ name ++ ": leftover characters when parsing '"
178
           ++ s ++ "': '" ++ e ++ "'"
179
parseChoices name s _ = fail $ name ++ ": cannot parse string '" ++ s ++ "'"
180

    
181
-- | Safe 'read' function returning data encapsulated in a Result.
182
tryRead :: (Monad m, Read a) => String -> String -> m a
183
tryRead name s = parseChoices name s $ reads s
184

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

    
204
-- | Constructs a printable table from given header and rows
205
printTable :: String -> [String] -> [[String]] -> [Bool] -> String
206
printTable lp header rows isnum =
207
  unlines . map ((++) lp . (:) ' ' . unwords) $
208
  formatTable (header:rows) isnum
209

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

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

    
246
-- | Unwraps a 'Result', exiting the program if it is a 'Bad' value,
247
-- otherwise returning the actual contained value.
248
exitIfBad :: String -> Result a -> IO a
249
exitIfBad msg (Bad s) = exitErr (msg ++ ": " ++ s)
250
exitIfBad _ (Ok v) = return v
251

    
252
-- | Exits immediately with an error message.
253
exitErr :: String -> IO a
254
exitErr errmsg = do
255
  hPutStrLn stderr $ "Error: " ++ errmsg
256
  exitWith (ExitFailure 1)
257

    
258
-- | Exits with an error message if the given boolean condition if true.
259
exitWhen :: Bool -> String -> IO ()
260
exitWhen True msg = exitErr msg
261
exitWhen False _  = return ()
262

    
263
-- | Exits with an error message /unless/ the given boolean condition
264
-- if true, the opposite of 'exitWhen'.
265
exitUnless :: Bool -> String -> IO ()
266
exitUnless cond = exitWhen (not cond)
267

    
268
-- | Unwraps a 'Result', logging a warning message and then returning a default
269
-- value if it is a 'Bad' value, otherwise returning the actual contained value.
270
logWarningIfBad :: String -> a -> Result a -> IO a
271
logWarningIfBad msg defVal (Bad s) = do
272
  logWarning $ msg ++ ": " ++ s
273
  return defVal
274
logWarningIfBad _ _ (Ok v) = return v
275

    
276
-- | Try an IO interaction, log errors and unfold as a 'Result'.
277
tryAndLogIOError :: IO a -> String -> (a -> Result b) -> IO (Result b)
278
tryAndLogIOError io msg okfn =
279
 try io >>= either
280
   (\ e -> do
281
       let combinedmsg = msg ++ ": " ++ show (e :: IOError)
282
       logError combinedmsg
283
       return . Bad $ combinedmsg)
284
   (return . okfn)
285

    
286
-- | Print a warning, but do not exit.
287
warn :: String -> IO ()
288
warn = hPutStrLn stderr . (++) "Warning: "
289

    
290
-- | Helper for 'niceSort'. Computes the key element for a given string.
291
extractKey :: [Either Integer String]  -- ^ Current (partial) key, reversed
292
           -> String                   -- ^ Remaining string
293
           -> ([Either Integer String], String)
294
extractKey ek [] = (reverse ek, [])
295
extractKey ek xs@(x:_) =
296
  let (span_fn, conv_fn) = if isDigit x
297
                             then (isDigit, Left . read)
298
                             else (not . isDigit, Right)
299
      (k, rest) = span span_fn xs
300
  in extractKey (conv_fn k:ek) rest
301

    
302
{-| Sort a list of strings based on digit and non-digit groupings.
303

    
304
Given a list of names @['a1', 'a10', 'a11', 'a2']@ this function
305
will sort the list in the logical order @['a1', 'a2', 'a10', 'a11']@.
306

    
307
The sort algorithm breaks each name in groups of either only-digits or
308
no-digits, and sorts based on each group.
309

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

    
317
-}
318
niceSort :: [String] -> [String]
319
niceSort = niceSortKey id
320

    
321
-- | Key-version of 'niceSort'. We use 'sortBy' and @compare `on` fst@
322
-- since we don't want to add an ordering constraint on the /a/ type,
323
-- hence the need to only compare the first element of the /(key, a)/
324
-- tuple.
325
niceSortKey :: (a -> String) -> [a] -> [a]
326
niceSortKey keyfn =
327
  map snd . sortBy (compare `on` fst) .
328
  map (\s -> (fst . extractKey [] $ keyfn s, s))
329

    
330
-- | Strip space characthers (including newline). As this is
331
-- expensive, should only be run on small strings.
332
rStripSpace :: String -> String
333
rStripSpace = reverse . dropWhile isSpace . reverse
334

    
335
-- | Returns a random UUID.
336
-- This is a Linux-specific method as it uses the /proc filesystem.
337
newUUID :: IO String
338
newUUID = do
339
  contents <- readFile ConstantUtils.randomUuidFile
340
  return $! rStripSpace $ take 128 contents
341

    
342
-- | Returns the current time as an 'Integer' representing the number
343
-- of seconds from the Unix epoch.
344
getCurrentTime :: IO Integer
345
getCurrentTime = do
346
  TOD ctime _ <- getClockTime
347
  return ctime
348

    
349
-- | Returns the current time as an 'Integer' representing the number
350
-- of microseconds from the Unix epoch (hence the need for 'Integer').
351
getCurrentTimeUSec :: IO Integer
352
getCurrentTimeUSec = do
353
  TOD ctime pico <- getClockTime
354
  -- pico: 10^-12, micro: 10^-6, so we have to shift seconds left and
355
  -- picoseconds right
356
  return $ ctime * 1000000 + pico `div` 1000000
357

    
358
-- | Convert a ClockTime into a (seconds-only) timestamp.
359
clockTimeToString :: ClockTime -> String
360
clockTimeToString (TOD t _) = show t
361

    
362
{-| Strip a prefix from a string, allowing the last character of the prefix
363
(which is assumed to be a separator) to be absent from the string if the string
364
terminates there.
365

    
366
\>>> chompPrefix \"foo:bar:\" \"a:b:c\"
367
Nothing
368

    
369
\>>> chompPrefix \"foo:bar:\" \"foo:bar:baz\"
370
Just \"baz\"
371

    
372
\>>> chompPrefix \"foo:bar:\" \"foo:bar:\"
373
Just \"\"
374

    
375
\>>> chompPrefix \"foo:bar:\" \"foo:bar\"
376
Just \"\"
377

    
378
\>>> chompPrefix \"foo:bar:\" \"foo:barbaz\"
379
Nothing
380
-}
381
chompPrefix :: String -> String -> Maybe String
382
chompPrefix pfx str =
383
  if pfx `isPrefixOf` str || str == init pfx
384
    then Just $ drop (length pfx) str
385
    else Nothing
386

    
387
-- | Breaks a string in lines with length \<= maxWidth.
388
--
389
-- NOTE: The split is OK if:
390
--
391
-- * It doesn't break a word, i.e. the next line begins with space
392
--   (@isSpace . head $ rest@) or the current line ends with space
393
--   (@null revExtra@);
394
--
395
-- * It breaks a very big word that doesn't fit anyway (@null revLine@).
396
wrap :: Int      -- ^ maxWidth
397
     -> String   -- ^ string that needs wrapping
398
     -> [String] -- ^ string \"broken\" in lines
399
wrap maxWidth = filter (not . null) . map trim . wrap0
400
  where wrap0 :: String -> [String]
401
        wrap0 text
402
          | length text <= maxWidth = [text]
403
          | isSplitOK               = line : wrap0 rest
404
          | otherwise               = line' : wrap0 rest'
405
          where (line, rest) = splitAt maxWidth text
406
                (revExtra, revLine) = break isSpace . reverse $ line
407
                (line', rest') = (reverse revLine, reverse revExtra ++ rest)
408
                isSplitOK =
409
                  null revLine || null revExtra || startsWithSpace rest
410
                startsWithSpace (x:_) = isSpace x
411
                startsWithSpace _     = False
412

    
413
-- | Removes surrounding whitespace. Should only be used in small
414
-- strings.
415
trim :: String -> String
416
trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
417

    
418
-- | A safer head version, with a default value.
419
defaultHead :: a -> [a] -> a
420
defaultHead def []    = def
421
defaultHead _   (x:_) = x
422

    
423
-- | A 'head' version in the I/O monad, for validating parameters
424
-- without which we cannot continue.
425
exitIfEmpty :: String -> [a] -> IO a
426
exitIfEmpty _ (x:_) = return x
427
exitIfEmpty s []    = exitErr s
428

    
429
-- | Obtain the unique element of a list in an arbitrary monad.
430
monadicThe :: (Eq a, Monad m) => String -> [a] -> m a
431
monadicThe s [] = fail s
432
monadicThe s (x:xs)
433
  | all (x ==) xs = return x
434
  | otherwise = fail s
435

    
436
-- | Split an 'Either' list into two separate lists (containing the
437
-- 'Left' and 'Right' elements, plus a \"trail\" list that allows
438
-- recombination later.
439
--
440
-- This is splitter; for recombination, look at 'recombineEithers'.
441
-- The sum of \"left\" and \"right\" lists should be equal to the
442
-- original list length, and the trail list should be the same length
443
-- as well. The entries in the resulting lists are reversed in
444
-- comparison with the original list.
445
splitEithers :: [Either a b] -> ([a], [b], [Bool])
446
splitEithers = foldl' splitter ([], [], [])
447
  where splitter (l, r, t) e =
448
          case e of
449
            Left  v -> (v:l, r, False:t)
450
            Right v -> (l, v:r, True:t)
451

    
452
-- | Recombines two \"left\" and \"right\" lists using a \"trail\"
453
-- list into a single 'Either' list.
454
--
455
-- This is the counterpart to 'splitEithers'. It does the opposite
456
-- transformation, and the output list will be the reverse of the
457
-- input lists. Since 'splitEithers' also reverses the lists, calling
458
-- these together will result in the original list.
459
--
460
-- Mismatches in the structure of the lists (e.g. inconsistent
461
-- lengths) are represented via 'Bad'; normally this function should
462
-- not fail, if lists are passed as generated by 'splitEithers'.
463
recombineEithers :: (Show a, Show b) =>
464
                    [a] -> [b] -> [Bool] -> Result [Either a b]
465
recombineEithers lefts rights trail =
466
  foldM recombiner ([], lefts, rights) trail >>= checker
467
    where checker (eithers, [], []) = Ok eithers
468
          checker (_, lefts', rights') =
469
            Bad $ "Inconsistent results after recombination, l'=" ++
470
                show lefts' ++ ", r'=" ++ show rights'
471
          recombiner (es, l:ls, rs) False = Ok (Left l:es,  ls, rs)
472
          recombiner (es, ls, r:rs) True  = Ok (Right r:es, ls, rs)
473
          recombiner (_,  ls, rs) t = Bad $ "Inconsistent trail log: l=" ++
474
                                      show ls ++ ", r=" ++ show rs ++ ",t=" ++
475
                                      show t
476

    
477
-- | Default hints for the resolver
478
resolveAddrHints :: Maybe AddrInfo
479
resolveAddrHints =
480
  Just defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV] }
481

    
482
-- | Resolves a numeric address.
483
resolveAddr :: Int -> String -> IO (Result (Family, SockAddr))
484
resolveAddr port str = do
485
  resolved <- getAddrInfo resolveAddrHints (Just str) (Just (show port))
486
  return $ case resolved of
487
             [] -> Bad "Invalid results from lookup?"
488
             best:_ -> Ok (addrFamily best, addrAddress best)
489

    
490
-- | Set the owner and the group of a file (given as names, not numeric id).
491
setOwnerAndGroupFromNames :: FilePath -> GanetiDaemon -> GanetiGroup -> IO ()
492
setOwnerAndGroupFromNames filename daemon dGroup = do
493
  -- TODO: it would be nice to rework this (or getEnts) so that runtimeEnts
494
  -- is read only once per daemon startup, and then cached for further usage.
495
  runtimeEnts <- getEnts
496
  ents <- exitIfBad "Can't find required user/groups" runtimeEnts
497
  -- note: we use directly ! as lookup failures shouldn't happen, due
498
  -- to the map construction
499
  let uid = fst ents M.! daemon
500
  let gid = snd ents M.! dGroup
501
  setOwnerAndGroup filename uid gid
502

    
503
-- | Formats an integral number, appending a suffix.
504
formatOrdinal :: (Integral a, Show a) => a -> String
505
formatOrdinal num
506
  | num > 10 && num < 20 = suffix "th"
507
  | tens == 1            = suffix "st"
508
  | tens == 2            = suffix "nd"
509
  | tens == 3            = suffix "rd"
510
  | otherwise            = suffix "th"
511
  where tens     = num `mod` 10
512
        suffix s = show num ++ s
513

    
514
-- | Atomically write a file, by first writing the contents into a temporary
515
-- file and then renaming it to the old position.
516
atomicWriteFile :: FilePath -> String -> IO ()
517
atomicWriteFile path contents = do
518
  (tmppath, tmphandle) <- openTempFile (takeDirectory path) (takeBaseName path)
519
  hPutStr tmphandle contents
520
  hClose tmphandle
521
  renameFile tmppath path
522

    
523
-- | Attempt, in a non-blocking way, to obtain a lock on a given file; report
524
-- back success.
525
lockFile :: FilePath -> IO (Result ())
526
lockFile path = do
527
  handle <- openFile path WriteMode
528
  fd <- handleToFd handle
529
  Control.Monad.liftM (either (Bad . show) Ok)
530
    (try (setLock fd (WriteLock, AbsoluteSeek, 0, 0)) :: IO (Either IOError ()))