% Copyright (C) 2003 David Roundy
%
% This program is free software; you can redistribute it and/or modify
% it under the terms of the GNU General Public License as published by
% the Free Software Foundation; either version 2, or (at your option)
% any later version.
%
% This program is distributed in the hope that it will be useful,
% but WITHOUT ANY WARRANTY; without even the implied warranty of
% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
% GNU General Public License for more details.
%
% You should have received a copy of the GNU General Public License
% along with this program; see the file COPYING. If not, write to
% the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
% Boston, MA 02110-1301, USA.
\begin{code}
{-# OPTIONS_GHC -cpp -fffi #-}
module Darcs.Lock ( withLock, withLockCanFail,
withTemp, withOpenTemp, withStdoutTemp,
withTempDir, withPermDir, withDelayedDir, withNamedTemp,
writeToFile, appendToFile,
writeBinFile, writeDocBinFile, appendBinFile, appendDocBinFile,
readBinFile, readDocBinFile,
writeAtomicFilePS,
gzWriteAtomicFilePS, gzWriteAtomicFilePSs, gzWriteDocFile,
rm_recursive, removeFileMayNotExist,
canonFilename, maybeRelink,
world_readable_temp, tempdir_loc,
) where
import Prelude hiding ( catch )
import Control.Monad ( liftM )
import Data.List ( inits )
import Data.Maybe ( listToMaybe )
import System.Exit ( exitWith, ExitCode(..) )
import System.IO ( openBinaryFile, openBinaryTempFile,
hClose, hPutStr, Handle,
IOMode(WriteMode, AppendMode), hFlush, stdout )
import System.IO.Error ( isDoesNotExistError, isAlreadyExistsError )
import Control.Exception ( bracket, catchJust, ioErrors, finally, throwIO,
Exception(IOException), catch, try )
import System.Directory ( setCurrentDirectory, removeFile, removeDirectory,
doesFileExist, doesDirectoryExist,
getDirectoryContents, createDirectory,
getTemporaryDirectory,
)
import Workaround ( renameFile, getCurrentDirectory )
import Darcs.Utils ( withCurrentDirectory, maybeGetEnv, firstJustIO )
import Control.Monad ( when )
import Workaround ( fileMode, getFileStatus, setFileMode )
import Darcs.URL ( is_relative )
import Darcs.Utils ( catchall, add_to_error_loc )
import FastPackedString ( PackedString, hPutPS, readFilePS, unpackPS,
gzWriteFilePSs, nullPS,
)
import Darcs.SignalHandler ( withSignalsBlocked )
import Printer ( Doc, hPutDoc, packedString, empty, renderPSs )
import FileName ( breakup )
import Darcs.Global ( atexit, darcsdir )
import Darcs.Compat ( mk_stdout_temp, canonFilename, maybeRelink,
atomic_create, sloppy_atomic_create )
import System.Posix.Files ( getSymbolicLinkStatus, isDirectory )
import System.Posix ( sleep )
#include "impossible.h"
withLock :: String -> IO a -> IO a
releaseLock :: String -> IO ()
withLock s job = bracket (getlock s 30) releaseLock (\_ -> job)
-- | Tries to perform some task if it can obtain the lock,
-- Otherwise, just gives up without doing the task
withLockCanFail :: String -> IO a -> IO (Either () a)
withLockCanFail s job =
bracket (takeLock s)
(\l -> if l then releaseLock s else return ())
(\l -> if l then job >>= (return.Right)
else return $ Left ())
getlock :: String -> Int -> IO String
getlock l 0 = do putStrLn $ "Couldn't get lock "++l
exitWith $ ExitFailure 1
getlock lbad tl = do l <- canonFilename lbad
gotit <- takeLock l
if gotit then return l
else do putStrLn $ "Waiting for lock "++l
hFlush stdout -- for Windows
done <- sleep 2
if done == 0
then getlock l (tl - 1)
else getlock l 0
removeFileMayNotExist :: FilePath -> IO ()
removeFileMayNotExist f = catchNonExistence (removeFile f) ()
catchNonExistence :: IO a -> a -> IO a
catchNonExistence job nonexistval =
catchJust ioErrors job $
\e -> if isDoesNotExistError e then return nonexistval
else ioError e
releaseLock s = removeFileMayNotExist s
takeLock :: FilePath -> IO Bool
takeLock fp =
do atomic_create fp
return True
`catch` \e -> case e of
IOException e'
| isAlreadyExistsError e' ->
return False
_ -> do pwd <- getCurrentDirectory
throwIO $ add_to_error_loc e
("takeLock "++fp++" in "++pwd)
takeFile :: FilePath -> IO Bool
takeFile fp =
do sloppy_atomic_create fp
return True
`catch` \e -> case e of
IOException e'
| isAlreadyExistsError e' ->
return False
_ -> do pwd <- getCurrentDirectory
throwIO $ add_to_error_loc e
("takeFile "++fp++" in "++pwd)
\end{code}
\verb!withTemp! safely creates an empty file (not open for writing) and
returns its name. \verb!withOpenTemp! creates an already open temporary
file. Both of them run their argument and then delete the file. Also,
both of them (to my knowledge) are not susceptible to race conditions on
the temporary file (as long as you never delete the temporary file--that
would reintroduce a race condition).
The temp file operations are rather similar to the locking operations, in
that they both should always try to clean up, so exitWith causes trouble.
\begin{code}
withTemp :: (String -> IO a) -> IO a
withTemp = bracket get_empty_file removeFileMayNotExist
where get_empty_file = do (f,h) <- openBinaryTempFile "." "darcs"
hClose h
return f
withOpenTemp :: ((Handle, String) -> IO a) -> IO a
withOpenTemp = bracket get_empty_file cleanup
where cleanup (h,f) = do try $ hClose h
removeFileMayNotExist f
get_empty_file = invert `fmap` openBinaryTempFile "." "darcs"
invert (a,b) = (b,a)
withStdoutTemp :: (String -> IO a) -> IO a
withStdoutTemp = bracket (mk_stdout_temp "stdout_") removeFileMayNotExist
\end{code}
\verb!withTempDir! creates an empty directory and then removes it when it
is no longer needed. withTempDir creates a temporary directory. The
location of that directory is determined by the contents of
_darcs/prefs/tmpdir, if it exists, otherwise by \verb!$DARCS_TMPDIR!, and if
that doesn't exist then whatever your operating system considers to be a
a temporary directory (e.g. \verb!$TMPDIR! under Unix, \verb!$TEMP! under
Windows).
If none of those exist it creates the temporary directory
in the current directory, unless the current directory is under a \verb!_darcs!
directory, in which case the temporary directory in the parent of the highest
\verb!_darcs! directory to avoid accidentally corrupting darcs's internals.
This should not fail, but if it does indeed fail, we go ahead and use the
current directory anyway.
\verb!withPermDir! is like \verb!withTempDir!, except that it doesn't
delete the directory afterwards.
\begin{code}
tempdir_loc :: IO FilePath
tempdir_loc = firstJustIO [ readBinFile (darcsdir++"/prefs/tmpdir") >>= return . Just . head.words >>= chkdir,
maybeGetEnv "DARCS_TMPDIR" >>= chkdir,
getTemporaryDirectory >>= chkdir . Just,
getCurrentDirectorySansDarcs,
return $ Just "." -- always returns a Just
]
>>= return . fromJust
where chkdir Nothing = return Nothing
chkdir (Just d) = doesDirectoryExist d >>= return . \e -> if e then Just (d++"/") else Nothing
getCurrentDirectorySansDarcs :: IO (Maybe FilePath)
getCurrentDirectorySansDarcs = do
c <- getCurrentDirectory
return $ listToMaybe $ drop 5 $ reverse $ takeWhile no_darcs $ inits c
where no_darcs x = not $ darcsdir `elem` breakup x
data WithDirKind = Perm | Temp | Delayed
withDir :: WithDirKind -> String -> (String -> IO a) -> IO a
withDir kind abs_or_relative_name job = do
absolute_name <- if is_relative abs_or_relative_name
then liftM (++ abs_or_relative_name) tempdir_loc
else return abs_or_relative_name
formerdir <- getCurrentDirectory
bracket (create_directory absolute_name 0)
(case kind of
Perm -> (\_ -> setCurrentDirectory formerdir)
Temp -> remove_directory formerdir
Delayed -> (\dir -> do setCurrentDirectory formerdir
atexit (rm_recursive dir)))
job
where newname name 0 = name
newname name n = name ++ "-" ++ show n
create_directory :: FilePath -> Int -> IO FilePath
create_directory name n
= do createDirectory $ newname name n
setCurrentDirectory $ newname name n
getCurrentDirectory
`catch` (\e -> case e of
IOException e'
| isAlreadyExistsError e' ->
create_directory name (n+1)
_ -> throwIO e)
remove_directory f d = do
setCurrentDirectory f
still_here <- doesDirectoryReallyExist d
when still_here $
rm_recursive d `finally` setCurrentDirectory f
withPermDir :: String -> (String -> IO a) -> IO a
withPermDir = withDir Perm
withTempDir :: String -> (String -> IO a) -> IO a
withTempDir = withDir Temp
withDelayedDir :: String -> (String -> IO a) -> IO a
withDelayedDir = withDir Delayed
doesDirectoryReallyExist :: FilePath -> IO Bool
doesDirectoryReallyExist f =
catchNonExistence (isDirectory `fmap` getSymbolicLinkStatus f) False
rm_recursive :: FilePath -> IO ()
rm_recursive d =
do isd <- doesDirectoryReallyExist d
if not isd
then removeFile d
else when isd $ do conts <- actual_dir_contents
withCurrentDirectory d $
(sequence_ $ map rm_recursive conts)
removeDirectory d
where actual_dir_contents = -- doesn't include . or ..
do c <- getDirectoryContents d
return $ filter (/=".") $ filter (/="..") c
\end{code}
\begin{code}
world_readable_temp :: String -> IO String
world_readable_temp f = wrt 0
where wrt :: Int -> IO String
wrt 100 = fail $ "Failure creating temp named "++f
wrt n = do ok <- takeFile $ f++"-"++show n
if ok then return $ f++"-"++show n
else wrt (n+1)
withNamedTemp :: String -> (String -> IO a) -> IO a
withNamedTemp n = bracket get_empty_file removeFileMayNotExist
where get_empty_file = world_readable_temp n
readBinFile :: FilePath -> IO String
readBinFile = liftM unpackPS . readFilePS
readDocBinFile :: FilePath -> IO Doc
readDocBinFile fp = do ps <- readFilePS fp
return $ if nullPS ps then empty else packedString ps
appendBinFile :: FilePath -> String -> IO ()
appendBinFile f s = appendToFile f $ \h -> hPutStr h s
appendDocBinFile :: FilePath -> Doc -> IO ()
appendDocBinFile f d = appendToFile f $ \h -> hPutDoc h d
writeBinFile :: FilePath -> String -> IO ()
writeBinFile f s = writeToFile f $ \h -> hPutStr h s
writeDocBinFile :: FilePath -> Doc -> IO ()
writeDocBinFile f d = writeToFile f $ \h -> hPutDoc h d
writeAtomicFilePS :: FilePath -> PackedString -> IO ()
writeAtomicFilePS f ps = writeToFile f $ \h -> hPutPS h ps
gzWriteAtomicFilePS :: FilePath -> PackedString -> IO ()
gzWriteAtomicFilePS f ps = gzWriteAtomicFilePSs f [ps]
gzWriteAtomicFilePSs :: FilePath -> [PackedString] -> IO ()
gzWriteAtomicFilePSs f pss =
withSignalsBlocked $ withNamedTemp f $ \newf -> do
gzWriteFilePSs newf pss
already_exists <- doesFileExist f
when already_exists $ do mode <- fileMode `liftM` getFileStatus f
setFileMode newf mode
`catchall` return ()
renameFile newf f
gzWriteDocFile :: FilePath -> Doc -> IO ()
gzWriteDocFile f d = gzWriteAtomicFilePSs f $ renderPSs d
writeToFile :: FilePath -> (Handle -> IO ()) -> IO ()
writeToFile f job =
withSignalsBlocked $ withNamedTemp f $ \newf -> do
h <- openBinaryFile newf WriteMode
job h
hClose h
already_exists <- doesFileExist f
when already_exists $ do mode <- fileMode `liftM` getFileStatus f
setFileMode newf mode
`catchall` return ()
renameFile newf f
appendToFile :: FilePath -> (Handle -> IO ()) -> IO ()
appendToFile f job = withSignalsBlocked $ do
h <- openBinaryFile f AppendMode
job h
hClose h
\end{code}