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 Data.List ( inits )
import Data.Maybe ( isJust, 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, throwIO,
Exception(IOException), catch, try )
import System.Directory ( removeFile, removeDirectory,
doesFileExist, doesDirectoryExist,
getDirectoryContents, createDirectory,
getTemporaryDirectory,
)
import System.FilePath.Posix ( splitDirectories )
import Workaround ( renameFile )
import Darcs.Utils ( withCurrentDirectory, maybeGetEnv, firstJustIO )
import Control.Monad ( unless, when )
import Darcs.URL ( is_relative )
import Darcs.Utils ( catchall, add_to_error_loc )
import Darcs.RepoPath ( AbsolutePath, FilePathLike, toFilePath,
getCurrentDirectory, setCurrentDirectory )
import ByteStringUtils ( gzWriteFilePSs)
import qualified Data.ByteString as B (null, readFile, hPut, ByteString)
import qualified Data.ByteString.Char8 as BC (unpack)
import Darcs.SignalHandler ( withSignalsBlocked )
import Printer ( Doc, hPutDoc, packedString, empty, renderPSs )
import Darcs.Global ( atexit, darcsdir )
import Darcs.Compat ( mk_stdout_temp, canonFilename, maybeRelink,
atomic_create, sloppy_atomic_create )
import System.Posix.Files ( getSymbolicLinkStatus, isDirectory,
fileMode, getFileStatus, setFileMode )
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)
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
done <- sleep 2
if done == 0
then getlock l (tl 1)
else getlock l 0
removeFileMayNotExist :: FilePathLike p => p -> IO ()
removeFileMayNotExist f = catchNonExistence (removeFile $ toFilePath 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 :: FilePathLike p => p -> IO Bool
takeLock fp =
do atomic_create $ toFilePath fp
return True
`catch` \e -> case e of
IOException e'
| isAlreadyExistsError e' ->
return False
_ -> do pwd <- getCurrentDirectory
throwIO $ add_to_error_loc e
("takeLock "++toFilePath fp++" in "++toFilePath 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 "++toFilePath pwd)
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
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 "."
]
>>= 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 $ toFilePath c
where no_darcs x = not $ darcsdir `elem` splitDirectories x
data WithDirKind = Perm | Temp | Delayed
withDir :: WithDirKind -> String -> (AbsolutePath -> IO a) -> IO a
withDir kind abs_or_relative_name job = do
absolute_name <- if is_relative abs_or_relative_name
then fmap (++ abs_or_relative_name) tempdir_loc
else return abs_or_relative_name
formerdir <- getCurrentDirectory
bracket (create_directory absolute_name 0)
(\dir -> do setCurrentDirectory formerdir
k <- keep_tmpdir
unless k $ do case kind of
Perm -> return ()
Temp -> rm_recursive (toFilePath dir)
Delayed -> atexit $ rm_recursive (toFilePath dir))
job
where newname name 0 = name
newname name n = name ++ "-" ++ show n
create_directory :: FilePath -> Int -> IO AbsolutePath
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)
keep_tmpdir = isJust `fmap` maybeGetEnv "DARCS_KEEP_TMPDIR"
withPermDir :: String -> (AbsolutePath -> IO a) -> IO a
withPermDir = withDir Perm
withTempDir :: String -> (AbsolutePath -> IO a) -> IO a
withTempDir = withDir Temp
withDelayedDir :: String -> (AbsolutePath -> 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 =
do c <- getDirectoryContents d
return $ filter (/=".") $ filter (/="..") c
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 :: FilePathLike p => p -> IO String
readBinFile = fmap BC.unpack . B.readFile . toFilePath
readDocBinFile :: FilePathLike p => p -> IO Doc
readDocBinFile fp = do ps <- B.readFile $ toFilePath fp
return $ if B.null ps then empty else packedString ps
appendBinFile :: FilePathLike p => p -> String -> IO ()
appendBinFile f s = appendToFile f $ \h -> hPutStr h s
appendDocBinFile :: FilePathLike p => p -> Doc -> IO ()
appendDocBinFile f d = appendToFile f $ \h -> hPutDoc h d
writeBinFile :: FilePathLike p => p -> String -> IO ()
writeBinFile f s = writeToFile f $ \h -> hPutStr h s
writeDocBinFile :: FilePathLike p => p -> Doc -> IO ()
writeDocBinFile f d = writeToFile f $ \h -> hPutDoc h d
writeAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO ()
writeAtomicFilePS f ps = writeToFile f $ \h -> B.hPut h ps
gzWriteAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO ()
gzWriteAtomicFilePS f ps = gzWriteAtomicFilePSs f [ps]
gzWriteAtomicFilePSs :: FilePathLike p => p -> [B.ByteString] -> IO ()
gzWriteAtomicFilePSs f pss =
withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do
gzWriteFilePSs newf pss
already_exists <- doesFileExist $ toFilePath f
when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f)
setFileMode newf mode
`catchall` return ()
renameFile newf (toFilePath f)
gzWriteDocFile :: FilePathLike p => p -> Doc -> IO ()
gzWriteDocFile f d = gzWriteAtomicFilePSs f $ renderPSs d
writeToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO ()
writeToFile f job =
withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do
bracket (openBinaryFile newf WriteMode) hClose job
already_exists <- doesFileExist (toFilePath f)
when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f)
setFileMode newf mode
`catchall` return ()
renameFile newf (toFilePath f)
appendToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO ()
appendToFile f job = withSignalsBlocked $
bracket (openBinaryFile (toFilePath f) AppendMode) hClose job