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