Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / Utils.hs @ 557f5dad

History | View | Annotate | Download (21.8 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
  , parseUnitAssumeBinary
40
  , plural
41
  , niceSort
42
  , niceSortKey
43
  , exitIfBad
44
  , exitErr
45
  , exitWhen
46
  , exitUnless
47
  , logWarningIfBad
48
  , rStripSpace
49
  , newUUID
50
  , getCurrentTime
51
  , getCurrentTimeUSec
52
  , clockTimeToString
53
  , chompPrefix
54
  , warn
55
  , wrap
56
  , trim
57
  , defaultHead
58
  , exitIfEmpty
59
  , splitEithers
60
  , recombineEithers
61
  , resolveAddr
62
  , monadicThe
63
  , setOwnerAndGroupFromNames
64
  , formatOrdinal
65
  , atomicWriteFile
66
  , tryAndLogIOError
67
  , lockFile
68
  , FStat
69
  , nullFStat
70
  , getFStat
71
  , getFStatSafe
72
  , needsReload
73
  , watchFile
74
  ) where
75

    
76
import Control.Concurrent
77
import Control.Exception (try)
78
import Data.Char (toUpper, isAlphaNum, isDigit, isSpace)
79
import Data.Function (on)
80
import Data.IORef
81
import Data.List
82
import qualified Data.Map as M
83
import Control.Monad (foldM, liftM)
84
import System.Directory (renameFile)
85
import System.FilePath.Posix (takeDirectory, takeBaseName)
86
import System.INotify
87
import System.Posix.Types
88

    
89
import Debug.Trace
90
import Network.Socket
91

    
92
import Ganeti.BasicTypes
93
import qualified Ganeti.ConstantUtils as ConstantUtils
94
import Ganeti.Logging
95
import Ganeti.Runtime
96
import System.IO
97
import System.Exit
98
import System.Posix.Files
99
import System.Posix.IO
100
import System.Time
101

    
102
-- * Debug functions
103

    
104
-- | To be used only for debugging, breaks referential integrity.
105
debug :: Show a => a -> a
106
debug x = trace (show x) x
107

    
108
-- | Displays a modified form of the second parameter before returning
109
-- it.
110
debugFn :: Show b => (a -> b) -> a -> a
111
debugFn fn x = debug (fn x) `seq` x
112

    
113
-- | Show the first parameter before returning the second one.
114
debugXy :: Show a => a -> b -> b
115
debugXy = seq . debug
116

    
117
-- * Miscellaneous
118

    
119
-- | Apply the function if condition holds, otherwise use default value.
120
applyIf :: Bool -> (a -> a) -> a -> a
121
applyIf b f x = if b then f x else x
122

    
123
-- | Comma-join a string list.
124
commaJoin :: [String] -> String
125
commaJoin = intercalate ","
126

    
127
-- | Split a list on a separator and return an array.
128
sepSplit :: Eq a => a -> [a] -> [[a]]
129
sepSplit sep s
130
  | null s    = []
131
  | null xs   = [x]
132
  | null ys   = [x,[]]
133
  | otherwise = x:sepSplit sep ys
134
  where (x, xs) = break (== sep) s
135
        ys = drop 1 xs
136

    
137
-- | Simple pluralize helper
138
plural :: Int -> String -> String -> String
139
plural 1 s _ = s
140
plural _ _ p = p
141

    
142
-- | Ensure a value is quoted if needed.
143
ensureQuoted :: String -> String
144
ensureQuoted v = if not (all (\c -> isAlphaNum c || c == '.') v)
145
                 then '\'':v ++ "'"
146
                 else v
147

    
148
-- * Mathematical functions
149

    
150
-- Simple and slow statistical functions, please replace with better
151
-- versions
152

    
153
-- | Standard deviation function.
154
stdDev :: [Double] -> Double
155
stdDev lst =
156
  -- first, calculate the list length and sum lst in a single step,
157
  -- for performance reasons
