Revision a2a1a8ca
b/src/Ganeti/Utils.hs | ||
---|---|---|
1 |
{-# LANGUAGE FlexibleContexts #-} |
|
2 |
|
|
1 | 3 |
{-| Utility functions. -} |
2 | 4 |
|
3 | 5 |
{- |
... | ... | |
61 | 63 |
, resolveAddr |
62 | 64 |
, monadicThe |
63 | 65 |
, setOwnerAndGroupFromNames |
66 |
, setOwnerWGroupR |
|
64 | 67 |
, formatOrdinal |
65 | 68 |
, atomicWriteFile |
69 |
, atomicUpdateFile |
|
70 |
, atomicUpdateLockedFile |
|
71 |
, atomicUpdateLockedFile_ |
|
66 | 72 |
, tryAndLogIOError |
67 | 73 |
, lockFile |
74 |
, withLockedFile |
|
68 | 75 |
, FStat |
69 | 76 |
, nullFStat |
70 | 77 |
, getFStat |
... | ... | |
78 | 85 |
|
79 | 86 |
import Control.Concurrent |
80 | 87 |
import Control.Exception (try) |
81 |
import Control.Monad (foldM, liftM, when, unless) |
|
82 |
import Control.Monad.IO.Class (liftIO) |
|
88 |
import qualified Control.Exception.Lifted as L |
|
89 |
import Control.Monad |
|
90 |
import Control.Monad.Base (MonadBase(..)) |
|
91 |
import Control.Monad.Error |
|
92 |
import Control.Monad.Trans.Control |
|
83 | 93 |
import Data.Char (toUpper, isAlphaNum, isDigit, isSpace) |
84 | 94 |
import qualified Data.Either as E |
85 | 95 |
import Data.Function (on) |
... | ... | |
531 | 541 |
let gid = snd ents M.! dGroup |
532 | 542 |
setOwnerAndGroup filename uid gid |
533 | 543 |
|
544 |
-- | Resets permissions so that the owner can read/write and the group only |
|
545 |
-- read. All other permissions are cleared. |
|
546 |
setOwnerWGroupR :: FilePath -> IO () |
|
547 |
setOwnerWGroupR path = setFileMode path mode |
|
548 |
where mode = foldl unionFileModes nullFileMode |
|
549 |
[ownerReadMode, ownerWriteMode, groupReadMode] |
|
550 |
|
|
534 | 551 |
-- | Formats an integral number, appending a suffix. |
535 | 552 |
formatOrdinal :: (Integral a, Show a) => a -> String |
536 | 553 |
formatOrdinal num |
... | ... | |
545 | 562 |
-- | Atomically write a file, by first writing the contents into a temporary |
546 | 563 |
-- file and then renaming it to the old position. |
547 | 564 |
atomicWriteFile :: FilePath -> String -> IO () |
548 |
atomicWriteFile path contents = do |
|
549 |
(tmppath, tmphandle) <- openTempFile (takeDirectory path) (takeBaseName path) |
|
550 |
hPutStr tmphandle contents |
|
551 |
hClose tmphandle |
|
552 |
renameFile tmppath path |
|
565 |
atomicWriteFile path contents = atomicUpdateFile path |
|
566 |
(\_ fh -> hPutStr fh contents) |
|
567 |
|
|
568 |
-- | Atomically update a file, by first creating a temporary file, running the |
|
569 |
-- given action on it, and then renaming it to the old position. |
|
570 |
-- Usually the action will write to the file and update its permissions. |
|
571 |
-- The action is allowed to close the file descriptor, but isn't required to do |
|
572 |
-- so. |
|
573 |
atomicUpdateFile :: (MonadBaseControl IO m) |
|
574 |
=> FilePath -> (FilePath -> Handle -> m a) -> m a |
|
575 |
atomicUpdateFile path action = do |
|
576 |
(tmppath, tmphandle) <- liftBase $ openTempFile (takeDirectory path) |
|
577 |
(takeBaseName path) |
|
578 |
r <- L.finally (action tmppath tmphandle) (liftBase $ hClose tmphandle) |
|
579 |
-- if all went well, rename the file |
|
580 |
liftBase $ renameFile tmppath path |
|
581 |
return r |
|
582 |
|
|
583 |
-- | Opens a file in a R/W mode, locks it (blocking if needed) and runs |
|
584 |
-- a given action while the file is locked. Releases the lock and |
|
585 |
-- closes the file afterwards. |
|
586 |
withLockedFile :: (MonadError e m, Error e, MonadBaseControl IO m) |
|
587 |
=> FilePath -> (Fd -> m a) -> m a |
|
588 |
withLockedFile path = |
|
589 |
L.bracket (openAndLock path) (liftBase . closeFd) |
|
590 |
where |
|
591 |
openAndLock :: (MonadError e m, Error e, MonadBaseControl IO m) |
|
592 |
=> FilePath -> m Fd |
|
593 |
openAndLock p = liftBase $ do |
|
594 |
fd <- openFd p ReadWrite Nothing defaultFileFlags |
|
595 |
waitToSetLock fd (WriteLock, AbsoluteSeek, 0, 0) |
|
596 |
return fd |
|
597 |
|
|
598 |
-- | Just as 'atomicUpdateFile', but in addition locks the file during the |
|
599 |
-- operation using 'withLockedFile' and checks if the file has been modified. |
|
600 |
-- The action is only run if it hasn't, otherwise an error is thrown. |
|
601 |
-- The file must exist. |
|
602 |
-- Returns the new file status after the operation is finished. |
|
603 |
atomicUpdateLockedFile :: FilePath |
|
604 |
-> FStat |
|
605 |
-> (FilePath -> Handle -> IO a) |
|
606 |
-> ResultT IOError IO (FStat, a) |
|
607 |
atomicUpdateLockedFile path fstat action = |
|
608 |
withLockedFile path checkStatAndRun |
|
609 |
where |
|
610 |
checkStatAndRun _ = do |
|
611 |
newstat <- liftIO $ getFStat path |
|
612 |
unless (fstat == newstat) |
|
613 |
(failError $ "Cannot overwrite file " ++ path ++ |
|
614 |
": it has been modified since last written" ++ |
|
615 |
" (" ++ show fstat ++ " != " ++ show newstat ++ ")") |
|
616 |
liftIO $ atomicUpdateFile path actionAndStat |
|
617 |
actionAndStat tmppath tmphandle = do |
|
618 |
r <- action tmppath tmphandle |
|
619 |
hClose tmphandle -- close the handle so that we get meaningful stats |
|
620 |
finalstat <- liftIO $ getFStat tmppath |
|
621 |
return (finalstat, r) |
|
622 |
|
|
623 |
-- | Just as 'atomicUpdateLockedFile', but discards the action result. |
|
624 |
atomicUpdateLockedFile_ :: FilePath |
|
625 |
-> FStat |
|
626 |
-> (FilePath -> Handle -> IO a) |
|
627 |
-> ResultT IOError IO FStat |
|
628 |
atomicUpdateLockedFile_ path oldstat |
|
629 |
= liftM fst . atomicUpdateLockedFile path oldstat |
|
553 | 630 |
|
554 | 631 |
-- | Attempt, in a non-blocking way, to obtain a lock on a given file; report |
555 | 632 |
-- back success. |
Also available in: Unified diff