src/Darcs/Lock.lhs

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