158
  let (ll', sx) = foldl' (\(rl, rs) e ->
159
                           let rl' = rl + 1
160
                               rs' = rs + e
161
                           in rl' `seq` rs' `seq` (rl', rs')) (0::Int, 0) lst
162
      ll = fromIntegral ll'::Double
163
      mv = sx / ll
164
      av = foldl' (\accu em -> let d = em - mv in accu + d * d) 0.0 lst
165
  in sqrt (av / ll) -- stddev
166

    
167
-- *  Logical functions
168

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

    
174
-- | \"if\" as a function, rather than as syntactic sugar.
175
if' :: Bool -- ^ condition
176
    -> a    -- ^ \"then\" result
177
    -> a    -- ^ \"else\" result
178
    -> a    -- ^ \"then\" or "else" result depending on the condition
179
if' True x _ = x
180
if' _    _ y = y
181

    
182
-- * Parsing utility functions
183

    
184
-- | Parse results from readsPrec.
185
parseChoices :: (Monad m, Read a) => String -> String -> [(a, String)] -> m a
186
parseChoices _ _ ((v, ""):[]) = return v
187
parseChoices name s ((_, e):[]) =
188
    fail $ name ++ ": leftover characters when parsing '"
189
           ++ s ++ "': '" ++ e ++ "'"
190
parseChoices name s _ = fail $ name ++ ": cannot parse string '" ++ s ++ "'"
191

    
192
-- | Safe 'read' function returning data encapsulated in a Result.
193
tryRead :: (Monad m, Read a) => String -> String -> m a
194
tryRead name s = parseChoices name s $ reads s
195

    
196
-- | Format a table of strings to maintain consistent length.
197
formatTable :: [[String]] -> [Bool] -> [[String]]
198
formatTable vals numpos =
199
    let vtrans = transpose vals  -- transpose, so that we work on rows
200
                                 -- rather than columns
201
        mlens = map (maximum . map length) vtrans
202
        expnd = map (\(flds, isnum, ml) ->
203
                         map (\val ->
204
                                  let delta = ml - length val
205
                                      filler = replicate delta ' '
206
                                  in if delta > 0
207
                                     then if isnum
208
                                          then filler ++ val
209
                                          else val ++ filler
210
                                     else val
211
                             ) flds
212
                    ) (zip3 vtrans numpos mlens)
213
   in transpose expnd
214

    
215
-- | Constructs a printable table from given header and rows
216
printTable :: String -> [String] -> [[String]] -> [Bool] -> String
217
printTable lp header rows isnum =
218
  unlines . map ((++) lp . (:) ' ' . unwords) $
219
  formatTable (header:rows) isnum
220

    
221
-- | Converts a unit (e.g. m or GB) into a scaling factor.
222
parseUnitValue :: (Monad m) => Bool -> String -> m Rational
223
parseUnitValue noDecimal unit
224
  -- binary conversions first
225
  | null unit                     = return 1
226
  | unit == "m" || upper == "MIB" = return 1
227
  | unit == "g" || upper == "GIB" = return kbBinary
228
  | unit == "t" || upper == "TIB" = return $ kbBinary * kbBinary
229
  -- SI conversions
230
  | unit == "M" || upper == "MB"  = return mbFactor
231
  | unit == "G" || upper == "GB"  = return $ mbFactor * kbDecimal
232
  | unit == "T" || upper == "TB"  = return $ mbFactor * kbDecimal * kbDecimal
233
  | otherwise = fail $ "Unknown unit '" ++ unit ++ "'"
234
  where upper = map toUpper unit
235
        kbBinary = 1024 :: Rational
236
        kbDecimal = if noDecimal then kbBinary else 1000
237
        decToBin = kbDecimal / kbBinary -- factor for 1K conversion
238
        mbFactor = decToBin * decToBin -- twice the factor for just 1K
239

    
240
-- | Tries to extract number and scale from the given string.
241
--
242
-- Input must be in the format NUMBER+ SPACE* [UNIT]. If no unit is
243
-- specified, it defaults to MiB. Return value is always an integral
244
-- value in MiB; if the first argument is True, all kilos are binary.
245
parseUnitEx :: (Monad m, Integral a, Read a) => Bool -> String -> m a
246
parseUnitEx noDecimal str =
247
  -- TODO: enhance this by splitting the unit parsing code out and
248
  -- accepting floating-point numbers
249
  case (reads str::[(Int, String)]) of
250
    [(v, suffix)] ->
251
      let unit = dropWhile (== ' ') suffix
252
      in do
253
        scaling <- parseUnitValue noDecimal unit
254
        return $ truncate (fromIntegral v * scaling)
255
    _ -> fail $ "Can't parse string '" ++ str ++ "'"
256

    
257
-- | Tries to extract number and scale from the given string.
258
--
259
-- Input must be in the format NUMBER+ SPACE* [UNIT]. If no unit is
260
-- specified, it defaults to MiB. Return value is always an integral
261
-- value in MiB.
262
parseUnit :: (Monad m, Integral a, Read a) => String -> m a
263
parseUnit = parseUnitEx False
264

    
265
-- | Tries to extract a number and scale from a given string, taking
266
-- all kilos to be binary.
267
parseUnitAssumeBinary :: (Monad m, Integral a, Read a) => String -> m a
268
parseUnitAssumeBinary = parseUnitEx True
269

    
270
-- | Unwraps a 'Result', exiting the program if it is a 'Bad' value,
271
-- otherwise returning the actual contained value.
272
exitIfBad :: String -> Result a -> IO a
273
exitIfBad msg (Bad s) = exitErr (msg ++ ": " ++ s)
274
exitIfBad _ (Ok v) = return v
275

    
276
-- | Exits immediately with an error message.
277
exitErr :: String -> IO a
278
exitErr errmsg = do
279
  hPutStrLn stderr $ "Error: " ++ errmsg
280
  exitWith (ExitFailure 1)
281

    
282
-- | Exits with an error message if the given boolean condition if true.
283
exitWhen :: Bool -> String -> IO ()
284
exitWhen True msg = exitErr msg
285
exitWhen False _  = return ()
286

    
287
-- | Exits with an error message /unless/ the given boolean condition
288
-- if true, the opposite of 'exitWhen'.
289
exitUnless :: Bool -> String -> IO ()
290
exitUnless cond = exitWhen (not cond)
291

    
292
-- | Unwraps a 'Result', logging a warning message and then returning a default
293
-- value if it is a 'Bad' value, otherwise returning the actual contained value.
294
logWarningIfBad :: String -> a -> Result a -> IO a
295
logWarningIfBad msg defVal (Bad s) = do
296
  logWarning $ msg ++ ": " ++ s
297
  return defVal
298
logWarningIfBad _ _ (Ok v) = return v
299

    
300
-- | Try an IO interaction, log errors and unfold as a 'Result'.
301
tryAndLogIOError :: IO a -> String -> (a -> Result b) -> IO (Result b)
302
tryAndLogIOError io msg okfn =
303
 try io >>= either
304
   (\ e -> do
305
       let combinedmsg = msg ++ ": " ++ show (e :: IOError)
306
       logError combinedmsg
307
       return . Bad $ combinedmsg)
308
   (return . okfn)
309

    
310
-- | Print a warning, but do not exit.
311
warn :: String -> IO ()
312
warn = hPutStrLn stderr . (++) "Warning: "
313

    
314
-- | Helper for 'niceSort'. Computes the key element for a given string.
315
extractKey :: [Either Integer String]  -- ^ Current (partial) key, reversed
316
           -> String                   -- ^ Remaining string
317
           -> ([Either Integer String], String)
318
extractKey ek [] = (reverse ek, [])
319
extractKey ek xs@(x:_) =
320
  let (span_fn, conv_fn) = if isDigit x
321
                             then (isDigit, Left . read)
322
                             else (not . isDigit, Right)
323
      (k, rest) = span span_fn xs
324
  in extractKey (conv_fn k:ek) rest
325

    
326
{-| Sort a list of strings based on digit and non-digit groupings.
327

    
328
Given a list of names @['a1', 'a10', 'a11', 'a2']@ this function
329
will sort the list in the logical order @['a1', 'a2', 'a10', 'a11']@.
330

    
331
The sort algorithm breaks each name in groups of either only-digits or
332
no-digits, and sorts based on each group.
333

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

    
341
-}
342
niceSort :: [String] -> [String]
343
niceSort = niceSortKey id
344

    
345
-- | Key-version of 'niceSort'. We use 'sortBy' and @compare `on` fst@
346
-- since we don't want to add an ordering constraint on the /a/ type,
347
-- hence the need to only compare the first element of the /(key, a)/
348
-- tuple.
349
niceSortKey :: (a -> String) -> [a] -> [a]
350
niceSortKey keyfn =
351
  map snd . sortBy (compare `on` fst) .
352
  map (\s -> (fst . extractKey [] $ keyfn s, s))
353

    
354
-- | Strip space characthers (including newline). As this is
355
-- expensive, should only be run on small strings.
356
rStripSpace :: String -> String
357
rStripSpace = reverse . dropWhile isSpace . reverse
358

    
359
-- | Returns a random UUID.
360
-- This is a Linux-specific method as it uses the /proc filesystem.
361
newUUID :: IO String
362
newUUID = do
363
  contents <- readFile ConstantUtils.randomUuidFile
364
  return $! rStripSpace $ take 128 contents
365

    
366
-- | Returns the current time as an 'Integer' representing the number
367
-- of seconds from the Unix epoch.
368
getCurrentTime :: IO Integer
369
getCurrentTime = do
370
  TOD ctime _ <- getClockTime
371
  return ctime
372

    
373
-- | Returns the current time as an 'Integer' representing the number
374
-- of microseconds from the Unix epoch (hence the need for 'Integer').
375
getCurrentTimeUSec :: IO Integer
376
getCurrentTimeUSec = do
377
  TOD ctime pico <- getClockTime
378
  -- pico: 10^-12, micro: 10^-6, so we have to shift seconds left and
379
  -- picoseconds right
380
  return $ ctime * 1000000 + pico `div` 1000000
381

    
382
-- | Convert a ClockTime into a (seconds-only) timestamp.
383
clockTimeToString :: ClockTime -> String
384
clockTimeToString (TOD t _) = show t
385

    
386
{-| Strip a prefix from a string, allowing the last character of the prefix
387
(which is assumed to be a separator) to be absent from the string if the string
388
terminates there.
389

    
390
\>>> chompPrefix \"foo:bar:\" \"a:b:c\"
391
Nothing
392

    
393
\>>> chompPrefix \"foo:bar:\" \"foo:bar:baz\"
394
Just \"baz\"
395

    
396
\>>> chompPrefix \"foo:bar:\" \"foo:bar:\"
397
Just \"\"
398

    
399
\>>> chompPrefix \"foo:bar:\" \"foo:bar\"
400
Just \"\"
401

    
402
\>>> chompPrefix \"foo:bar:\" \"foo:barbaz\"
403
Nothing
404
-}
405
chompPrefix :: String -> String -> Maybe String
406
chompPrefix pfx str =
407
  if pfx `isPrefixOf` str || str == init pfx
408
    then Just $ drop (length pfx) str
409
    else Nothing
410

    
411
-- | Breaks a string in lines with length \<= maxWidth.
412
--
413
-- NOTE: The split is OK if:
414
--
415
-- * It doesn't break a word, i.e. the next line begins with space
416
--   (@isSpace . head $ rest@) or the current line ends with space
417
--   (@null revExtra@);
418
--
419
-- * It breaks a very big word that doesn't fit anyway (@null revLine@).
420
wrap :: Int      -- ^ maxWidth
421
     -> String   -- ^ string that needs wrapping
422
     -> [String] -- ^ string \"broken\" in lines
423
wrap maxWidth = filter (not . null) . map trim . wrap0
424
  where wrap0 :: String -> [String]
425
        wrap0 text
426
          | length text <= maxWidth = [text]
427
          | isSplitOK               = line : wrap0 rest
428
          | otherwise               = line' : wrap0 rest'
429
          where (line, rest) = splitAt maxWidth text
430
                (revExtra, revLine) = break isSpace . reverse $ line
431
                (line', rest') = (reverse revLine, reverse revExtra ++ rest)
432
                isSplitOK =
433
                  null revLine || null revExtra || startsWithSpace rest
434
                startsWithSpace (x:_) = isSpace x
435
                startsWithSpace _     = False
436

    
437
-- | Removes surrounding whitespace. Should only be used in small
438
-- strings.
439
trim :: String -> String
440
trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
441

    
442
-- | A safer head version, with a default value.
443
defaultHead :: a -> [a] -> a
444
defaultHead def []    = def
445
defaultHead _   (x:_) = x
446

    
447
-- | A 'head' version in the I/O monad, for validating parameters
448
-- without which we cannot continue.
449
exitIfEmpty :: String -> [a] -> IO a
450
exitIfEmpty _ (x:_) = return x
451
exitIfEmpty s []    = exitErr s
452

    
453
-- | Obtain the unique element of a list in an arbitrary monad.
454
monadicThe :: (Eq a, Monad m) => String -> [a] -> m a
455
monadicThe s [] = fail s
456
monadicThe s (x:xs)
457
  | all (x ==) xs = return x
458
  | otherwise = fail s
459

    
460
-- | Split an 'Either' list into two separate lists (containing the
461
-- 'Left' and 'Right' elements, plus a \"trail\" list that allows
462
-- recombination later.
463
--
464
-- This is splitter; for recombination, look at 'recombineEithers'.
465
-- The sum of \"left\" and \"right\" lists should be equal to the
466
-- original list length, and the trail list should be the same length
467
-- as well. The entries in the resulting lists are reversed in
468
-- comparison with the original list.
469
splitEithers :: [Either a b] -> ([a], [b], [Bool])
470
splitEithers = foldl' splitter ([], [], [])
471
  where splitter (l, r, t) e =
472
          case e of
473
            Left  v -> (v:l, r, False:t)
474
            Right v -> (l, v:r, True:t)
475

    
476
-- | Recombines two \"left\" and \"right\" lists using a \"trail\"
477
-- list into a single 'Either' list.
478
--
479
-- This is the counterpart to 'splitEithers'. It does the opposite
480
-- transformation, and the output list will be the reverse of the
481
-- input lists. Since 'splitEithers' also reverses the lists, calling
482
-- these together will result in the original list.
483
--
484
-- Mismatches in the structure of the lists (e.g. inconsistent
485
-- lengths) are represented via 'Bad'; normally this function should
486
-- not fail, if lists are passed as generated by 'splitEithers'.
487
recombineEithers :: (Show a, Show b) =>
488
                    [a] -> [b] -> [Bool] -> Result [Either a b]
489
recombineEithers lefts rights trail =
490
  foldM recombiner ([], lefts, rights) trail >>= checker
491
    where checker (eithers, [], []) = Ok eithers
492
          checker (_, lefts', rights') =
493
            Bad $ "Inconsistent results after recombination, l'=" ++
494
                show lefts' ++ ", r'=" ++ show rights'
495
          recombiner (es, l:ls, rs) False = Ok (Left l:es,  ls, rs)
496
          recombiner (es, ls, r:rs) True  = Ok (Right r:es, ls, rs)
497
          recombiner (_,  ls, rs) t = Bad $ "Inconsistent trail log: l=" ++
498
                                      show ls ++ ", r=" ++ show rs ++ ",t=" ++
499
                                      show t
500

    
501
-- | Default hints for the resolver
502
resolveAddrHints :: Maybe AddrInfo
503
resolveAddrHints =
504
  Just defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV] }
