-- 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
    , withStdoutTemp
    , withTempDir
    , withPermDir
    , withDelayedDir
    , withNamedTemp
    , writeBinFile
    , writeTextFile
    , writeDocBinFile
    , appendBinFile
    , appendTextFile
    , appendDocBinFile
    , readBinFile
    , readTextFile
    , readDocBinFile
    , writeAtomicFilePS
    , gzWriteAtomicFilePS
    , gzWriteAtomicFilePSs
    , gzWriteDocFile
    , rmRecursive
    , removeFileMayNotExist
    , canonFilename
    , maybeRelink
    , tempdirLoc
    , environmentHelpTmpdir
    , environmentHelpKeepTmpdir
    , addToErrorLoc
    , withNewDirectory
    ) where

import Prelude ()
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
    ( removeFile
    , removeDirectory
    , doesFileExist
    , doesDirectoryExist
    , getDirectoryContents
    , createDirectory
    , getTemporaryDirectory
    , removeDirectoryRecursive
    )
import System.FilePath.Posix ( splitDirectories )
import System.Environment ( lookupEnv )

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
                       , doesDirectoryReallyExist, 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.Workaround ( renameFile )
import Darcs.Util.Compat
    ( mkStdoutTemp
    , 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 s :: String
s job :: 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 30) String -> IO ()
releaseLock (\_ -> 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 s :: String
s job :: 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)
          (\l :: 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)
          (\l :: 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 l :: String
l 0 = do String
yorn <- String -> IO String
askUser (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ "Couldn't get lock "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
lString -> String -> String
forall a. [a] -> [a] -> [a]
++". Abort (yes or anything else)? "
                 case String
yorn of
                    ('y':_) -> 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 1
                    _ -> String -> Int -> IO String
getlock String
l 30
getlock lbad :: String
lbad tl :: 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
$ "Waiting for lock "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
l
                                      Handle -> IO ()
hFlush Handle
stdout -- for Windows
                                      Int -> IO ()
threadDelay 2000000
                                      String -> Int -> IO String
getlock String
l (Int
tl Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)


takeLock :: FilePathLike p => p -> IO Bool
takeLock :: p -> IO Bool
takeLock fp :: 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` \e :: 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
                                   ("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]
++" 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 fp :: 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` \e :: 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
                                   ("takeFile "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
fpString -> String -> String
forall a. [a] -> [a] -> [a]
++" 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 = (["DARCS_SLOPPY_LOCKS"],[
 "If on some filesystems you get an error of the kind:",
 "",
 "    darcs: takeLock [...]: atomic_create [...]: unsupported operation",
 "",
 "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 (f :: String
f,h :: Handle
h) <- String -> String -> IO (String, Handle)
openBinaryTempFile "." "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 (h :: Handle
h,f :: 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 "." "darcs"
          invert :: (b, a) -> (a, b)
invert (a :: b
a,b :: a
b) = (a
b,b
a)

withStdoutTemp :: (FilePath -> IO a) -> IO a
withStdoutTemp :: (String -> IO a) -> IO a
withStdoutTemp = 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
mkStdoutTemp "stdout_") String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist

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]
++"/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 "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 "."  -- always returns a Just
                ]
    where chkdir :: Maybe String -> IO (Maybe String)
