Merge branch 'stable-2.16' into stable-2.17
[ganeti-github.git] / src / Ganeti / Utils / Atomic.hs
1 {-# LANGUAGE FlexibleContexts #-}
2
3 {-| Utility functions for atomic file access. -}
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.Atomic
36 ( atomicWriteFile
37 , atomicUpdateFile
38 , withLockedFile
39 , atomicUpdateLockedFile
40 , atomicUpdateLockedFile_
41 ) where
42
43 import qualified Control.Exception.Lifted as L
44 import Control.Monad
45 import Control.Monad.Base (MonadBase(..))
46 import Control.Monad.Error.Class (MonadError)
47 import Control.Monad.Trans.Control
48 import System.FilePath.Posix (takeDirectory, takeBaseName)
49 import System.IO
50 import System.Directory (renameFile)
51 import System.Posix.IO
52 import System.Posix.Types
53
54 import Ganeti.BasicTypes
55 import Ganeti.Errors
56 import Ganeti.Logging (logAlert)
57 import Ganeti.Utils
58 import Ganeti.Utils.UniStd (fsyncFile)
59
60 -- | Atomically write a file, by first writing the contents into a temporary
61 -- file and then renaming it to the old position.
62 atomicWriteFile :: FilePath -> String -> IO ()
63 atomicWriteFile path contents = atomicUpdateFile path
64 (\_ fh -> hPutStr fh contents)
65
66 -- | Calls fsync(2) on a given file.
67 -- If the operation fails, issue an alert log message and continue.
68 -- Doesn't throw an exception.
69 fsyncFileChecked :: FilePath -> IO ()
70 fsyncFileChecked path =
71 runResultT (fsyncFile path) >>= genericResult logMsg return
72 where
73 logMsg e = logAlert $ "Can't fsync file '" ++ path ++ "': " ++ e
74
75 -- | Atomically update a file, by first creating a temporary file, running the
76 -- given action on it, and then renaming it to the old position.
77 -- Usually the action will write to the file and update its permissions.
78 -- The action is allowed to close the file descriptor, but isn't required to do
79 -- so.
80 atomicUpdateFile :: (MonadBaseControl IO m)
81 => FilePath -> (FilePath -> Handle -> m a) -> m a
82 atomicUpdateFile path action = do
83 -- Put a separator on the filename pattern to produce temporary filenames
84 -- such as job-1234-NNNNNN.tmp instead of job-1234NNNNNN. The latter can cause
85 -- problems (as well as user confusion) because temporary filenames have the
86 -- same format as real filenames, and anything that scans a directory won't be
87 -- able to tell them apart.
88 let filenameTemplate = takeBaseName path ++ "-.tmp"
89 (tmppath, tmphandle) <- liftBase $ openBinaryTempFile (takeDirectory path)
90 filenameTemplate
91 r <- L.finally (action tmppath tmphandle)
92 (liftBase (hClose tmphandle >> fsyncFileChecked tmppath))
93 -- if all went well, rename the file
94 liftBase $ renameFile tmppath path
95 return r
96
97 -- | Opens a file in a R/W mode, locks it (blocking if needed) and runs
98 -- a given action while the file is locked. Releases the lock and
99 -- closes the file afterwards.
100 withLockedFile :: (MonadError e m, FromString e, MonadBaseControl IO m)
101 => FilePath -> (Fd -> m a) -> m a
102 withLockedFile path =
103 L.bracket (openAndLock path) (liftBase . closeFd)
104 where
105 openAndLock :: (MonadError e m, FromString e, MonadBaseControl IO m)
106 => FilePath -> m Fd
107 openAndLock p = liftBase $ do
108 fd <- openFd p ReadWrite Nothing defaultFileFlags
109 waitToSetLock fd (WriteLock, AbsoluteSeek, 0, 0)
110 return fd
111
112 -- | Just as 'atomicUpdateFile', but in addition locks the file during the
113 -- operation using 'withLockedFile' and checks if the file has been modified.
114 -- The action is only run if it hasn't, otherwise an error is thrown.
115 -- The file must exist.
116 -- Returns the new file status after the operation is finished.
117 atomicUpdateLockedFile :: FilePath
118 -> FStat
119 -> (FilePath -> Handle -> IO a)
120 -> ResultG (FStat, a)
121 atomicUpdateLockedFile path fstat action =
122 toErrorBase . withErrorT (LockError . (show :: IOError -> String))
123 $ withLockedFile path checkStatAndRun
124 where
125 checkStatAndRun _ = do
126 newstat <- liftIO $ getFStat path
127 unless (fstat == newstat)
128 (failError $ "Cannot overwrite file " ++ path ++
129 ": it has been modified since last written" ++
130 " (" ++ show fstat ++ " != " ++ show newstat ++ ")")
131 liftIO $ atomicUpdateFile path actionAndStat
132 actionAndStat tmppath tmphandle = do
133 r <- action tmppath tmphandle
134 hClose tmphandle -- close the handle so that we get meaningful stats
135 finalstat <- liftIO $ getFStat tmppath
136 return (finalstat, r)
137
138 -- | Just as 'atomicUpdateLockedFile', but discards the action result.
139 atomicUpdateLockedFile_ :: FilePath
140 -> FStat
141 -> (FilePath -> Handle -> IO a)
142 -> ResultG FStat
143 atomicUpdateLockedFile_ path oldstat
144 = liftM fst . atomicUpdateLockedFile path oldstat