505

    
506
-- | Resolves a numeric address.
507
resolveAddr :: Int -> String -> IO (Result (Family, SockAddr))
508
resolveAddr port str = do
509
  resolved <- getAddrInfo resolveAddrHints (Just str) (Just (show port))
510
  return $ case resolved of
511
             [] -> Bad "Invalid results from lookup?"
512
             best:_ -> Ok (addrFamily best, addrAddress best)
513

    
514
-- | Set the owner and the group of a file (given as names, not numeric id).
515
setOwnerAndGroupFromNames :: FilePath -> GanetiDaemon -> GanetiGroup -> IO ()
516
setOwnerAndGroupFromNames filename daemon dGroup = do
517
  -- TODO: it would be nice to rework this (or getEnts) so that runtimeEnts
518
  -- is read only once per daemon startup, and then cached for further usage.
519
  runtimeEnts <- getEnts
520
  ents <- exitIfBad "Can't find required user/groups" runtimeEnts
521
  -- note: we use directly ! as lookup failures shouldn't happen, due
522
  -- to the map construction
523
  let uid = fst ents M.! daemon
524
  let gid = snd ents M.! dGroup
525
  setOwnerAndGroup filename uid gid
526

    
527
-- | Formats an integral number, appending a suffix.
528
formatOrdinal :: (Integral a, Show a) => a -> String
529
formatOrdinal num
530
  | num > 10 && num < 20 = suffix "th"
