1 -- Copyright (C) 2003 David Roundy 2 -- 3 -- This program is free software; you can redistribute it and/or modify 4 -- it under the terms of the GNU General Public License as published by 5 -- the Free Software Foundation; either version 2, or (at your option) 6 -- any later version. 7 -- 8 -- This program is distributed in the hope that it will be useful, 9 -- but WITHOUT ANY WARRANTY; without even the implied warranty of 10 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 -- GNU General Public License for more details. 12 -- 13 -- You should have received a copy of the GNU General Public License 14 -- along with this program; see the file COPYING. If not, write to 15 -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 16 -- Boston, MA 02110-1301, USA. 17 18 {-# LANGUAGE CPP, ForeignFunctionInterface #-} 19 20 module Darcs.Lock ( withLock, withLockCanFail, 21 withTemp, withOpenTemp, withStdoutTemp, 22 withTempDir, withPermDir, withDelayedDir, withNamedTemp, 23 writeToFile, appendToFile, 24 writeBinFile, writeDocBinFile, appendBinFile, appendDocBinFile, 25 readBinFile, readDocBinFile, 26 writeAtomicFilePS, 27 gzWriteAtomicFilePS, gzWriteAtomicFilePSs, gzWriteDocFile, 28 rm_recursive, removeFileMayNotExist, 29 canonFilename, maybeRelink, 30 world_readable_temp, tempdir_loc, 31 environmentHelpTmpdir, environmentHelpKeepTmpdir 32 ) where 33 34 import Prelude hiding ( catch ) 35 import Data.List ( inits ) 36 import Data.Maybe ( isJust, listToMaybe ) 37 import System.Exit ( exitWith, ExitCode(..) ) 38 import System.IO ( openBinaryFile, openBinaryTempFile, 39 hClose, hPutStr, Handle, 40 IOMode(WriteMode, AppendMode), hFlush, stdout ) 41 import System.IO.Error ( isDoesNotExistError, isAlreadyExistsError ) 42 import Control.Exception ( bracket, catchJust, ioErrors, throwIO, 43 Exception(IOException), catch, try ) 44 import System.Directory ( removeFile, removeDirectory, 45 doesFileExist, doesDirectoryExist, 46 getDirectoryContents, createDirectory, 47 getTemporaryDirectory, 48 ) 49 import System.FilePath.Posix ( splitDirectories ) 50 import Workaround ( renameFile ) 51 import Darcs.Utils ( withCurrentDirectory, maybeGetEnv, firstJustIO ) 52 import Control.Monad ( unless, when ) 53 54 import Darcs.URL ( is_relative ) 55 import Darcs.Utils ( catchall, add_to_error_loc ) 56 import Darcs.RepoPath ( AbsolutePath, FilePathLike, toFilePath, 57 getCurrentDirectory, setCurrentDirectory ) 58 59 import ByteStringUtils ( gzWriteFilePSs) 60 import qualified Data.ByteString as B (null, readFile, hPut, ByteString) 61 import qualified Data.ByteString.Char8 as BC (unpack) 62 63 import Darcs.SignalHandler ( withSignalsBlocked ) 64 import Printer ( Doc, hPutDoc, packedString, empty, renderPSs ) 65 import Darcs.Global ( atexit, darcsdir ) 66 import Darcs.Compat ( mk_stdout_temp, canonFilename, maybeRelink, 67 atomic_create, sloppy_atomic_create ) 68 import System.Posix.Files ( getSymbolicLinkStatus, isDirectory, 69 fileMode, getFileStatus, setFileMode ) 70 import System.Posix ( sleep ) 71 #include "impossible.h" 72 73 withLock :: String -> IO a -> IO a 74 releaseLock :: String -> IO () 75 76 withLock s job = bracket (getlock s 30) releaseLock (\_ -> job) 77 78 -- | Tries to perform some task if it can obtain the lock, 79 -- Otherwise, just gives up without doing the task 80 withLockCanFail :: String -> IO a -> IO (Either () a) 81 withLockCanFail s job = 82 bracket (takeLock s) 83 (\l -> if l then releaseLock s else return ()) 84 (\l -> if l then job >>= (return.Right) 85 else return $ Left ()) 86 87 getlock :: String -> Int -> IO String 88 getlock l 0 = do putStrLn $ "Couldn't get lock "++l 89 exitWith $ ExitFailure 1 90 getlock lbad tl = do l <- canonFilename lbad 91 gotit <- takeLock l 92 if gotit then return l 93 else do putStrLn $ "Waiting for lock "++l 94 hFlush stdout -- for Windows 95 done <- sleep 2 96 if done == 0 97 then getlock l (tl - 1) 98 else getlock l 0 99 100 removeFileMayNotExist :: FilePathLike p => p -> IO () 101 removeFileMayNotExist f = catchNonExistence (removeFile $ toFilePath f) () 102 103 catchNonExistence :: IO a -> a -> IO a 104 catchNonExistence job nonexistval = 105 catchJust ioErrors job $ 106 \e -> if isDoesNotExistError e then return nonexistval 107 else ioError e 108 109 releaseLock s = removeFileMayNotExist s 110 111 takeLock :: FilePathLike p => p -> IO Bool 112 takeLock fp = 113 do atomic_create $ toFilePath fp 114 return True 115 `catch` \e -> case e of 116 IOException e' 117 | isAlreadyExistsError e' -> 118 return False 119 _ -> do pwd <- getCurrentDirectory 120 throwIO $ add_to_error_loc e 121 ("takeLock "++toFilePath fp++" in "++toFilePath pwd) 122 123 takeFile :: FilePath -> IO Bool 124 takeFile fp = 125 do sloppy_atomic_create fp 126 return True 127 `catch` \e -> case e of 128 IOException e' 129 | isAlreadyExistsError e' -> 130 return False 131 _ -> do pwd <- getCurrentDirectory 132 throwIO $ add_to_error_loc e 133 ("takeFile "++fp++" in "++toFilePath pwd) 134 135 -- |'withTemp' safely creates an empty file (not open for writing) and 136 -- returns its name. 137 -- 138 -- The temp file operations are rather similar to the locking operations, in 139 -- that they both should always try to clean up, so exitWith causes trouble. 140 withTemp :: (String -> IO a) -> IO a 141 withTemp = bracket get_empty_file removeFileMayNotExist 142 where get_empty_file = do (f,h) <- openBinaryTempFile "." "darcs" 143 hClose h 144 return f 145 146 -- |'withOpenTemp' creates an already open temporary 147 -- file. Both of them run their argument and then delete the file. Also, 148 -- both of them (to my knowledge) are not susceptible to race conditions on 149 -- the temporary file (as long as you never delete the temporary file; that 150 -- would reintroduce a race condition). 151 withOpenTemp :: ((Handle, String) -> IO a) -> IO a 152 withOpenTemp = bracket get_empty_file cleanup 153 where cleanup (h,f) = do try $ hClose h 154 removeFileMayNotExist f 155 get_empty_file = invert `fmap` openBinaryTempFile "." "darcs" 156 invert (a,b) = (b,a) 157 158 withStdoutTemp :: (String -> IO a) -> IO a 159 withStdoutTemp = bracket (mk_stdout_temp "stdout_") removeFileMayNotExist 160 161 tempdir_loc :: IO FilePath 162 tempdir_loc = firstJustIO [ readBinFile (darcsdir++"/prefs/tmpdir") >>= return . Just . head.words >>= chkdir, 163 maybeGetEnv "DARCS_TMPDIR" >>= chkdir, 164 getTemporaryDirectory >>= chkdir . Just, 165 getCurrentDirectorySansDarcs, 166 return $ Just "." -- always returns a Just 167 ] 168 >>= return . fromJust 169 where chkdir Nothing = return Nothing 170 chkdir (Just d) = doesDirectoryExist d >>= return . \e -> if e then Just (d++"/") else Nothing 171 172 environmentHelpTmpdir :: ([String], [String]) 173 environmentHelpTmpdir = (["DARCS_TMPDIR", "TMPDIR"], [ 174 "Darcs often creates temporary directories. For example, the `darcs", 175 "diff' command creates two for the working trees to be diffed. By", 176 "default temporary directories are created in /tmp, or if that doesn't", 177 "exist, in _darcs (within the current repo). This can be overridden by", 178 "specifying some other directory in the file _darcs/prefs/tmpdir or the", 179 "environment variable $DARCS_TMPDIR or $TMPDIR."]) 180 181 getCurrentDirectorySansDarcs :: IO (Maybe FilePath) 182 getCurrentDirectorySansDarcs = do 183 c <- getCurrentDirectory 184 return $ listToMaybe $ drop 5 $ reverse $ takeWhile no_darcs $ inits $ toFilePath c 185 where no_darcs x = not $ darcsdir `elem` splitDirectories x 186 187 data WithDirKind = Perm | Temp | Delayed 188 189 withDir :: WithDirKind -> String -> (AbsolutePath -> IO a) -> IO a 190 withDir _ "" _ = bug "withDir called with empty directory name" 191 withDir kind abs_or_relative_name job = do 192 absolute_name <- if is_relative abs_or_relative_name 193 then fmap (++ abs_or_relative_name) tempdir_loc 194 else return abs_or_relative_name 195 formerdir <- getCurrentDirectory 196 bracket (create_directory absolute_name 0) 197 (\dir -> do setCurrentDirectory formerdir 198 k <- keep_tmpdir 199 unless k $ do case kind of 200 Perm -> return () 201 Temp -> rm_recursive (toFilePath dir) 202 Delayed -> atexit $ rm_recursive (toFilePath dir)) 203 job 204 where newname name 0 = name 205 newname name n = name ++ "-" ++ show n 206 create_directory :: FilePath -> Int -> IO AbsolutePath 207 create_directory name n 208 = do createDirectory $ newname name n 209 setCurrentDirectory $ newname name n 210 getCurrentDirectory 211 `catch` (\e -> case e of 212 IOException e' 213 | isAlreadyExistsError e' -> 214 create_directory name (n+1) 215 _ -> throwIO e) 216 keep_tmpdir = isJust `fmap` maybeGetEnv "DARCS_KEEP_TMPDIR" 217 218 environmentHelpKeepTmpdir :: ([String], [String]) 219 environmentHelpKeepTmpdir = (["DARCS_KEEP_TMPDIR"],[ 220 "If the environment variable DARCS_KEEP_TMPDIR is defined, darcs will", 221 "not remove the temporary directories it creates. This is intended", 222 "primarily for debugging Darcs itself, but it can also be useful, for", 223 "example, to determine why your test preference (see `darcs setpref')", 224 "is failing when you run `darcs record', but working when run manually."]) 225 226 -- |'withPermDir' is like 'withTempDir', except that it doesn't 227 -- delete the directory afterwards. 228 withPermDir :: String -> (AbsolutePath -> IO a) -> IO a 229 withPermDir = withDir Perm 230 231 -- |'withTempDir' creates an empty directory and then removes it when it 232 -- is no longer needed. withTempDir creates a temporary directory. The 233 -- location of that directory is determined by the contents of 234 -- _darcs/prefs/tmpdir, if it exists, otherwise by @$DARCS_TMPDIR@, and if 235 -- that doesn't exist then whatever your operating system considers to be a 236 -- a temporary directory (e.g. @$TMPDIR@ under Unix, @$TEMP@ under 237 -- Windows). 238 -- 239 -- If none of those exist it creates the temporary directory 240 -- in the current directory, unless the current directory is under a _darcs 241 -- directory, in which case the temporary directory in the parent of the highest 242 -- _darcs directory to avoid accidentally corrupting darcs's internals. 243 -- This should not fail, but if it does indeed fail, we go ahead and use the 244 -- current directory anyway. If @$DARCS_KEEP_TMPDIR@ variable is set 245 -- temporary directory is not removed, this can be useful for debugging. 246 withTempDir :: String -> (AbsolutePath -> IO a) -> IO a 247 withTempDir = withDir Temp 248 249 withDelayedDir :: String -> (AbsolutePath -> IO a) -> IO a 250 withDelayedDir = withDir Delayed 251 252 doesDirectoryReallyExist :: FilePath -> IO Bool 253 doesDirectoryReallyExist f = 254 catchNonExistence (isDirectory `fmap` getSymbolicLinkStatus f) False 255 256 rm_recursive :: FilePath -> IO () 257 rm_recursive d = 258 do isd <- doesDirectoryReallyExist d 259 if not isd 260 then removeFile d 261 else when isd $ do conts <- actual_dir_contents 262 withCurrentDirectory d $ 263 mapM_ rm_recursive conts 264 removeDirectory d 265 where actual_dir_contents = -- doesn't include . or .. 266 do c <- getDirectoryContents d 267 return $ filter (/=".") $ filter (/="..") c 268 269 world_readable_temp :: String -> IO String 270 world_readable_temp f = wrt 0 271 where wrt :: Int -> IO String 272 wrt 100 = fail $ "Failure creating temp named "++f 273 wrt n = let f_new = f++"-"++show n 274 in do ok <- takeFile f_new 275 if ok then do atexit $ removeFileMayNotExist f_new 276 return f_new 277 else wrt (n+1) 278 279 withNamedTemp :: String -> (String -> IO a) -> IO a 280 withNamedTemp n = bracket get_empty_file removeFileMayNotExist 281 where get_empty_file = world_readable_temp n 282 283 readBinFile :: FilePathLike p => p -> IO String 284 readBinFile = fmap BC.unpack . B.readFile . toFilePath 285 286 readDocBinFile :: FilePathLike p => p -> IO Doc 287 readDocBinFile fp = do ps <- B.readFile $ toFilePath fp 288 return $ if B.null ps then empty else packedString ps 289 290 appendBinFile :: FilePathLike p => p -> String -> IO () 291 appendBinFile f s = appendToFile f $ \h -> hPutStr h s 292 293 appendDocBinFile :: FilePathLike p => p -> Doc -> IO () 294 appendDocBinFile f d = appendToFile f $ \h -> hPutDoc h d 295 296 writeBinFile :: FilePathLike p => p -> String -> IO () 297 writeBinFile f s = writeToFile f $ \h -> hPutStr h s 298 299 writeDocBinFile :: FilePathLike p => p -> Doc -> IO () 300 writeDocBinFile f d = writeToFile f $ \h -> hPutDoc h d 301 302 writeAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO () 303 writeAtomicFilePS f ps = writeToFile f $ \h -> B.hPut h ps 304 305 gzWriteAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO () 306 gzWriteAtomicFilePS f ps = gzWriteAtomicFilePSs f [ps] 307 308 gzWriteAtomicFilePSs :: FilePathLike p => p -> [B.ByteString] -> IO () 309 gzWriteAtomicFilePSs f pss = 310 withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do 311 gzWriteFilePSs newf pss 312 already_exists <- doesFileExist $ toFilePath f 313 when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f) 314 setFileMode newf mode 315 `catchall` return () 316 renameFile newf (toFilePath f) 317 318 gzWriteDocFile :: FilePathLike p => p -> Doc -> IO () 319 gzWriteDocFile f d = gzWriteAtomicFilePSs f $ renderPSs d 320 321 writeToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO () 322 writeToFile f job = 323 withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do 324 bracket (openBinaryFile newf WriteMode) hClose job 325 already_exists <- doesFileExist (toFilePath f) 326 when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f) 327 setFileMode newf mode 328 `catchall` return () 329 renameFile newf (toFilePath f) 330 331 appendToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO () 332 appendToFile f job = withSignalsBlocked $ 333 bracket (openBinaryFile (toFilePath f) AppendMode) hClose job