Utils.hs 25.7 KB
Newer Older
1
2
{-# LANGUAGE FlexibleContexts #-}

3
{-| Utility functions. -}
Iustin Pop's avatar
Iustin Pop committed
4

Iustin Pop's avatar
Iustin Pop committed
5
6
{-

7
Copyright (C) 2009, 2010, 2011, 2012, 2013 Google Inc.
Iustin Pop's avatar
Iustin Pop committed
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.

-}

26
module Ganeti.Utils
27
28
29
30
31
32
33
34
35
  ( debug
  , debugFn
  , debugXy
  , sepSplit
  , stdDev
  , if'
  , select
  , applyIf
  , commaJoin
36
  , ensureQuoted
37
38
  , tryRead
  , formatTable
39
  , printTable
40
  , parseUnit
41
  , parseUnitAssumeBinary
42
  , plural
43
44
  , niceSort
  , niceSortKey
Iustin Pop's avatar
Iustin Pop committed
45
46
47
48
  , exitIfBad
  , exitErr
  , exitWhen
  , exitUnless
49
  , logWarningIfBad
50
  , rStripSpace
51
  , newUUID
52
  , getCurrentTime
53
  , getCurrentTimeUSec
54
  , clockTimeToString
55
56
  , clockTimeToCTime
  , cTimeToClockTime
57
  , chompPrefix
58
  , warn
Yiannis Tsiouris's avatar
Yiannis Tsiouris committed
59
60
  , wrap
  , trim
61
62
  , defaultHead
  , exitIfEmpty
63
64
  , splitEithers
  , recombineEithers
65
  , resolveAddr
66
  , monadicThe
67
  , setOwnerAndGroupFromNames
68
  , setOwnerWGroupR
Hrvoje Ribicic's avatar
Hrvoje Ribicic committed
69
  , formatOrdinal
70
  , tryAndLogIOError
Klaus Aehlig's avatar
Klaus Aehlig committed
71
  , lockFile
72
73
  , FStat
  , nullFStat
Klaus Aehlig's avatar
Klaus Aehlig committed
74
  , getFStat
Klaus Aehlig's avatar
Klaus Aehlig committed
75
  , getFStatSafe
76
  , needsReload
77
  , watchFile
78
  , watchFileBy
79
  , safeRenameFile
80
  , FilePermissions(..)
Klaus Aehlig's avatar
Klaus Aehlig committed
81
  , ensurePermissions
82
  ) where
Iustin Pop's avatar
Iustin Pop committed
83

84
import Control.Concurrent
85
import Control.Exception (try, bracket)
86
87
import Control.Monad
import Control.Monad.Error
88
import Data.Char (toUpper, isAlphaNum, isDigit, isSpace)
Klaus Aehlig's avatar
Klaus Aehlig committed
89
import qualified Data.Either as E
90
import Data.Function (on)
91
import Data.IORef
92
import Data.List
93
import qualified Data.Map as M
94
import Foreign.C.Types (CTime(..))
Klaus Aehlig's avatar
Klaus Aehlig committed
95
import Numeric (showOct)
96
import System.Directory (renameFile, createDirectoryIfMissing)
97
import System.FilePath.Posix (takeDirectory)
98
import System.INotify
99
import System.Posix.Types
Iustin Pop's avatar
Iustin Pop committed
100
101

import Debug.Trace
102
import Network.Socket
Iustin Pop's avatar
Iustin Pop committed
103

Iustin Pop's avatar
Iustin Pop committed
104
import Ganeti.BasicTypes
105
import qualified Ganeti.ConstantUtils as ConstantUtils
106
import Ganeti.Logging
107
import Ganeti.Runtime
Iustin Pop's avatar
Iustin Pop committed
108
109
import System.IO
import System.Exit
110
import System.Posix.Files
Klaus Aehlig's avatar
Klaus Aehlig committed
111
import System.Posix.IO
Klaus Aehlig's avatar
Klaus Aehlig committed
112
import System.Posix.User
113
import System.Time
Iustin Pop's avatar
Iustin Pop committed
114

Iustin Pop's avatar
Iustin Pop committed
115
116
-- * Debug functions

Iustin Pop's avatar
Iustin Pop committed
117
118
119
120
-- | To be used only for debugging, breaks referential integrity.
debug :: Show a => a -> a
debug x = trace (show x) x

121
122
-- | Displays a modified form of the second parameter before returning
-- it.
Iustin Pop's avatar
Iustin Pop committed
123
124
125
debugFn :: Show b => (a -> b) -> a -> a
debugFn fn x = debug (fn x) `seq` x

126
-- | Show the first parameter before returning the second one.
Iustin Pop's avatar
Iustin Pop committed
127
debugXy :: Show a => a -> b -> b
128
debugXy = seq . debug
Iustin Pop's avatar
Iustin Pop committed
129

130
-- * Miscellaneous
Iustin Pop's avatar
Iustin Pop committed
131

132
133
134
135
-- | Apply the function if condition holds, otherwise use default value.
applyIf :: Bool -> (a -> a) -> a -> a
applyIf b f x = if b then f x else x

Iustin Pop's avatar
Iustin Pop committed
136
137
138
139
-- | Comma-join a string list.
commaJoin :: [String] -> String
commaJoin = intercalate ","

Iustin Pop's avatar
Iustin Pop committed
140
141
-- | Split a list on a separator and return an array.
sepSplit :: Eq a => a -> [a] -> [[a]]
Iustin Pop's avatar
Iustin Pop committed
142
sepSplit sep s
143
144
145
146
147
148
  | null s    = []
  | null xs   = [x]
  | null ys   = [x,[]]
  | otherwise = x:sepSplit sep ys
  where (x, xs) = break (== sep) s
        ys = drop 1 xs
Iustin Pop's avatar
Iustin Pop committed
149

150
151
152
153
154
-- | Simple pluralize helper
plural :: Int -> String -> String -> String
plural 1 s _ = s
plural _ _ p = p

155
156
157
158
159
160
-- | Ensure a value is quoted if needed.
ensureQuoted :: String -> String
ensureQuoted v = if not (all (\c -> isAlphaNum c || c == '.') v)
                 then '\'':v ++ "'"
                 else v

Iustin Pop's avatar
Iustin Pop committed
161
162
-- * Mathematical functions

163
164
-- Simple and slow statistical functions, please replace with better
-- versions
Iustin Pop's avatar
Iustin Pop committed
165

166
-- | Standard deviation function.
Iustin Pop's avatar
Iustin Pop committed
167
168
stdDev :: [Double] -> Double
stdDev lst =
169
170
171
172
173
174
175
176
177
  -- first, calculate the list length and sum lst in a single step,
  -- for performance reasons
  let (ll', sx) = foldl' (\(rl, rs) e ->
                           let rl' = rl + 1
                               rs' = rs + e
                           in rl' `seq` rs' `seq` (rl', rs')) (0::Int, 0) lst
      ll = fromIntegral ll'::Double
      mv = sx / ll
      av = foldl' (\accu em -> let d = em - mv in accu + d * d) 0.0 lst
Iustin Pop's avatar
Iustin Pop committed
178
  in sqrt (av / ll) -- stddev
Iustin Pop's avatar
Iustin Pop committed
179

180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
-- *  Logical functions

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

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

195
196
-- * Parsing utility functions

197
-- | Parse results from readsPrec.
198
199
200
201
202
203
204
205
206
207
parseChoices :: (Monad m, Read a) => String -> String -> [(a, String)] -> m a
parseChoices _ _ ((v, ""):[]) = return v
parseChoices name s ((_, e):[]) =
    fail $ name ++ ": leftover characters when parsing '"
           ++ s ++ "': '" ++ e ++ "'"
parseChoices name s _ = fail $ name ++ ": cannot parse string '" ++ s ++ "'"

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

209
-- | Format a table of strings to maintain consistent length.
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
formatTable :: [[String]] -> [Bool] -> [[String]]
formatTable vals numpos =
    let vtrans = transpose vals  -- transpose, so that we work on rows
                                 -- rather than columns
        mlens = map (maximum . map length) vtrans
        expnd = map (\(flds, isnum, ml) ->
                         map (\val ->
                                  let delta = ml - length val
                                      filler = replicate delta ' '
                                  in if delta > 0
                                     then if isnum
                                          then filler ++ val
                                          else val ++ filler
                                     else val
                             ) flds
                    ) (zip3 vtrans numpos mlens)
   in transpose expnd
Iustin Pop's avatar
Iustin Pop committed
227

228
229
230
-- | Constructs a printable table from given header and rows
printTable :: String -> [String] -> [[String]] -> [Bool] -> String
printTable lp header rows isnum =
Iustin Pop's avatar
Iustin Pop committed
231
  unlines . map ((++) lp . (:) ' ' . unwords) $
232
233
  formatTable (header:rows) isnum

Iustin Pop's avatar
Iustin Pop committed
234
-- | Converts a unit (e.g. m or GB) into a scaling factor.
235
236
parseUnitValue :: (Monad m) => Bool -> String -> m Rational
parseUnitValue noDecimal unit
Iustin Pop's avatar
Iustin Pop committed
237
238
239
240
241
242
243
244
245
246
247
  -- binary conversions first
  | null unit                     = return 1
  | unit == "m" || upper == "MIB" = return 1
  | unit == "g" || upper == "GIB" = return kbBinary
  | unit == "t" || upper == "TIB" = return $ kbBinary * kbBinary
  -- SI conversions
  | unit == "M" || upper == "MB"  = return mbFactor
  | unit == "G" || upper == "GB"  = return $ mbFactor * kbDecimal
  | unit == "T" || upper == "TB"  = return $ mbFactor * kbDecimal * kbDecimal
  | otherwise = fail $ "Unknown unit '" ++ unit ++ "'"
  where upper = map toUpper unit
248
        kbBinary = 1024 :: Rational
249
        kbDecimal = if noDecimal then kbBinary else 1000
Iustin Pop's avatar
Iustin Pop committed
250
251
252
        decToBin = kbDecimal / kbBinary -- factor for 1K conversion
        mbFactor = decToBin * decToBin -- twice the factor for just 1K

Iustin Pop's avatar
Iustin Pop committed
253
254
255
256
-- | Tries to extract number and scale from the given string.
--
-- Input must be in the format NUMBER+ SPACE* [UNIT]. If no unit is
-- specified, it defaults to MiB. Return value is always an integral
257
258
259
-- value in MiB; if the first argument is True, all kilos are binary.
parseUnitEx :: (Monad m, Integral a, Read a) => Bool -> String -> m a
parseUnitEx noDecimal str =
260
261
  -- TODO: enhance this by splitting the unit parsing code out and
  -- accepting floating-point numbers
Iustin Pop's avatar
Iustin Pop committed
262
  case (reads str::[(Int, String)]) of
263
264
    [(v, suffix)] ->
      let unit = dropWhile (== ' ') suffix
Iustin Pop's avatar
Iustin Pop committed
265
      in do
266
        scaling <- parseUnitValue noDecimal unit
Iustin Pop's avatar
Iustin Pop committed
267
        return $ truncate (fromIntegral v * scaling)
268
    _ -> fail $ "Can't parse string '" ++ str ++ "'"
Iustin Pop's avatar
Iustin Pop committed
269

270
271
272
273
274
275
276
277
278
279
280
281
282
-- | Tries to extract number and scale from the given string.
--
-- Input must be in the format NUMBER+ SPACE* [UNIT]. If no unit is
-- specified, it defaults to MiB. Return value is always an integral
-- value in MiB.
parseUnit :: (Monad m, Integral a, Read a) => String -> m a
parseUnit = parseUnitEx False

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

Iustin Pop's avatar
Iustin Pop committed
283
284
285
-- | Unwraps a 'Result', exiting the program if it is a 'Bad' value,
-- otherwise returning the actual contained value.
exitIfBad :: String -> Result a -> IO a
286
exitIfBad msg (Bad s) = exitErr (msg ++ ": " ++ s)
Iustin Pop's avatar
Iustin Pop committed
287
288
289
290
291
exitIfBad _ (Ok v) = return v

-- | Exits immediately with an error message.
exitErr :: String -> IO a
exitErr errmsg = do
292
  hPutStrLn stderr $ "Error: " ++ errmsg
Iustin Pop's avatar
Iustin Pop committed
293
294
295
296
297
298
299
300
301
302
303
  exitWith (ExitFailure 1)

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

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

305
306
307
308
309
310
311
312
-- | Unwraps a 'Result', logging a warning message and then returning a default
-- value if it is a 'Bad' value, otherwise returning the actual contained value.
logWarningIfBad :: String -> a -> Result a -> IO a
logWarningIfBad msg defVal (Bad s) = do
  logWarning $ msg ++ ": " ++ s
  return defVal
logWarningIfBad _ _ (Ok v) = return v

313
314
315
316
317
318
319
320
321
322
-- | Try an IO interaction, log errors and unfold as a 'Result'.
tryAndLogIOError :: IO a -> String -> (a -> Result b) -> IO (Result b)
tryAndLogIOError io msg okfn =
 try io >>= either
   (\ e -> do
       let combinedmsg = msg ++ ": " ++ show (e :: IOError)
       logError combinedmsg
       return . Bad $ combinedmsg)
   (return . okfn)

323
324
325
326
-- | Print a warning, but do not exit.
warn :: String -> IO ()
warn = hPutStrLn stderr . (++) "Warning: "

327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
-- | Helper for 'niceSort'. Computes the key element for a given string.
extractKey :: [Either Integer String]  -- ^ Current (partial) key, reversed
           -> String                   -- ^ Remaining string
           -> ([Either Integer String], String)
extractKey ek [] = (reverse ek, [])
extractKey ek xs@(x:_) =
  let (span_fn, conv_fn) = if isDigit x
                             then (isDigit, Left . read)
                             else (not . isDigit, Right)
      (k, rest) = span span_fn xs
  in extractKey (conv_fn k:ek) rest

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

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

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

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

-}
niceSort :: [String] -> [String]
356
niceSort = niceSortKey id
357
358
359
360
361
362
363
364
365

-- | Key-version of 'niceSort'. We use 'sortBy' and @compare `on` fst@
-- since we don't want to add an ordering constraint on the /a/ type,
-- hence the need to only compare the first element of the /(key, a)/
-- tuple.
niceSortKey :: (a -> String) -> [a] -> [a]
niceSortKey keyfn =
  map snd . sortBy (compare `on` fst) .
  map (\s -> (fst . extractKey [] $ keyfn s, s))
366
367
368
369
370

-- | Strip space characthers (including newline). As this is
-- expensive, should only be run on small strings.
rStripSpace :: String -> String
rStripSpace = reverse . dropWhile isSpace . reverse
371
372
373
374
375

-- | Returns a random UUID.
-- This is a Linux-specific method as it uses the /proc filesystem.
newUUID :: IO String
newUUID = do
376
  contents <- readFile ConstantUtils.randomUuidFile
377
  return $! rStripSpace $ take 128 contents
378

379
380
-- | Returns the current time as an 'Integer' representing the number
-- of seconds from the Unix epoch.
381
382
383
384
385
getCurrentTime :: IO Integer
getCurrentTime = do
  TOD ctime _ <- getClockTime
  return ctime

386
387
388
389
390
391
392
393
394
-- | Returns the current time as an 'Integer' representing the number
-- of microseconds from the Unix epoch (hence the need for 'Integer').
getCurrentTimeUSec :: IO Integer
getCurrentTimeUSec = do
  TOD ctime pico <- getClockTime
  -- pico: 10^-12, micro: 10^-6, so we have to shift seconds left and
  -- picoseconds right
  return $ ctime * 1000000 + pico `div` 1000000

395
396
397
-- | Convert a ClockTime into a (seconds-only) timestamp.
clockTimeToString :: ClockTime -> String
clockTimeToString (TOD t _) = show t
398

399
400
401
402
403
404
405
406
-- | Convert a ClockTime into a (seconds-only) 'EpochTime' (AKA @time_t@).
clockTimeToCTime :: ClockTime -> EpochTime
clockTimeToCTime (TOD secs _) = fromInteger secs

-- | Convert a ClockTime into a (seconds-only) 'EpochTime' (AKA @time_t@).
cTimeToClockTime :: EpochTime -> ClockTime
cTimeToClockTime (CTime timet) = TOD (toInteger timet) 0

407
408
409
410
{-| Strip a prefix from a string, allowing the last character of the prefix
(which is assumed to be a separator) to be absent from the string if the string
terminates there.

411
\>>> chompPrefix \"foo:bar:\" \"a:b:c\"
412
413
Nothing

414
415
\>>> chompPrefix \"foo:bar:\" \"foo:bar:baz\"
Just \"baz\"
416

417
418
\>>> chompPrefix \"foo:bar:\" \"foo:bar:\"
Just \"\"
419

420
421
\>>> chompPrefix \"foo:bar:\" \"foo:bar\"
Just \"\"
422

423
\>>> chompPrefix \"foo:bar:\" \"foo:barbaz\"
424
425
426
427
428
429
430
Nothing
-}
chompPrefix :: String -> String -> Maybe String
chompPrefix pfx str =
  if pfx `isPrefixOf` str || str == init pfx
    then Just $ drop (length pfx) str
    else Nothing
Yiannis Tsiouris's avatar
Yiannis Tsiouris committed
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461

-- | Breaks a string in lines with length \<= maxWidth.
--
-- NOTE: The split is OK if:
--
-- * It doesn't break a word, i.e. the next line begins with space
--   (@isSpace . head $ rest@) or the current line ends with space
--   (@null revExtra@);
--
-- * It breaks a very big word that doesn't fit anyway (@null revLine@).
wrap :: Int      -- ^ maxWidth
     -> String   -- ^ string that needs wrapping
     -> [String] -- ^ string \"broken\" in lines
wrap maxWidth = filter (not . null) . map trim . wrap0
  where wrap0 :: String -> [String]
        wrap0 text
          | length text <= maxWidth = [text]
          | isSplitOK               = line : wrap0 rest
          | otherwise               = line' : wrap0 rest'
          where (line, rest) = splitAt maxWidth text
                (revExtra, revLine) = break isSpace . reverse $ line
                (line', rest') = (reverse revLine, reverse revExtra ++ rest)
                isSplitOK =
                  null revLine || null revExtra || startsWithSpace rest
                startsWithSpace (x:_) = isSpace x
                startsWithSpace _     = False

-- | Removes surrounding whitespace. Should only be used in small
-- strings.
trim :: String -> String
trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
462
463
464
465
466
467
468
469
470
471
472

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

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

474
475
476
477
478
479
480
-- | Obtain the unique element of a list in an arbitrary monad.
monadicThe :: (Eq a, Monad m) => String -> [a] -> m a
monadicThe s [] = fail s
monadicThe s (x:xs)
  | all (x ==) xs = return x
  | otherwise = fail s

481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
-- | Split an 'Either' list into two separate lists (containing the
-- 'Left' and 'Right' elements, plus a \"trail\" list that allows
-- recombination later.
--
-- This is splitter; for recombination, look at 'recombineEithers'.
-- The sum of \"left\" and \"right\" lists should be equal to the
-- original list length, and the trail list should be the same length
-- as well. The entries in the resulting lists are reversed in
-- comparison with the original list.
splitEithers :: [Either a b] -> ([a], [b], [Bool])
splitEithers = foldl' splitter ([], [], [])
  where splitter (l, r, t) e =
          case e of
            Left  v -> (v:l, r, False:t)
            Right v -> (l, v:r, True:t)

-- | Recombines two \"left\" and \"right\" lists using a \"trail\"
-- list into a single 'Either' list.
--
-- This is the counterpart to 'splitEithers'. It does the opposite
-- transformation, and the output list will be the reverse of the
-- input lists. Since 'splitEithers' also reverses the lists, calling
-- these together will result in the original list.
--
-- Mismatches in the structure of the lists (e.g. inconsistent
-- lengths) are represented via 'Bad'; normally this function should
-- not fail, if lists are passed as generated by 'splitEithers'.
recombineEithers :: (Show a, Show b) =>
                    [a] -> [b] -> [Bool] -> Result [Either a b]
recombineEithers lefts rights trail =
  foldM recombiner ([], lefts, rights) trail >>= checker
    where checker (eithers, [], []) = Ok eithers
          checker (_, lefts', rights') =
            Bad $ "Inconsistent results after recombination, l'=" ++
                show lefts' ++ ", r'=" ++ show rights'
          recombiner (es, l:ls, rs) False = Ok (Left l:es,  ls, rs)
          recombiner (es, ls, r:rs) True  = Ok (Right r:es, ls, rs)
          recombiner (_,  ls, rs) t = Bad $ "Inconsistent trail log: l=" ++
                                      show ls ++ ", r=" ++ show rs ++ ",t=" ++
                                      show t
521
522
523
524
525
526
527
528
529
530
531
532
533

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

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

535
536
537
538
539
-- | Set the owner and the group of a file (given as names, not numeric id).
setOwnerAndGroupFromNames :: FilePath -> GanetiDaemon -> GanetiGroup -> IO ()
setOwnerAndGroupFromNames filename daemon dGroup = do
  -- TODO: it would be nice to rework this (or getEnts) so that runtimeEnts
  -- is read only once per daemon startup, and then cached for further usage.
540
  runtimeEnts <- runResultT getEnts
541
542
543
  ents <- exitIfBad "Can't find required user/groups" runtimeEnts
  -- note: we use directly ! as lookup failures shouldn't happen, due
  -- to the map construction
544
545
  let uid = reUserToUid ents M.! daemon
  let gid = reGroupToGid ents M.! dGroup
546
  setOwnerAndGroup filename uid gid
Hrvoje Ribicic's avatar
Hrvoje Ribicic committed
547

548
549
550
551
552
553
554
-- | Resets permissions so that the owner can read/write and the group only
-- read. All other permissions are cleared.
setOwnerWGroupR :: FilePath -> IO ()
setOwnerWGroupR path = setFileMode path mode
  where mode = foldl unionFileModes nullFileMode
                     [ownerReadMode, ownerWriteMode, groupReadMode]

Hrvoje Ribicic's avatar
Hrvoje Ribicic committed
555
556
557
558
559
560
561
562
563
564
-- | Formats an integral number, appending a suffix.
formatOrdinal :: (Integral a, Show a) => a -> String
formatOrdinal num
  | num > 10 && num < 20 = suffix "th"
  | tens == 1            = suffix "st"
  | tens == 2            = suffix "nd"
  | tens == 3            = suffix "rd"
  | otherwise            = suffix "th"
  where tens     = num `mod` 10
        suffix s = show num ++ s
565

Klaus Aehlig's avatar
Klaus Aehlig committed
566
567
-- | Attempt, in a non-blocking way, to obtain a lock on a given file; report
-- back success.
568
569
-- Returns the file descriptor so that the lock can be released by closing
lockFile :: FilePath -> IO (Result Fd)
570
lockFile path = runResultT . liftIO $ do
Klaus Aehlig's avatar
Klaus Aehlig committed
571
572
  handle <- openFile path WriteMode
  fd <- handleToFd handle
573
  setLock fd (WriteLock, AbsoluteSeek, 0, 0)
574
  return fd
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595

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

-- | Null 'FStat' value.
nullFStat :: FStat
nullFStat = (-1, -1, -1)

-- | Computes the file cache data from a FileStatus structure.
buildFileStatus :: FileStatus -> FStat
buildFileStatus ofs =
    let modt = modificationTime ofs
        inum = fileID ofs
        fsize = fileSize ofs
    in (modt, inum, fsize)

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

Klaus Aehlig's avatar
Klaus Aehlig committed
596
597
598
599
600
-- | Safe version of 'getFStat', that ignores IOErrors.
getFStatSafe :: FilePath -> IO FStat
getFStatSafe fpath = liftM (either (const nullFStat) id)
                       ((try $ getFStat fpath) :: IO (Either IOError FStat))

601
602
603
604
605
606
607
-- | Check if the file needs reloading
needsReload :: FStat -> FilePath -> IO (Maybe FStat)
needsReload oldstat path = do
  newstat <- getFStat path
  return $ if newstat /= oldstat
             then Just newstat
             else Nothing
608
609
610
611
612

-- | Until the given point in time (useconds since the epoch), wait
-- for the output of a given method to change and return the new value;
-- make use of the promise that the output only changes if the reference
-- has a value different than the given one.
613
614
watchFileEx :: (Eq b) => Integer -> b -> IORef b -> (a -> Bool) -> IO a -> IO a
watchFileEx endtime base ref check read_fn = do
615
616
617
618
619
620
  current <- getCurrentTimeUSec
  if current > endtime then read_fn else do
    val <- readIORef ref
    if val /= base
      then do
        new <- read_fn
621
        if check new then return new else do
622
          logDebug "Observed change not relevant"
623
          threadDelay 100000
624
625
          watchFileEx endtime val ref check read_fn
      else do
626
       threadDelay 100000
627
       watchFileEx endtime base ref check read_fn
628
629

-- | Within the given timeout (in seconds), wait for for the output
630
631
-- of the given method to satisfy a given predicate and return the new value;
-- make use of the promise that the method will only change its value, if
632
633
-- the given file changes on disk. If the file does not exist on disk, return
-- immediately.
634
635
watchFileBy :: FilePath -> Int -> (a -> Bool) -> IO a -> IO a
watchFileBy fpath timeout check read_fn = do
636
637
638
639
  current <- getCurrentTimeUSec
  let endtime = current + fromIntegral timeout * 1000000
  fstat <- getFStatSafe fpath
  ref <- newIORef fstat
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
  bracket initINotify killINotify $ \inotify -> do
    let do_watch e = do
                       logDebug $ "Notified of change in " ++ fpath
                                    ++ "; event: " ++ show e
                       when (e == Ignored)
                         (addWatch inotify [Modify, Delete] fpath do_watch
                            >> return ())
                       fstat' <- getFStatSafe fpath
                       writeIORef ref fstat'
    _ <- addWatch inotify [Modify, Delete] fpath do_watch
    newval <- read_fn
    if check newval
      then do
        logDebug $ "File " ++ fpath ++ " changed during setup of inotify"
        return newval
      else watchFileEx endtime fstat ref check read_fn

-- | Within the given timeout (in seconds), wait for for the output
-- of the given method to change and return the new value; make use of
-- the promise that the method will only change its value, if
-- the given file changes on disk. If the file does not exist on disk, return
-- immediately.
watchFile :: Eq a => FilePath -> Int -> a -> IO a -> IO a
watchFile fpath timeout old = watchFileBy fpath timeout (/= old)
664
665
666
667
668
669
670
671
672
673

-- | Type describing ownership and permissions of newly generated
-- directories and files. All parameters are optional, with nothing
-- meaning that the default value should be left untouched.

data FilePermissions = FilePermissions { fpOwner :: Maybe String
                                       , fpGroup :: Maybe String
                                       , fpPermissions :: FileMode
                                       }

Klaus Aehlig's avatar
Klaus Aehlig committed
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
-- | Ensure that a given file or directory has the permissions, and
-- possibly ownerships, as required.
ensurePermissions :: FilePath -> FilePermissions -> IO (Result ())
ensurePermissions fpath perms = do
  eitherFileStatus <- try $ getFileStatus fpath
                      :: IO (Either IOError FileStatus)
  (flip $ either (return . Bad . show)) eitherFileStatus $ \fstat -> do
    ownertry <- case fpOwner perms of
      Nothing -> return $ Right ()
      Just owner -> try $ do
        ownerid <- userID `liftM` getUserEntryForName owner
        unless (ownerid == fileOwner fstat) $ do
          logDebug $ "Changing owner of " ++ fpath ++ " to " ++ owner
          setOwnerAndGroup fpath ownerid (-1)
    grouptry <- case fpGroup perms of
      Nothing -> return $ Right ()
      Just grp -> try $ do
        groupid <- groupID `liftM` getGroupEntryForName grp
        unless (groupid == fileGroup fstat) $ do
          logDebug $ "Changing group of " ++ fpath ++ " to " ++ grp
          setOwnerAndGroup fpath (-1) groupid
    let fp = fpPermissions perms
    permtry <- if fileMode fstat == fp
      then return $ Right ()
      else try $ do
        logInfo $ "Changing permissions of " ++ fpath ++ " to "
                    ++ showOct fp ""
        setFileMode fpath fp
    let errors = E.lefts ([ownertry, grouptry, permtry] :: [Either IOError ()])
    if null errors
      then return $ Ok ()
      else return . Bad $ show errors

707
-- | Safely rename a file, creating the target directory, if needed.
708
709
710
711
712
713
714
715
716
717
718
719
safeRenameFile :: FilePermissions -> FilePath -> FilePath -> IO (Result ())
safeRenameFile perms from to = do
  directtry <- try $ renameFile from to
  case (directtry :: Either IOError ()) of
    Right () -> return $ Ok ()
    Left _ -> do
      result <- try $ do
        let dir = takeDirectory to
        createDirectoryIfMissing True dir
        _ <- ensurePermissions dir perms
        renameFile from to
      return $ either (Bad . show) Ok (result :: Either IOError ())