531
  | tens == 1            = suffix "st"
532
  | tens == 2            = suffix "nd"
533
  | tens == 3            = suffix "rd"
534
  | otherwise            = suffix "th"
535
  where tens     = num `mod` 10
536
        suffix s = show num ++ s
537

    
538
-- | Atomically write a file, by first writing the contents into a temporary
539
-- file and then renaming it to the old position.
540
atomicWriteFile :: FilePath -> String -> IO ()
541
atomicWriteFile path contents = do
542
  (tmppath, tmphandle) <- openTempFile (takeDirectory path) (takeBaseName path)
543
  hPutStr tmphandle contents
544
  hClose tmphandle
545
  renameFile tmppath path
546

    
547
-- | Attempt, in a non-blocking way, to obtain a lock on a given file; report
548
-- back success.
549
lockFile :: FilePath -> IO (Result ())
550
lockFile path = do
551
  handle <- openFile path WriteMode
552
  fd <- handleToFd handle
553
  Control.Monad.liftM (either (Bad . show) Ok)
554
    (try (setLock fd (WriteLock, AbsoluteSeek, 0, 0)) :: IO (Either IOError ()))
555

    
556
-- | File stat identifier.
557
type FStat = (EpochTime, FileID, FileOffset)
558

    
559
-- | Null 'FStat' value.
560
nullFStat :: FStat
561
nullFStat = (-1, -1, -1)
562

    
563
-- | Computes the file cache data from a FileStatus structure.
564
buildFileStatus :: FileStatus -> FStat
565
buildFileStatus ofs =
566
    let modt = modificationTime ofs
