-- 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.

module Darcs.Util.Lock
    ( withLock
    , withLockCanFail
    , environmentHelpLocks
    , withTemp
    , withOpenTemp
    , withTempDir
    , withPermDir
    , withDelayedDir
    , withNamedTemp
    , writeBinFile
    , writeTextFile
    , writeDocBinFile
    , appendBinFile
    , appendTextFile
    , appendDocBinFile
    , readBinFile
    , readTextFile
    , readDocBinFile
    , writeAtomicFilePS
    , gzWriteAtomicFilePS
    , gzWriteAtomicFilePSs
    , gzWriteDocFile
    , removeFileMayNotExist
    , canonFilename
    , maybeRelink
    , tempdirLoc
    , environmentHelpTmpdir
    , environmentHelpKeepTmpdir
    , addToErrorLoc
    , withNewDirectory
    ) where

import Darcs.Prelude

import Data.List ( inits )
import Data.Maybe ( fromJust, isJust, listToMaybe )
import System.Exit ( exitWith, ExitCode(..) )
import System.IO
    ( withFile, withBinaryFile, openBinaryTempFile
    , hClose, Handle, hPutStr, hSetEncoding
    , IOMode(WriteMode, AppendMode), hFlush, stdout
    )
import System.IO.Error
    ( isAlreadyExistsError
    , annotateIOError
    , catchIOError
    )
import Control.Exception
    ( IOException
    , bracket
    , throwIO
    , catch
    , try
    , SomeException
    )
import System.Directory
    ( removePathForcibly
    , doesFileExist
    , doesDirectoryExist
    , createDirectory
    , getTemporaryDirectory
    , removePathForcibly
    , renameFile
    , renameDirectory
    )
import System.FilePath.Posix ( splitDirectories, splitFileName )
import System.Environment ( lookupEnv )
import System.IO.Temp ( createTempDirectory )

import Control.Concurrent ( threadDelay )
import Control.Monad ( unless, when, liftM )

import System.Posix.Files ( fileMode, getFileStatus, setFileMode )

import GHC.IO.Encoding ( getFileSystemEncoding )

import Darcs.Util.URL ( isRelative )
import Darcs.Util.Exception
    ( firstJustIO
    , catchall
    )
import Darcs.Util.File ( withCurrentDirectory
                       , removeFileMayNotExist )
import Darcs.Util.Path ( AbsolutePath, FilePathLike, toFilePath,
                        getCurrentDirectory, setCurrentDirectory )

import Darcs.Util.ByteString ( gzWriteFilePSs )
import qualified Data.ByteString as B (null, readFile, hPut, ByteString)

import Darcs.Util.SignalHandler ( withSignalsBlocked )
import Darcs.Util.Printer ( Doc, hPutDoc, packedString, empty, renderPSs )
import Darcs.Util.AtExit ( atexit )
import Darcs.Util.Global ( darcsdir )
import Darcs.Util.Compat
    ( canonFilename
    , maybeRelink
    , atomicCreate
    , sloppyAtomicCreate
    )
import Darcs.Util.Progress ( debugMessage )
import Darcs.Util.Prompt ( askUser )

withLock :: String -> IO a -> IO a
withLock :: String -> IO a -> IO a
withLock String
s IO a
job = IO String -> (String -> IO ()) -> (String -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> Int -> IO String
getlock String
s Int
30) String -> IO ()
releaseLock (\String
_ -> IO a
job)

releaseLock :: String -> IO ()
releaseLock :: String -> IO ()
releaseLock = String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist

-- | 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 :: String -> IO a -> IO (Either () a)
withLockCanFail String
s IO a
job =
  IO Bool
