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