e3d865f949eb9c413ae3fa301200b48858cf444c
[ganeti-github.git] / src / Ganeti / Utils.hs
1 {-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
2
3 {-| Utility functions. -}
4
5 {-
6
7 Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
8 All rights reserved.
9
10 Redistribution and use in source and binary forms, with or without
11 modification, are permitted provided that the following conditions are
12 met:
13
14 1. Redistributions of source code must retain the above copyright notice,
15 this list of conditions and the following disclaimer.
16
17 2. Redistributions in binary form must reproduce the above copyright
18 notice, this list of conditions and the following disclaimer in the
19 documentation and/or other materials provided with the distribution.
20
21 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
22 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
23 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
24 PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
25 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
26 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
27 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32
33 -}
34
35 module Ganeti.Utils
36 ( debug
37 , debugFn
38 , debugXy
39 , sepSplit
40 , findFirst
41 , stdDev
42 , if'
43 , select
44 , applyIf
45 , commaJoin
46 , ensureQuoted
47 , tryRead
48 , formatTable
49 , printTable
50 , parseUnit
51 , parseUnitAssumeBinary
52 , plural
53 , niceSort
54 , niceSortKey
55 , exitIfBad
56 , exitErr
57 , exitWhen
58 , exitUnless
59 , logWarningIfBad
60 , rStripSpace
61 , newUUID
62 , getCurrentTime
63 , getCurrentTimeUSec
64 , clockTimeToString
65 , clockTimeToCTime
66 , cTimeToClockTime
67 , chompPrefix
68 , warn
69 , wrap
70 , trim
71 , defaultHead
72 , exitIfEmpty
73 , splitEithers
74 , recombineEithers
75 , resolveAddr
76 , monadicThe
77 , setOwnerAndGroupFromNames
78 , setOwnerWGroupR
79 , formatOrdinal
80 , tryAndLogIOError
81 , withDefaultOnIOError
82 , lockFile
83 , FStat
84 , nullFStat
85 , getFStat
86 , getFStatSafe
87 , needsReload
88 , watchFile
89 , watchFileBy
90 , safeRenameFile
91 , FilePermissions(..)
92 , ensurePermissions
93 ) where
94
95 import Control.Concurrent
96 import Control.Exception (try, bracket)
97 import Control.Monad
98 import Control.Monad.Error
99 import Data.Char (toUpper, isAlphaNum, isDigit, isSpace)
100 import qualified Data.Either as E
101 import Data.Function (on)
102 import Data.IORef
103 import Data.List
104 import qualified Data.Map as M
105 import Data.Maybe (fromMaybe)
106 import qualified Data.Set as S
107 import Foreign.C.Types (CTime(..))
108 import Numeric (showOct)
109 import System.Directory (renameFile, createDirectoryIfMissing)
110 import System.FilePath.Posix (takeDirectory)
111 import System.INotify
112 import System.Posix.Types
113
114 import Debug.Trace
115 import Network.Socket
116
117 import Ganeti.BasicTypes
118 import qualified Ganeti.ConstantUtils as ConstantUtils
119 import Ganeti.Logging
120 import Ganeti.Runtime
121 import System.IO
122 import System.Exit
123 import System.Posix.Files
124 import System.Posix.IO
125 import System.Time
126
127 -- * Debug functions
128
129 -- | To be used only for debugging, breaks referential integrity.
130 debug :: Show a => a -> a
131 debug x = trace (show x) x
132
133 -- | Displays a modified form of the second parameter before returning
134 -- it.
135 debugFn :: Show b => (a -> b) -> a -> a
136 debugFn fn x = debug (fn x) `seq` x
137
138 -- | Show the first parameter before returning the second one.
139 debugXy :: Show a => a -> b -> b
140 debugXy = seq . debug
141
142 -- * Miscellaneous
143
144 -- | Apply the function if condition holds, otherwise use default value.
145 applyIf :: Bool -> (a -> a) -> a -> a
146 applyIf b f x = if b then f x else x
147
148 -- | Comma-join a string list.
149 commaJoin :: [String] -> String
150 commaJoin = intercalate ","
151
152 -- | Split a list on a separator and return a list of lists.
153 sepSplit :: Eq a => a -> [a] -> [[a]]
154 sepSplit sep s
155 | null s = []
156 | null xs = [x]
157 | null ys = [x,[]]
158 | otherwise = x:sepSplit sep ys
159 where (x, xs) = break (== sep) s
160 ys = drop 1 xs
161
162 -- | Finds the first unused element in a set starting from a given base.
163 findFirst :: (Ord a, Enum a) => a -> S.Set a -> a
164 findFirst base xs =
165 case S.splitMember base xs of
166 (_, False, _) -> base
167 (_, True, ys) -> fromMaybe (succ base) $
168 (fmap fst . find (uncurry (<)) . zip [succ base..] . S.toAscList $ ys)
169 `mplus` fmap (succ . fst) (S.maxView ys)
170
171 -- | Simple pluralize helper
172 plural :: Int -> String -> String -> String
173 plural 1 s _ = s
174 plural _ _ p = p
175
176 -- | Ensure a value is quoted if needed.
177 ensureQuoted :: String -> String
178 ensureQuoted v = if not (all (\c -> isAlphaNum c || c == '.') v)
179 then '\'':v ++ "'"
180 else v
181
182 -- * Mathematical functions
183
184 -- Simple and slow statistical functions, please replace with better
185 -- versions
186
187 -- | Standard deviation function.
188 stdDev :: [Double] -> Double
189 stdDev lst =
190 -- first, calculate the list length and sum lst in a single step,
191 -- for performance reasons
192 let (ll', sx) = foldl' (\(rl, rs) e ->
193 let rl' = rl + 1
194 rs' = rs + e
195 in rl' `seq` rs' `seq` (rl', rs')) (0::Int, 0) lst
196 ll = fromIntegral ll'::Double
197 mv = sx / ll
198 av = foldl' (\accu em -> let d = em - mv in accu + d * d) 0.0 lst
199 in sqrt (av / ll) -- stddev
200
201 -- * Logical functions
202
203 -- Avoid syntactic sugar and enhance readability. These functions are proposed
204 -- by some for inclusion in the Prelude, and at the moment they are present
205 -- (with various definitions) in the utility-ht package. Some rationale and
206 -- discussion is available at <http://www.haskell.org/haskellwiki/If-then-else>
207
208 -- | \"if\" as a function, rather than as syntactic sugar.
209 if' :: Bool -- ^ condition
210 -> a -- ^ \"then\" result
211 -> a -- ^ \"else\" result
212 -> a -- ^ \"then\" or "else" result depending on the condition
213 if' True x _ = x
214 if' _ _ y = y
215
216 -- * Parsing utility functions
217
218 -- | Parse results from readsPrec.
219 parseChoices :: Monad m => String -> String -> [(a, String)] -> m a
220 parseChoices _ _ [(v, "")] = return v
221 parseChoices name s [(_, e)] =
222 fail $ name ++ ": leftover characters when parsing '"
223 ++ s ++ "': '" ++ e ++ "'"
224 parseChoices name s _ = fail $ name ++ ": cannot parse string '" ++ s ++ "'"
225
226 -- | Safe 'read' function returning data encapsulated in a Result.
227 tryRead :: (Monad m, Read a) => String -> String -> m a
228 tryRead name s = parseChoices name s $ reads s
229
230 -- | Format a table of strings to maintain consistent length.
231 formatTable :: [[String]] -> [Bool] -> [[String]]
232 formatTable vals numpos =
233 let vtrans = transpose vals -- transpose, so that we work on rows
234 -- rather than columns
235 mlens = map (maximum . map length) vtrans
236 expnd = map (\(flds, isnum, ml) ->
237 map (\val ->
238 let delta = ml - length val
239 filler = replicate delta ' '
240 in if delta > 0
241 then if isnum
242 then filler ++ val
243 else val ++ filler
244 else val
245 ) flds
246 ) (zip3 vtrans numpos mlens)
247 in transpose expnd
248
249 -- | Constructs a printable table from given header and rows
250 printTable :: String -> [String] -> [[String]] -> [Bool] -> String
251 printTable lp header rows isnum =
252 unlines . map ((++) lp . (:) ' ' . unwords) $
253 formatTable (header:rows) isnum
254
255 -- | Converts a unit (e.g. m or GB) into a scaling factor.
256 parseUnitValue :: (Monad m) => Bool -> String -> m Rational
257 parseUnitValue noDecimal unit
258 -- binary conversions first
259 | null unit = return 1
260 | unit == "m" || upper == "MIB" = return 1
261 | unit == "g" || upper == "GIB" = return kbBinary
262 | unit == "t" || upper == "TIB" = return $ kbBinary * kbBinary
263 -- SI conversions
264 | unit == "M" || upper == "MB" = return mbFactor
265 | unit == "G" || upper == "GB" = return $ mbFactor * kbDecimal
266 | unit == "T" || upper == "TB" = return $ mbFactor * kbDecimal * kbDecimal
267 | otherwise = fail $ "Unknown unit '" ++ unit ++ "'"
268 where upper = map toUpper unit
269 kbBinary = 1024 :: Rational
270 kbDecimal = if noDecimal then kbBinary else 1000
271 decToBin = kbDecimal / kbBinary -- factor for 1K conversion
272 mbFactor = decToBin * decToBin -- twice the factor for just 1K
273
274 -- | Tries to extract number and scale from the given string.
275 --
276 -- Input must be in the format NUMBER+ SPACE* [UNIT]. If no unit is
277 -- specified, it defaults to MiB. Return value is always an integral
278 -- value in MiB; if the first argument is True, all kilos are binary.
279 parseUnitEx :: (Monad m, Integral a, Read a) => Bool -> String -> m a
280 parseUnitEx noDecimal str =
281 -- TODO: enhance this by splitting the unit parsing code out and
282 -- accepting floating-point numbers
283 case (reads str::[(Int, String)]) of
284 [(v, suffix)] ->
285 let unit = dropWhile (== ' ') suffix
286 in do
287 scaling <- parseUnitValue noDecimal unit
288 return $ truncate (fromIntegral v * scaling)
289 _ -> fail $ "Can't parse string '" ++ str ++ "'"
290
291 -- | Tries to extract number and scale from the given string.
292 --
293 -- Input must be in the format NUMBER+ SPACE* [UNIT]. If no unit is
294 -- specified, it defaults to MiB. Return value is always an integral
295 -- value in MiB.
296 parseUnit :: (Monad m, Integral a, Read a) => String -> m a
297 parseUnit = parseUnitEx False
298
299 -- | Tries to extract a number and scale from a given string, taking
300 -- all kilos to be binary.
301 parseUnitAssumeBinary :: (Monad m, Integral a, Read a) => String -> m a
302 parseUnitAssumeBinary = parseUnitEx True
303
304 -- | Unwraps a 'Result', exiting the program if it is a 'Bad' value,
305 -- otherwise returning the actual contained value.
306 exitIfBad :: String -> Result a -> IO a
307 exitIfBad msg (Bad s) = exitErr (msg ++ ": " ++ s)
308 exitIfBad _ (Ok v) = return v
309
310 -- | Exits immediately with an error message.
311 exitErr :: String -> IO a
312 exitErr errmsg = do
313 hPutStrLn stderr $ "Error: " ++ errmsg
314 exitWith (ExitFailure 1)
315
316 -- | Exits with an error message if the given boolean condition if true.
317 exitWhen :: Bool -> String -> IO ()
318 exitWhen True msg = exitErr msg
319 exitWhen False _ = return ()
320
321 -- | Exits with an error message /unless/ the given boolean condition
322 -- if true, the opposite of 'exitWhen'.
323 exitUnless :: Bool -> String -> IO ()
324 exitUnless cond = exitWhen (not cond)
325
326 -- | Unwraps a 'Result', logging a warning message and then returning a default
327 -- value if it is a 'Bad' value, otherwise returning the actual contained value.
328 logWarningIfBad :: String -> a -> Result a -> IO a
329 logWarningIfBad msg defVal (Bad s) = do
330 logWarning $ msg ++ ": " ++ s
331 return defVal
332 logWarningIfBad _ _ (Ok v) = return v
333
334 -- | Try an IO interaction, log errors and unfold as a 'Result'.
335 tryAndLogIOError :: IO a -> String -> (a -> Result b) -> IO (Result b)
336 tryAndLogIOError io msg okfn =
337 try io >>= either
338 (\ e -> do
339 let combinedmsg = msg ++ ": " ++ show (e :: IOError)
340 logError combinedmsg
341 return . Bad $ combinedmsg)
342 (return . okfn)
343
344 -- | Try an IO interaction and return a default value if the interaction
345 -- throws an IOError.
346 withDefaultOnIOError :: a -> IO a -> IO a
347 withDefaultOnIOError a io =
348 try io >>= either (\ (_ :: IOError) -> return a) return
349
350 -- | Print a warning, but do not exit.
351 warn :: String -> IO ()
352 warn = hPutStrLn stderr . (++) "Warning: "
353
354 -- | Helper for 'niceSort'. Computes the key element for a given string.
355 extractKey :: [Either Integer String] -- ^ Current (partial) key, reversed
356 -> String -- ^ Remaining string
357 -> ([Either Integer String], String)
358 extractKey ek [] = (reverse ek, [])
359 extractKey ek xs@(x:_) =
360 let (span_fn, conv_fn) = if isDigit x
361 then (isDigit, Left . read)
362 else (not . isDigit, Right)
363 (k, rest) = span span_fn xs
364 in extractKey (conv_fn k:ek) rest
365
366 {-| Sort a list of strings based on digit and non-digit groupings.
367
368 Given a list of names @['a1', 'a10', 'a11', 'a2']@ this function
369 will sort the list in the logical order @['a1', 'a2', 'a10', 'a11']@.
370
371 The sort algorithm breaks each name in groups of either only-digits or
372 no-digits, and sorts based on each group.
373
374 Internally, this is not implemented via regexes (like the Python
375 version), but via actual splitting of the string in sequences of
376 either digits or everything else, and converting the digit sequences
377 in /Left Integer/ and the non-digit ones in /Right String/, at which
378 point sorting becomes trivial due to the built-in 'Either' ordering;
379 we only need one extra step of dropping the key at the end.
380
381 -}
382 niceSort :: [String] -> [String]
383 niceSort = niceSortKey id
384
385 -- | Key-version of 'niceSort'. We use 'sortBy' and @compare `on` fst@
386 -- since we don't want to add an ordering constraint on the /a/ type,
387 -- hence the need to only compare the first element of the /(key, a)/
388 -- tuple.
389 niceSortKey :: (a -> String) -> [a] -> [a]
390 niceSortKey keyfn =
391 map snd . sortBy (compare `on` fst) .
392 map (\s -> (fst . extractKey [] $ keyfn s, s))
393
394 -- | Strip space characthers (including newline). As this is
395 -- expensive, should only be run on small strings.
396 rStripSpace :: String -> String
397 rStripSpace = reverse . dropWhile isSpace . reverse
398
399 -- | Returns a random UUID.
400 -- This is a Linux-specific method as it uses the /proc filesystem.
401 newUUID :: IO String
402 newUUID = do
403 contents <- readFile ConstantUtils.randomUuidFile
404 return $! rStripSpace $ take 128 contents
405
406 -- | Returns the current time as an 'Integer' representing the number
407 -- of seconds from the Unix epoch.
408 getCurrentTime :: IO Integer
409 getCurrentTime = do
410 TOD ctime _ <- getClockTime
411 return ctime
412
413 -- | Returns the current time as an 'Integer' representing the number
414 -- of microseconds from the Unix epoch (hence the need for 'Integer').
415 getCurrentTimeUSec :: IO Integer
416 getCurrentTimeUSec = do
417 TOD ctime pico <- getClockTime
418 -- pico: 10^-12, micro: 10^-6, so we have to shift seconds left and
419 -- picoseconds right
420 return $ ctime * 1000000 + pico `div` 1000000
421
422 -- | Convert a ClockTime into a (seconds-only) timestamp.
423 clockTimeToString :: ClockTime -> String
424 clockTimeToString (TOD t _) = show t
425
426 -- | Convert a ClockTime into a (seconds-only) 'EpochTime' (AKA @time_t@).
427 clockTimeToCTime :: ClockTime -> EpochTime
428 clockTimeToCTime (TOD secs _) = fromInteger secs
429
430 -- | Convert a ClockTime into a (seconds-only) 'EpochTime' (AKA @time_t@).
431 cTimeToClockTime :: EpochTime -> ClockTime
432 cTimeToClockTime (CTime timet) = TOD (toInteger timet) 0
433
434 {-| Strip a prefix from a string, allowing the last character of the prefix
435 (which is assumed to be a separator) to be absent from the string if the string
436 terminates there.
437
438 \>>> chompPrefix \"foo:bar:\" \"a:b:c\"
439 Nothing
440
441 \>>> chompPrefix \"foo:bar:\" \"foo:bar:baz\"
442 Just \"baz\"
443
444 \>>> chompPrefix \"foo:bar:\" \"foo:bar:\"
445 Just \"\"
446
447 \>>> chompPrefix \"foo:bar:\" \"foo:bar\"
448 Just \"\"
449
450 \>>> chompPrefix \"foo:bar:\" \"foo:barbaz\"
451 Nothing
452 -}
453 chompPrefix :: String -> String -> Maybe String
454 chompPrefix pfx str =
455 if pfx `isPrefixOf` str || str == init pfx
456 then Just $ drop (length pfx) str
457 else Nothing
458
459 -- | Breaks a string in lines with length \<= maxWidth.
460 --
461 -- NOTE: The split is OK if:
462 --
463 -- * It doesn't break a word, i.e. the next line begins with space
464 -- (@isSpace . head $ rest@) or the current line ends with space
465 -- (@null revExtra@);
466 --
467 -- * It breaks a very big word that doesn't fit anyway (@null revLine@).
468 wrap :: Int -- ^ maxWidth
469 -> String -- ^ string that needs wrapping
470 -> [String] -- ^ string \"broken\" in lines
471 wrap maxWidth = filter (not . null) . map trim . wrap0
472 where wrap0 :: String -> [String]
473 wrap0 text
474 | length text <= maxWidth = [text]
475 | isSplitOK = line : wrap0 rest
476 | otherwise = line' : wrap0 rest'
477 where (line, rest) = splitAt maxWidth text
478 (revExtra, revLine) = break isSpace . reverse $ line
479 (line', rest') = (reverse revLine, reverse revExtra ++ rest)
480 isSplitOK =
481 null revLine || null revExtra || startsWithSpace rest
482 startsWithSpace (x:_) = isSpace x
483 startsWithSpace _ = False
484
485 -- | Removes surrounding whitespace. Should only be used in small
486 -- strings.
487 trim :: String -> String
488 trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
489
490 -- | A safer head version, with a default value.
491 defaultHead :: a -> [a] -> a
492 defaultHead def [] = def
493 defaultHead _ (x:_) = x
494
495 -- | A 'head' version in the I/O monad, for validating parameters
496 -- without which we cannot continue.
497 exitIfEmpty :: String -> [a] -> IO a
498 exitIfEmpty _ (x:_) = return x
499 exitIfEmpty s [] = exitErr s
500
501 -- | Obtain the unique element of a list in an arbitrary monad.
502 monadicThe :: (Eq a, Monad m) => String -> [a] -> m a
503 monadicThe s [] = fail s
504 monadicThe s (x:xs)
505 | all (x ==) xs = return x
506 | otherwise = fail s
507
508 -- | Split an 'Either' list into two separate lists (containing the
509 -- 'Left' and 'Right' elements, plus a \"trail\" list that allows
510 -- recombination later.
511 --
512 -- This is splitter; for recombination, look at 'recombineEithers'.
513 -- The sum of \"left\" and \"right\" lists should be equal to the
514 -- original list length, and the trail list should be the same length
515 -- as well. The entries in the resulting lists are reversed in
516 -- comparison with the original list.
517 splitEithers :: [Either a b] -> ([a], [b], [Bool])
518 splitEithers = foldl' splitter ([], [], [])
519 where splitter (l, r, t) e =
520 case e of
521 Left v -> (v:l, r, False:t)
522 Right v -> (l, v:r, True:t)
523
524 -- | Recombines two \"left\" and \"right\" lists using a \"trail\"
525 -- list into a single 'Either' list.
526 --
527 -- This is the counterpart to 'splitEithers'. It does the opposite
528 -- transformation, and the output list will be the reverse of the
529 -- input lists. Since 'splitEithers' also reverses the lists, calling
530 -- these together will result in the original list.
531 --
532 -- Mismatches in the structure of the lists (e.g. inconsistent
533 -- lengths) are represented via 'Bad'; normally this function should
534 -- not fail, if lists are passed as generated by 'splitEithers'.
535 recombineEithers :: (Show a, Show b) =>
536 [a] -> [b] -> [Bool] -> Result [Either a b]
537 recombineEithers lefts rights trail =
538 foldM recombiner ([], lefts, rights) trail >>= checker
539 where checker (eithers, [], []) = Ok eithers
540 checker (_, lefts', rights') =
541 Bad $ "Inconsistent results after recombination, l'=" ++
542 show lefts' ++ ", r'=" ++ show rights'
543 recombiner (es, l:ls, rs) False = Ok (Left l:es, ls, rs)
544 recombiner (es, ls, r:rs) True = Ok (Right r:es, ls, rs)
545 recombiner (_, ls, rs) t = Bad $ "Inconsistent trail log: l=" ++
546 show ls ++ ", r=" ++ show rs ++ ",t=" ++
547 show t
548
549 -- | Default hints for the resolver
550 resolveAddrHints :: Maybe AddrInfo
551 resolveAddrHints =
552 Just defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV] }
553
554 -- | Resolves a numeric address.
555 resolveAddr :: Int -> String -> IO (Result (Family, SockAddr))
556 resolveAddr port str = do
557 resolved <- getAddrInfo resolveAddrHints (Just str) (Just (show port))
558 return $ case resolved of
559 [] -> Bad "Invalid results from lookup?"
560 best:_ -> Ok (addrFamily best, addrAddress best)
561
562 -- | Set the owner and the group of a file (given as names, not numeric id).
563 setOwnerAndGroupFromNames :: FilePath -> GanetiDaemon -> GanetiGroup -> IO ()
564 setOwnerAndGroupFromNames filename daemon dGroup = do
565 -- TODO: it would be nice to rework this (or getEnts) so that runtimeEnts
566 -- is read only once per daemon startup, and then cached for further usage.
567 runtimeEnts <- runResultT getEnts
568 ents <- exitIfBad "Can't find required user/groups" runtimeEnts
569 -- note: we use directly ! as lookup failures shouldn't happen, due
570 -- to the map construction
571 let uid = reUserToUid ents M.! daemon
572 let gid = reGroupToGid ents M.! dGroup
573 setOwnerAndGroup filename uid gid
574
575 -- | Resets permissions so that the owner can read/write and the group only
576 -- read. All other permissions are cleared.
577 setOwnerWGroupR :: FilePath -> IO ()
578 setOwnerWGroupR path = setFileMode path mode
579 where mode = foldl unionFileModes nullFileMode
580 [ownerReadMode, ownerWriteMode, groupReadMode]
581
582 -- | Formats an integral number, appending a suffix.
583 formatOrdinal :: (Integral a, Show a) => a -> String
584 formatOrdinal num
585 | num > 10 && num < 20 = suffix "th"
586 | tens == 1 = suffix "st"
587 | tens == 2 = suffix "nd"
588 | tens == 3 = suffix "rd"
589 | otherwise = suffix "th"
590 where tens = num `mod` 10
591 suffix s = show num ++ s
592
593 -- | Attempt, in a non-blocking way, to obtain a lock on a given file; report
594 -- back success.
595 -- Returns the file descriptor so that the lock can be released by closing
596 lockFile :: FilePath -> IO (Result Fd)
597 lockFile path = runResultT . liftIO $ do
598 handle <- openFile path WriteMode
599 fd <- handleToFd handle
600 setLock fd (WriteLock, AbsoluteSeek, 0, 0)
601 return fd
602
603 -- | File stat identifier.
604 type FStat = (EpochTime, FileID, FileOffset)
605
606 -- | Null 'FStat' value.
607 nullFStat :: FStat
608 nullFStat = (-1, -1, -1)
609
610 -- | Computes the file cache data from a FileStatus structure.
611 buildFileStatus :: FileStatus -> FStat
612 buildFileStatus ofs =
613 let modt = modificationTime ofs
614 inum = fileID ofs
615 fsize = fileSize ofs
616 in (modt, inum, fsize)
617
618 -- | Wrapper over 'buildFileStatus'. This reads the data from the
619 -- filesystem and then builds our cache structure.
620 getFStat :: FilePath -> IO FStat
621 getFStat p = liftM buildFileStatus (getFileStatus p)
622
623 -- | Safe version of 'getFStat', that ignores IOErrors.
624 getFStatSafe :: FilePath -> IO FStat
625 getFStatSafe fpath = liftM (either (const nullFStat) id)
626 ((try $ getFStat fpath) :: IO (Either IOError FStat))
627
628 -- | Check if the file needs reloading
629 needsReload :: FStat -> FilePath -> IO (Maybe FStat)
630 needsReload oldstat path = do
631 newstat <- getFStat path
632 return $ if newstat /= oldstat
633 then Just newstat
634 else Nothing
635
636 -- | Until the given point in time (useconds since the epoch), wait
637 -- for the output of a given method to change and return the new value;
638 -- make use of the promise that the output only changes if the reference
639 -- has a value different than the given one.
640 watchFileEx :: (Eq b) => Integer -> b -> IORef b -> (a -> Bool) -> IO a -> IO a
641 watchFileEx endtime base ref check read_fn = do
642 current <- getCurrentTimeUSec
643 if current > endtime then read_fn else do
644 val <- readIORef ref
645 if val /= base
646 then do
647 new <- read_fn
648 if check new then return new else do
649 logDebug "Observed change not relevant"
650 threadDelay 100000
651 watchFileEx endtime val ref check read_fn
652 else do
653 threadDelay 100000
654 watchFileEx endtime base ref check read_fn
655
656 -- | Within the given timeout (in seconds), wait for for the output
657 -- of the given method to satisfy a given predicate and return the new value;
658 -- make use of the promise that the method will only change its value, if
659 -- the given file changes on disk. If the file does not exist on disk, return
660 -- immediately.
661 watchFileBy :: FilePath -> Int -> (a -> Bool) -> IO a -> IO a
662 watchFileBy fpath timeout check read_fn = do
663 current <- getCurrentTimeUSec
664 let endtime = current + fromIntegral timeout * 1000000
665 fstat <- getFStatSafe fpath
666 ref <- newIORef fstat
667 bracket initINotify killINotify $ \inotify -> do
668 let do_watch e = do
669 logDebug $ "Notified of change in " ++ fpath
670 ++ "; event: " ++ show e
671 when (e == Ignored)
672 (addWatch inotify [Modify, Delete] fpath do_watch
673 >> return ())
674 fstat' <- getFStatSafe fpath
675 writeIORef ref fstat'
676 _ <- addWatch inotify [Modify, Delete] fpath do_watch
677 newval <- read_fn
678 if check newval
679 then do
680 logDebug $ "File " ++ fpath ++ " changed during setup of inotify"
681 return newval
682 else watchFileEx endtime fstat ref check read_fn
683
684 -- | Within the given timeout (in seconds), wait for for the output
685 -- of the given method to change and return the new value; make use of
686 -- the promise that the method will only change its value, if
687 -- the given file changes on disk. If the file does not exist on disk, return
688 -- immediately.
689 watchFile :: Eq a => FilePath -> Int -> a -> IO a -> IO a
690 watchFile fpath timeout old = watchFileBy fpath timeout (/= old)
691
692 -- | Type describing ownership and permissions of newly generated
693 -- directories and files. All parameters are optional, with nothing
694 -- meaning that the default value should be left untouched.
695
696 data FilePermissions = FilePermissions { fpOwner :: Maybe GanetiDaemon
697 , fpGroup :: Maybe GanetiGroup
698 , fpPermissions :: FileMode
699 }
700
701 -- | Ensure that a given file or directory has the permissions, and
702 -- possibly ownerships, as required.
703 ensurePermissions :: FilePath -> FilePermissions -> IO (Result ())
704 ensurePermissions fpath perms = do
705 -- Fetch the list of entities
706 runtimeEnts <- runResultT getEnts
707 ents <- exitIfBad "Can't determine user/group ids" runtimeEnts
708
709 -- Get the existing file properties
710 eitherFileStatus <- try $ getFileStatus fpath
711 :: IO (Either IOError FileStatus)
712
713 -- And see if any modifications are needed
714 (flip $ either (return . Bad . show)) eitherFileStatus $ \fstat -> do
715 ownertry <- case fpOwner perms of
716 Nothing -> return $ Right ()
717 Just owner -> try $ do
718 let ownerid = reUserToUid ents M.! owner
719 unless (ownerid == fileOwner fstat) $ do
720 logDebug $ "Changing owner of " ++ fpath ++ " to " ++ show owner
721 setOwnerAndGroup fpath ownerid (-1)
722 grouptry <- case fpGroup perms of
723 Nothing -> return $ Right ()
724 Just grp -> try $ do
725 let groupid = reGroupToGid ents M.! grp
726 unless (groupid == fileGroup fstat) $ do
727 logDebug $ "Changing group of " ++ fpath ++ " to " ++ show grp
728 setOwnerAndGroup fpath (-1) groupid
729 let fp = fpPermissions perms
730 permtry <- if fileMode fstat == fp
731 then return $ Right ()
732 else try $ do
733 logInfo $ "Changing permissions of " ++ fpath ++ " to "
734 ++ showOct fp ""
735 setFileMode fpath fp
736 let errors = E.lefts ([ownertry, grouptry, permtry] :: [Either IOError ()])
737 if null errors
738 then return $ Ok ()
739 else return . Bad $ show errors
740
741 -- | Safely rename a file, creating the target directory, if needed.
742 safeRenameFile :: FilePermissions -> FilePath -> FilePath -> IO (Result ())
743 safeRenameFile perms from to = do
744 directtry <- try $ renameFile from to
745 case (directtry :: Either IOError ()) of
746 Right () -> return $ Ok ()
747 Left _ -> do
748 result <- try $ do
749 let dir = takeDirectory to
750 createDirectoryIfMissing True dir
751 _ <- ensurePermissions dir perms
752 renameFile from to
753 return $ either (Bad . show) Ok (result :: Either IOError ())