567
        inum = fileID ofs
568
        fsize = fileSize ofs
569
    in (modt, inum, fsize)
570

    
571
-- | Wrapper over 'buildFileStatus'. This reads the data from the
572
-- filesystem and then builds our cache structure.
573
getFStat :: FilePath -> IO FStat
574
getFStat p = liftM buildFileStatus (getFileStatus p)
575

    
576
-- | Safe version of 'getFStat', that ignores IOErrors.
577
getFStatSafe :: FilePath -> IO FStat
578
getFStatSafe fpath = liftM (either (const nullFStat) id)
579
                       ((try $ getFStat fpath) :: IO (Either IOError FStat))
580

    
581
-- | Check if the file needs reloading
582
needsReload :: FStat -> FilePath -> IO (Maybe FStat)
583
needsReload oldstat path = do
584
  newstat <- getFStat path
585
  return $ if newstat /= oldstat
586
             then Just newstat
587
             else Nothing
588

    
589
-- | Until the given point in time (useconds since the epoch), wait
590
-- for the output of a given method to change and return the new value;
591
-- make use of the promise that the output only changes if the reference
592
-- has a value different than the given one.
593
watchFileEx :: (Eq a, Eq b) => Integer -> b -> IORef b -> a -> IO a -> IO a
594
watchFileEx endtime base ref old read_fn = do
595
  current <- getCurrentTimeUSec