-> (Bool -> IO ())
-> (Bool -> IO (Either () a))
-> IO (Either () a)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> IO Bool
forall p. FilePathLike p => p -> IO Bool
takeLock String
s)
          (\Bool
l -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
l (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
releaseLock String
s)
          (\Bool
l -> if Bool
l then (a -> Either () a) -> IO a -> IO (Either () a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Either () a
forall a b. b -> Either a b
Right IO a
job
                      else Either () a -> IO (Either () a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either () a -> IO (Either () a))
-> Either () a -> IO (Either () a)
forall a b. (a -> b) -> a -> b
$ () -> Either () a
forall a b. a -> Either a b
Left ())

getlock :: String -> Int -> IO String
getlock :: String -> Int -> IO String
getlock String
l Int
0 = do String
yorn <- String -> IO String
askUser (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"Couldn't get lock "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
lString -> String -> String
forall a. [a] -> [a] -> [a]
++String
". Abort (yes or anything else)? "
                 case String
yorn of
                    (Char
'y':String
_) -> ExitCode -> IO String
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO String) -> ExitCode -> IO String
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
                    String
_ -> String -> Int -> IO String
getlock String
l Int
30
getlock String
lbad Int
tl = do String
l <- String -> IO String
canonFilename String
lbad
                     Bool
gotit <- String -> IO Bool
forall p. FilePathLike p => p -> IO Bool
takeLock String
l
                     if Bool
gotit then String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
l
                              else do String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Waiting for lock "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
l
                                      Handle -> IO ()
hFlush Handle
stdout -- for Windows
                                      Int -> IO ()
threadDelay Int
2000000
                                      String -> Int -> IO String
getlock String
l (Int
tl Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)


takeLock :: FilePathLike p => p -> IO Bool
takeLock :: p -> IO Bool
takeLock p
fp =
    do String -> IO ()
atomicCreate (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ p -> String
forall a. FilePathLike a => a -> String
toFilePath p
fp
       Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  IO Bool -> (IOError -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \IOError
e -> if IOError -> Bool
isAlreadyExistsError IOError
e
                then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                else do AbsolutePath
pwd <- IO AbsolutePath
getCurrentDirectory
                        IOError -> IO Bool
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO Bool) -> IOError -> IO Bool
forall a b. (a -> b) -> a -> b
$ IOError -> String -> IOError
addToErrorLoc IOError
e
                                   (String
"takeLock "String -> String -> String
forall a. [a] -> [a] -> [a]
++p -> String
forall a. FilePathLike a => a -> String
toFilePath p
fpString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" in "String -> String -> String
forall a. [a] -> [a] -> [a]
++AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath AbsolutePath
pwd)

takeFile :: FilePath -> IO Bool
takeFile :: String -> IO Bool
takeFile String
fp =
    do String -> IO ()
sloppyAtomicCreate String
fp
       Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  IO Bool -> (IOError -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \IOError
e -> if IOError -> Bool
isAlreadyExistsError IOError
e
                then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                else do AbsolutePath
pwd <- IO AbsolutePath
getCurrentDirectory
                        IOError -> IO Bool
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO Bool) -> IOError -> IO Bool
forall a b. (a -> b) -> a -> b
$ IOError -> String -> IOError
addToErrorLoc IOError
e
                                   (String
"takeFile "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
fpString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" in "String -> String -> String
forall a. [a] -> [a] -> [a]
++AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath AbsolutePath
pwd)

environmentHelpLocks :: ([String],[String])
environmentHelpLocks :: ([String], [String])
environmentHelpLocks = ([String
"DARCS_SLOPPY_LOCKS"],[
 String
"If on some filesystems you get an error of the kind:",
 String
"",
 String
"    darcs: takeLock [...]: atomic_create [...]: unsupported operation",
 String
"",
 String
"you may want to try to export DARCS_SLOPPY_LOCKS=True."])

-- |'withTemp' safely creates an empty file (not open for writing) and
-- returns its name.
--
-- 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.
withTemp :: (FilePath -> IO a) -> IO a
withTemp :: (String -> IO a) -> IO a
withTemp = IO String -> (String -> IO ()) -> (String -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO String
get_empty_file String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist
    where get_empty_file :: IO String
get_empty_file = do (String
f,Handle
h) <- String -> String -> IO (String, Handle)
openBinaryTempFile String
"." String
"darcs"
                              Handle -> IO ()
hClose Handle
h
                              String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
f

-- |'withOpenTemp' creates a temporary file, and opens it.
-- 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).
withOpenTemp :: ((Handle, FilePath) -> IO a) -> IO a
withOpenTemp :: ((Handle, String) -> IO a) -> IO a
withOpenTemp = IO (Handle, String)
-> ((Handle, String) -> IO ())
-> ((Handle, String) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Handle, String)
get_empty_file (Handle, String) -> IO ()
forall p. FilePathLike p => (Handle, p) -> IO ()
cleanup
    where cleanup :: (Handle, p) -> IO ()
cleanup (Handle
h,p
f) = do Either SomeException ()
_ <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (Handle -> IO ()
hClose Handle
h) :: IO (Either SomeException ())
                             p -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist p
f
          get_empty_file :: IO (Handle, String)
get_empty_file = (String, Handle) -> (Handle, String)
forall b a. (b, a) -> (a, b)
invert ((String, Handle) -> (Handle, String))
-> IO (String, Handle) -> IO (Handle, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> String -> IO (String, Handle)
openBinaryTempFile String
"." String
"darcs"
          invert :: (b, a) -> (a, b)
invert (b
a,a
b) = (a
b,b
a)

tempdirLoc :: IO FilePath
tempdirLoc :: IO String
tempdirLoc = (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (IO (Maybe String) -> IO String) -> IO (Maybe String) -> IO String
forall a b. (a -> b) -> a -> b
$
    [IO (Maybe String)] -> IO (Maybe String)
forall a. [IO (Maybe a)] -> IO (Maybe a)
firstJustIO [ (String -> Maybe String) -> IO String -> IO (Maybe String)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (String -> String) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall a. [a] -> a
head ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words) (String -> IO String
readFile (String
darcsdirString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"/prefs/tmpdir")) IO (Maybe String)
-> (Maybe String -> IO (Maybe String)) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe String -> IO (Maybe String)
chkdir,
                  String -> IO (Maybe String)
lookupEnv String
"DARCS_TMPDIR" IO (Maybe String)
-> (Maybe String -> IO (Maybe String)) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe String -> IO (Maybe String)
chkdir,
                  IO String
getTemporaryDirectory IO String -> (String -> IO (Maybe String)) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe String -> IO (Maybe String)
chkdir (Maybe String -> IO (Maybe String))
-> (String -> Maybe String) -> String -> IO (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just,
                  IO (Maybe String)
getCurrentDirectorySansDarcs,
                  Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
"."  -- always returns a Just
                ]
    where chkdir :: Maybe String -> IO (Maybe String)
chkdir Maybe String
Nothing = Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
          chkdir (Just String
d) = (Bool -> Maybe String) -> IO Bool -> IO (Maybe String)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\Bool
e -> if Bool
e then String -> Maybe String
forall a. a -> Maybe a
Just (String
dString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"/") else Maybe String
forall a. Maybe a
Nothing) (IO Bool -> IO (Maybe String)) -> IO Bool -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
d

environmentHelpTmpdir :: ([String], [String])
environmentHelpTmpdir :: ([String], [String])
environmentHelpTmpdir = ([String
"DARCS_TMPDIR", String
"TMPDIR"], [
 String
"Darcs often creates temporary directories.  For example, the `darcs",
 String
"diff` command creates two for the working trees to be diffed.  By",
 String
"default temporary directories are created in /tmp, or if that doesn't",
 String
"exist, in _darcs (within the current repo).  This can be overridden by",
 String
"specifying some other directory in the file _darcs/prefs/tmpdir or the",
 String
"environment variable $DARCS_TMPDIR or $TMPDIR."])

getCurrentDirectorySansDarcs :: IO (Maybe FilePath)
getCurrentDirectorySansDarcs :: IO (Maybe String)
getCurrentDirectorySansDarcs = do
  AbsolutePath
c <- IO AbsolutePath
getCurrentDirectory
  Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe ([String] -> Maybe String) -> [String] -> Maybe String
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
5 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile String -> Bool
no_darcs ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
forall a. [a] -> [[a]]
inits (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath AbsolutePath
c
  where no_darcs :: String -> Bool
no_darcs String
x = String
darcsdir String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String -> [String]
splitDirectories String
x

data WithDirKind = Perm | Temp | Delayed

-- | Creates a directory based on the path parameter;
-- if a relative path is given the dir is created in the darcs temp dir.
-- If an absolute path is given this dir will be created if it doesn't exist.
-- If it is specified as a temporary dir, it is deleted after finishing the job.
withDir :: WithDirKind  -- specifies if and when directory will be deleted
        -> FilePath     -- path parameter
        -> (AbsolutePath -> IO a) -> IO a
withDir :: WithDirKind -> String -> (AbsolutePath -> IO a) -> IO a
withDir WithDirKind
_ String
"" AbsolutePath -> IO a
_ = String -> IO a
forall a. HasCallStack => String -> a
error String
"withDir called with empty directory name"
withDir WithDirKind
kind String
absoluteOrRelativeName AbsolutePath -> IO a
job = do
  String
absoluteName <- if String -> Bool
isRelative String
absoluteOrRelativeName
                   then (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
absoluteOrRelativeName) IO String
tempdirLoc
                   else String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
absoluteOrRelativeName
  AbsolutePath
formerdir <- IO AbsolutePath
getCurrentDirectory
  IO AbsolutePath
-> (AbsolutePath -> IO ()) -> (AbsolutePath -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> IO AbsolutePath
createDir String
absoluteName)
          (\AbsolutePath
dir -> do
              AbsolutePath -> IO ()
forall p. FilePathLike p => p -> IO ()
setCurrentDirectory AbsolutePath
formerdir
              Bool
k <- IO Bool
keepTempDir
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
k (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                  case WithDirKind
kind of
                      WithDirKind
Perm -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                      WithDirKind
Temp -> String -> IO ()
cleanup (AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath AbsolutePath
dir)
                      WithDirKind
Delayed -> IO () -> IO ()
atexit (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
cleanup (AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath AbsolutePath
dir))
          AbsolutePath -> IO a
job
    where createDir :: FilePath -> IO AbsolutePath
          createDir :: String -> IO AbsolutePath
createDir String
name
              = do let (String
parent,String
dir) = String -> (String, String)
splitFileName String
name
                   String -> String -> IO String
createTempDirectory String
parent String
dir IO String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO ()
forall p. FilePathLike p => p -> IO ()
setCurrentDirectory
                   IO AbsolutePath
getCurrentDirectory
          keepTempDir :: IO Bool
keepTempDir = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO (Maybe String)
lookupEnv String
"DARCS_KEEP_TMPDIR"
          toDelete :: String -> String
toDelete String
dir = String
dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_done"
          cleanup :: String -> IO ()
cleanup String
path = do
              -- so asynchronous threads cannot add any more
              -- files while we are deleting
              String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"atexit: renaming",String
path,String
"to",String -> String
toDelete String
path]
              String -> String -> IO ()
renameDirectory String
path (String -> String
toDelete String
path)
              String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"atexit: deleting",String -> String
toDelete String
path]
              String -> IO ()
removePathForcibly (String -> String
toDelete String
path)

environmentHelpKeepTmpdir :: ([String], [String])
environmentHelpKeepTmpdir :: ([String], [String])
environmentHelpKeepTmpdir = ([String
"DARCS_KEEP_TMPDIR"],[
 String
"If the environment variable DARCS_KEEP_TMPDIR is defined, darcs will",
 String
"not remove the temporary directories it creates.  This is intended",
 String
"primarily for debugging Darcs itself, but it can also be useful, for",
 String
"example, to determine why your test preference (see `darcs setpref`)",
 String
"is failing when you run `darcs record`, but working when run manually."])

-- |'withPermDir' is like 'withTempDir', except that it doesn't
-- delete the directory afterwards.
withPermDir :: FilePath -> (AbsolutePath -> IO a) -> IO a
withPermDir :: String -> (AbsolutePath -> IO a) -> IO a
withPermDir = WithDirKind -> String -> (AbsolutePath -> IO a) -> IO a
forall a. WithDirKind -> String -> (AbsolutePath -> IO a) -> IO a
withDir WithDirKind
Perm

-- |'withTempDir' creates a temporary directory, runs the action and then
-- removes the directory. The
-- location of that directory is determined by the contents of
-- _darcs/prefs/tmpdir, if it exists, otherwise by @$DARCS_TMPDIR@, and if
-- that doesn't exist then whatever your operating system considers to be a
-- a temporary directory (e.g. @$TMPDIR@ under Unix, @$TEMP@ under
-- Windows).
--
-- If none of those exist it creates the temporary directory
-- in the current directory, unless the current directory is under a _darcs
-- directory, in which case the temporary directory in the parent of the highest
-- _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. If @$DARCS_KEEP_TMPDIR@ variable is set
-- temporary directory is not removed, this can be useful for debugging.
withTempDir :: FilePath -> (AbsolutePath -> IO a) -> IO a
withTempDir :: String -> (AbsolutePath -> IO a) -> IO a
withTempDir = WithDirKind -> String -> (AbsolutePath -> IO a) -> IO a
forall a. WithDirKind -> String -> (AbsolutePath -> IO a) -> IO a
withDir WithDirKind
Temp

withDelayedDir :: FilePath -> (AbsolutePath -> IO a) -> IO a
withDelayedDir :: String -> (AbsolutePath -> IO a) -> IO a
withDelayedDir = WithDirKind -> String -> (AbsolutePath -> IO a) -> IO a
forall a. WithDirKind -> String -> (AbsolutePath -> IO a) -> IO a
withDir WithDirKind
Delayed

worldReadableTemp :: FilePath -> IO FilePath
worldReadableTemp :: String -> IO String
worldReadableTemp String
f = Int -> IO String
wrt Int
0
    where wrt :: Int -> IO FilePath
          wrt :: Int -> IO String
wrt Int
100 = String -> IO String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"Failure creating temp named "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
f
          wrt Int
n = let f_new :: String
f_new = String
fString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"-"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
n
                  in do Bool
ok <- String -> IO Bool
takeFile String
f_new
                        if Bool
ok then String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
f_new
                              else Int -> IO String
wrt (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

withNamedTemp :: FilePath -> (FilePath -> IO a) -> IO a
withNamedTemp :: String -> (String -> IO a) -> IO a
withNamedTemp String
n String -> IO a
f = do
    String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"withNamedTemp: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
n
    IO String -> (String -> IO ()) -> (String -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> IO String
worldReadableTemp String
n) String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist String -> IO a
f

readBinFile :: FilePathLike p => p -> IO B.ByteString
readBinFile :: p -> IO ByteString
readBinFile = String -> IO ByteString
B.readFile (String -> IO ByteString) -> (p -> String) -> p -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> String
forall a. FilePathLike a => a -> String
toFilePath

-- NOTE using 'seq' on the last element of the result causes the content to be
-- fully evaluated, so the file is read strictly; this is more efficient than
-- counting the number of characters; and in the (few) places where we use this
-- function we need the lines anyway.
readTextFile :: FilePathLike p => p -> IO [String]
readTextFile :: p -> IO [String]
readTextFile p
f = do
  [String]
result <- String -> [String]
lines (String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile (p -> String
forall a. FilePathLike a => a -> String
toFilePath p
f)
  case [String]
result of
    [] -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
result
    [String]
xs -> [String] -> String
forall a. [a] -> a
last [String]
xs String -> IO [String] -> IO [String]
`seq` [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
result

readDocBinFile :: FilePathLike p => p -> IO Doc
readDocBinFile :: p -> IO Doc
readDocBinFile p
fp = do ByteString
ps <- String -> IO ByteString
B.readFile (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ p -> String
forall a. FilePathLike a => a -> String
toFilePath p
fp
                       Doc -> IO Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> IO Doc) -> Doc -> IO Doc
forall a b. (a -> b) -> a -> b
$ if ByteString -> Bool
B.null ByteString
ps then Doc
empty else ByteString -> Doc
packedString ByteString
ps

appendBinFile :: FilePathLike p => p -> B.ByteString -> IO ()
appendBinFile :: p -> ByteString -> IO ()
appendBinFile p
f ByteString
s = FileType -> p -> (Handle -> IO ()) -> IO ()
forall p.
FilePathLike p =>
FileType -> p -> (Handle -> IO ()) -> IO ()
appendToFile FileType
Binary p
f ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> ByteString -> IO ()
B.hPut Handle
h ByteString
s

appendTextFile :: FilePathLike p => p -> String -> IO ()
appendTextFile :: p -> String -> IO ()
appendTextFile p
f String
s = FileType -> p -> (Handle -> IO ()) -> IO ()
forall p.
FilePathLike p =>
FileType -> p -> (Handle -> IO ()) -> IO ()
appendToFile FileType
Text p
f ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> String -> IO ()
hPutStr Handle
h String
s

appendDocBinFile :: FilePathLike p => p -> Doc -> IO ()
appendDocBinFile :: p -> Doc -> IO ()
appendDocBinFile p
f Doc
d = FileType -> p -> (Handle -> IO ()) -> IO ()
forall p.
FilePathLike p =>
FileType -> p -> (Handle -> IO ()) -> IO ()
appendToFile FileType
Binary p
f ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> Doc -> IO ()
hPutDoc Handle
h Doc
d

data FileType = Text | Binary

writeBinFile :: FilePathLike p => p -> B.ByteString -> IO ()
writeBinFile :: p -> ByteString -> IO ()
writeBinFile p
f ByteString
s = FileType -> p -> (Handle -> IO ()) -> IO ()
forall p.
FilePathLike p =>
FileType -> p -> (Handle -> IO ()) -> IO ()
writeToFile FileType
Binary p
f ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> ByteString -> IO ()
B.hPut Handle
h ByteString
s

writeTextFile :: FilePathLike p => p -> String -> IO ()
writeTextFile :: p -> String -> IO ()
writeTextFile p
f String
s = FileType -> p -> (Handle -> IO ()) -> IO ()
forall p.
FilePathLike p =>
FileType -> p -> (Handle -> IO ()) -> IO ()
writeToFile FileType
Text p
f ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
  IO TextEncoding
getFileSystemEncoding IO TextEncoding -> (TextEncoding -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h
  Handle -> String -> IO ()
hPutStr Handle
h String
s

writeDocBinFile :: FilePathLike p => p -> Doc -> IO ()
writeDocBinFile :: p -> Doc -> IO ()
writeDocBinFile p
f Doc
d = FileType -> p -> (Handle -> IO ()) -> IO ()
forall p.
FilePathLike p =>
FileType -> p -> (Handle -> IO ()) -> IO ()
writeToFile FileType
Binary p
f ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> Doc -> IO ()
hPutDoc Handle
h Doc
d

writeAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO ()
writeAtomicFilePS :: p -> ByteString -> IO ()
writeAtomicFilePS p
f ByteString
ps = FileType -> p -> (Handle -> IO ()) -> IO ()
forall p.
FilePathLike p =>
FileType -> p -> (Handle -> IO ()) -> IO ()
writeToFile FileType
Binary p
f ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> ByteString -> IO ()
B.hPut Handle
h ByteString
ps

gzWriteAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO ()
gzWriteAtomicFilePS :: p -> ByteString -> IO ()
gzWriteAtomicFilePS p
f ByteString
ps = p -> [ByteString] -> IO ()
forall p. FilePathLike p => p -> [ByteString] -> IO ()
gzWriteAtomicFilePSs p
f [ByteString
ps]

gzWriteAtomicFilePSs :: FilePathLike p => p -> [B.ByteString] -> IO ()
gzWriteAtomicFilePSs :: p -> [ByteString] -> IO ()
gzWriteAtomicFilePSs p
f [ByteString]
pss =
    IO () -> IO ()
forall a. IO a -> IO a
withSignalsBlocked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> (String -> IO ()) -> IO ()
forall a. String -> (String -> IO a) -> IO a
withNamedTemp (p -> String
forall a. FilePathLike a => a -> String
toFilePath p
f) ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
newf -> do
    String -> [ByteString] -> IO ()
gzWriteFilePSs String
newf [ByteString]
pss
    Bool
already_exists <- String -> IO Bool
doesFileExist (String -> IO Bool) -> String -> IO Bool
forall a b. (a -> b) -> a -> b
$ p -> String
forall a. FilePathLike a => a -> String
toFilePath p
f
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
already_exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do FileMode
mode <- FileStatus -> FileMode
fileMode (FileStatus -> FileMode) -> IO FileStatus -> IO FileMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO FileStatus
getFileStatus (p -> String
forall a. FilePathLike a => a -> String
toFilePath p
f)
                             String -> FileMode -> IO ()
setFileMode String
newf FileMode
mode
             IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    String -> String -> IO ()
renameFile String
newf (p -> String
forall a. FilePathLike a => a -> String
toFilePath p
f)

gzWriteDocFile :: FilePathLike p => p -> Doc -> IO ()
gzWriteDocFile :: p -> Doc -> IO ()
gzWriteDocFile p
f Doc
d = p -> [ByteString] -> IO ()
forall p. FilePathLike p => p -> [ByteString] -> IO ()
gzWriteAtomicFilePSs p
f ([ByteString] -> IO ()) -> [ByteString] -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> [ByteString]
renderPSs Doc
d

writeToFile :: FilePathLike p => FileType -> p -> (Handle -> IO ()) -> IO ()
writeToFile :: FileType -> p -> (Handle -> IO ()) -> IO ()
writeToFile FileType
t p
f Handle -> IO ()
job =
    IO () -> IO ()
forall a. IO a -> IO a
withSignalsBlocked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> (String -> IO ()) -> IO ()
forall a. String -> (String -> IO a) -> IO a
withNamedTemp (p -> String
forall a. FilePathLike a => a -> String
toFilePath p
f) ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
newf -> do
    (case FileType
t of
      FileType
Text -> String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile
      FileType
Binary -> String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile) String
newf IOMode
WriteMode Handle -> IO ()
job
    Bool
already_exists <- String -> IO Bool
doesFileExist (p -> String
forall a. FilePathLike a => a -> String
toFilePath p
f)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
already_exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do FileMode
mode <- FileStatus -> FileMode
fileMode (FileStatus -> FileMode) -> IO FileStatus -> IO FileMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO FileStatus
getFileStatus (p -> String
forall a. FilePathLike a => a -> String
toFilePath p
f)
                             String -> FileMode -> IO ()
setFileMode String
newf FileMode
mode
             IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    String -> String -> IO ()
renameFile String
newf (p -> String
forall a. FilePathLike a => a -> String
toFilePath p
f)

appendToFile :: FilePathLike p => FileType -> p -> (Handle -> IO ()) -> IO ()
appendToFile :: FileType -> p -> (Handle -> IO ()) -> IO ()
appendToFile FileType
t p
f Handle -> IO ()
job = IO () -> IO ()
forall a. IO a -> IO a
withSignalsBlocked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    (case FileType
t of
      FileType
Binary -> String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile
      FileType
Text -> String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile) (p -> String
forall a. FilePathLike a => a -> String
toFilePath p
f) IOMode
AppendMode Handle -> IO ()
job


addToErrorLoc :: IOException
              -> String
              -> IOException
addToErrorLoc :: IOError -> String -> IOError
addToErrorLoc IOError
ioe String
s = IOError -> String -> Maybe Handle -> Maybe String -> IOError
annotateIOError IOError
ioe String
s Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing

-- | Do an action in a newly created directory of the given name. If the
-- directory is successfully created but the action raises an exception, the
-- directory and all its content is deleted. Caught exceptions are re-thrown.
withNewDirectory :: FilePath -> IO () -> IO ()
withNewDirectory :: String -> IO () -> IO ()
withNewDirectory String
name IO ()
action = do
  String -> IO ()
createDirectory String
name
  String -> IO () -> IO ()
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory String
name IO ()
action IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \SomeException
e -> do
    String -> IO ()
removePathForcibly String
name IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` (IO () -> IOError -> IO ()
forall a b. a -> b -> a
const (IO () -> IOError -> IO ()) -> IO () -> IOError -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (SomeException
e :: SomeException)