chkdir Nothing = Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
          chkdir (Just d :: String
d) = (Bool -> Maybe String) -> IO Bool -> IO (Maybe String)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\e :: Bool
e -> if Bool
e then String -> Maybe String
forall a. a -> Maybe a
Just (String
dString -> String -> String
forall a. [a] -> [a] -> [a]
++"/") 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 = (["DARCS_TMPDIR", "TMPDIR"], [
 "Darcs often creates temporary directories.  For example, the `darcs",
 "diff` command creates two for the working trees to be diffed.  By",
 "default temporary directories are created in /tmp, or if that doesn't",
 "exist, in _darcs (within the current repo).  This can be overridden by",
 "specifying some other directory in the file _darcs/prefs/tmpdir or the",
 "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 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 x :: 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 _ "" _ = String -> IO a
forall a. String -> a
bug "withDir called with empty directory name"
withDir kind :: WithDirKind
kind absoluteOrRelativeName :: String
absoluteOrRelativeName job :: 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 -> Int -> IO AbsolutePath
createDir String
absoluteName 0)
          (\dir :: 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
                                   Perm -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                   Temp -> String -> IO ()
rmRecursive (AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath AbsolutePath
dir)
                                   Delayed -> IO () -> IO ()
atexit (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
rmRecursive (AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath AbsolutePath
dir))
          AbsolutePath -> IO a
job
    where newname :: String -> a -> String
newname name :: String
name 0 = String
name
          newname name :: String
name n :: a
n = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ "-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n
          createDir :: FilePath -> Int -> IO AbsolutePath
          createDir :: String -> Int -> IO AbsolutePath
createDir name :: String
name n :: Int
n
              = do String -> IO ()
createDirectory (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Int -> String
forall a. (Eq a, Num a, Show a) => String -> a -> String
newname String
name Int
n
                   String -> IO ()
forall p. FilePathLike p => p -> IO ()
setCurrentDirectory (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Int -> String
forall a. (Eq a, Num a, Show a) => String -> a -> String
newname String
name Int
n
                   IO AbsolutePath
getCurrentDirectory
                IO AbsolutePath -> (IOError -> IO AbsolutePath) -> IO AbsolutePath
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\e :: IOError
e -> if IOError -> Bool
isAlreadyExistsError IOError
e
                               then String -> Int -> IO AbsolutePath
createDir String
name (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)
                               else IOError -> IO AbsolutePath
forall e a. Exception e => e -> IO a
throwIO IOError
e)
          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 "DARCS_KEEP_TMPDIR"

environmentHelpKeepTmpdir :: ([String], [String])
environmentHelpKeepTmpdir :: ([String], [String])
environmentHelpKeepTmpdir = (["DARCS_KEEP_TMPDIR"],[
 "If the environment variable DARCS_KEEP_TMPDIR is defined, darcs will",
 "not remove the temporary directories it creates.  This is intended",
 "primarily for debugging Darcs itself, but it can also be useful, for",
 "example, to determine why your test preference (see `darcs setpref`)",
 "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

rmRecursive :: FilePath -> IO ()
rmRecursive :: String -> IO ()
rmRecursive d :: String
d =
    do Bool
isd <- String -> IO Bool
doesDirectoryReallyExist String
d
       if Bool -> Bool
not Bool
isd
          then String -> IO ()
removeFile String
d
          else do [String]
conts <- IO [String]
actual_dir_contents
                  String -> IO () -> IO ()
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory String
d (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
rmRecursive [String]
conts
                  String -> IO ()
removeDirectory String
d
    where actual_dir_contents :: IO [String]
actual_dir_contents = -- doesn't include . or ..
              do [String]
c <- String -> IO [String]
getDirectoryContents String
d
                 [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=".") ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/="..") [String]
c

worldReadableTemp :: FilePath -> IO FilePath
worldReadableTemp :: String -> IO String
worldReadableTemp f :: String
f = Int -> IO String
wrt 0
    where wrt :: Int -> IO FilePath
          wrt :: Int -> IO String
wrt 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
$ "Failure creating temp named "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
f
          wrt n :: Int
n = let f_new :: String
f_new = String
fString -> String -> String
forall a. [a] -> [a] -> [a]
++"-"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
+1)

withNamedTemp :: FilePath -> (FilePath -> IO a) -> IO a
withNamedTemp :: String -> (String -> IO a) -> IO a
withNamedTemp n :: String
n f :: String -> IO a
f = do
    String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "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 f :: 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
    xs :: [String]
xs -> [String] -> String
forall a. [a] -> a
last [String]
xs String -> IO [String] -> IO [String]
forall a b. a -> b -> b
`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 fp :: 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 f :: p
f s :: 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
$ \h :: Handle
h -> Handle -> ByteString -> IO ()
B.hPut Handle
h ByteString
s

appendTextFile :: FilePathLike p => p -> String -> IO ()
appendTextFile :: p -> String -> IO ()
appendTextFile f :: p
f s :: 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
$ \h :: Handle
h -> Handle -> String -> IO ()
hPutStr Handle
h String
s

appendDocBinFile :: FilePathLike p => p -> Doc -> IO ()
appendDocBinFile :: p -> Doc -> IO ()
appendDocBinFile f :: p
f d :: 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
$ \h :: 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 f :: p
f s :: 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
$ \h :: Handle
h -> Handle -> ByteString -> IO ()
B.hPut Handle
h ByteString
s

writeTextFile :: FilePathLike p => p -> String -> IO ()
writeTextFile :: p -> String -> IO ()
writeTextFile f :: p
f s :: 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
$ \h :: 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 f :: p
f d :: 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
$ \h :: Handle
h -> Handle -> Doc -> IO ()
hPutDoc Handle
h Doc
d

writeAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO ()
writeAtomicFilePS :: p -> ByteString -> IO ()
writeAtomicFilePS f :: p
f ps :: 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
$ \h :: Handle
h -> Handle -> ByteString -> IO ()
B.hPut Handle
h ByteString
ps

gzWriteAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO ()
gzWriteAtomicFilePS :: p -> ByteString -> IO ()
gzWriteAtomicFilePS f :: p
f ps :: 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 f :: p
f pss :: [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
$ \newf :: 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 f :: p
f d :: 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 t :: FileType
t f :: p
f job :: 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
$ \newf :: String
newf -> do
    (case FileType
t of
      Text -> String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile
      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 t :: FileType
t f :: p
f job :: 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
      Binary -> String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile
      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 ioe :: IOError
ioe s :: 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 name :: String
name action :: 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` \e :: SomeException
e -> do
    String -> IO ()
removeDirectoryRecursive 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)