596
  if current > endtime then read_fn else do
597
    val <- readIORef ref
598
    if val /= base
599
      then do
600
        new <- read_fn
601
        if new /= old then return new else do
602
          threadDelay 100000
603
          watchFileEx endtime val ref old read_fn
604
      else do 
605
       threadDelay 100000
606
       watchFileEx endtime base ref old read_fn
607

    
608
-- | Within the given timeout (in seconds), wait for for the output
609
-- of the given method to change and return the new value; make use of
610
-- the promise that the method will only change its value, if
611
-- the given file changes on disk. If the file does not exist on disk, return
612
-- immediately.
613
watchFile :: Eq a => FilePath -> Int -> a -> IO a -> IO a
614
watchFile fpath timeout old read_fn = do
615
  current <- getCurrentTimeUSec
616
  let endtime = current + fromIntegral timeout * 1000000
617
  fstat <- getFStatSafe fpath
618
  ref <- newIORef fstat
619
  inotify <- initINotify
620
  _ <- addWatch inotify [Modify, Delete] fpath . const $ do
621
    logDebug $ "Notified of change in " ++ fpath
622
    fstat' <- getFStatSafe fpath
623
    writeIORef ref fstat'
624
  result <- watchFileEx endtime fstat ref old read_fn
625
  killINotify inotify
626
  return result
627