-- 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
    , withTempDir
    , withPermDir
    , withDelayedDir
    , withNamedTemp
    , writeBinFile
    , writeTextFile
    , writeDocBinFile
    , appendBinFile
    , appendTextFile
    , appendDocBinFile
    , readBinFile
    , readTextFile
    , readDocBinFile
    , writeAtomicFilePS
    , gzWriteAtomicFilePS
    , gzWriteAtomicFilePSs
    , gzWriteDocFile
    , removeFileMayNotExist
    , 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
    , Handle, hPutStr, hSetEncoding
    , IOMode(WriteMode, AppendMode), hFlush, stdout
    )
import System.IO.Error
    ( isAlreadyExistsError
    , annotateIOError
    , catchIOError
    )
import Control.Exception
    ( IOException
    , bracket
    , throwIO
    , catch
    , SomeException
    )
import System.Directory
    ( doesFileExist
    , doesDirectoryExist
    , createDirectory
    , getTemporaryDirectory
    , makeAbsolute
    , removePathForcibly
    , renameFile
    , renameDirectory
    )
import System.FilePath.Posix ( splitDirectories, splitFileName )
import System.Directory ( withCurrentDirectory )
import System.Environment ( lookupEnv )
import System.IO.Temp ( createTempDirectory )

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

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

import GHC.IO.Encoding ( getFileSystemEncoding )

import Safe ( headErr )

import Darcs.Util.URL ( isRelative )
import Darcs.Util.Exception
    ( firstJustIO
    , catchall
    )
import Darcs.Util.File ( 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
    ( maybeRelink
    , atomicCreate
    , sloppyAtomicCreate
    )
import Darcs.Util.Progress ( debugMessage )
import Darcs.Util.Prompt ( askUser )

withLock :: String -> IO a -> IO a
withLock :: forall a. FilePath -> IO a -> IO a
withLock FilePath
s IO a
job = IO FilePath -> (FilePath -> IO ()) -> (FilePath -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (FilePath -> Int -> IO FilePath
getLock FilePath
s Int
30) FilePath -> IO ()
releaseLock (IO a -> FilePath -> IO a
forall a b. a -> b -> a
const IO a
job)

releaseLock :: String -> IO ()
releaseLock :: FilePath -> IO ()
releaseLock = FilePath -> 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 :: forall a. FilePath -> IO a -> IO (Either () a)
withLockCanFail FilePath
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 (FilePath -> IO Bool
forall p. FilePathLike p => p -> IO Bool
takeLock FilePath
s IO Bool -> IO Bool -> IO Bool
forall a. IO a -> IO a -> IO a
`catchall` Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
          (\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
$ FilePath -> IO ()
releaseLock FilePath
s)
          (\Bool
l -> if Bool
l then a -> Either () a
forall a b. b -> Either a b
Right (a -> Either () a) -> IO a -> IO (Either () a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
job
                      else Either () a -> IO (Either () a)
forall a. a -> IO 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 :: FilePath -> Int -> IO FilePath
getLock FilePath
l Int
0 = do FilePath
yorn <- FilePath -> IO FilePath
askUser (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"Couldn't get lock "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
lFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
". Abort (yes or anything else)? "
                 case FilePath
yorn of
                    (Char
'y':FilePath
_) -> ExitCode -> IO FilePath
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO FilePath) -> ExitCode -> IO FilePath
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
1
                    FilePath
_ -> FilePath -> Int -> IO FilePath
getLock FilePath
l Int
30
getLock FilePath
lbad Int
tl = do FilePath
l <- FilePath -> IO FilePath
makeAbsolute FilePath
lbad
                     Bool
gotit <- FilePath -> IO Bool
forall p. FilePathLike p => p -> IO Bool
takeLock FilePath
l
                     if Bool
gotit then FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
l
                              else do FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Waiting for lock "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
l
                                      Handle -> IO ()
hFlush Handle
stdout -- for Windows
                                      Int -> IO ()
threadDelay Int
2000000
                                      FilePath -> Int -> IO FilePath
getLock FilePath
l (Int
tl Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)


takeLock :: FilePathLike p => p -> IO Bool
takeLock :: forall p. FilePathLike p => p -> IO Bool
takeLock p
fp =
    do FilePath -> IO ()
atomicCreate (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ p -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath p
fp
       Bool -> IO Bool
forall a. a -> IO a
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 a. a -> IO a
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 -> FilePath -> IOError
addToErrorLoc IOError
e
                                   (FilePath
"takeLock "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++p -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath p
fpFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
" in "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++AbsolutePath -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath AbsolutePath
pwd)

takeFile :: FilePath -> IO Bool
takeFile :: FilePath -> IO Bool
takeFile FilePath
fp =
    do FilePath -> IO ()
sloppyAtomicCreate FilePath
fp
       Bool -> IO Bool
forall a. a -> IO a
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 a. a -> IO a
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 -> FilePath -> IOError
addToErrorLoc IOError
e
                                   (FilePath
"takeFile "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
fpFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
" in "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++AbsolutePath -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath AbsolutePath
pwd)

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

tempdirLoc :: IO FilePath
tempdirLoc :: IO FilePath
tempdirLoc = Maybe FilePath -> FilePath
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe FilePath -> FilePath) -> IO (Maybe FilePath) -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    [IO (Maybe FilePath)] -> IO (Maybe FilePath)
forall a. [IO (Maybe a)] -> IO (Maybe a)
firstJustIO [ (FilePath -> Maybe FilePath) -> IO FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath)
-> (FilePath -> FilePath) -> FilePath -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
forall a. HasCallStack => [a] -> a
headErr ([FilePath] -> FilePath)
-> (FilePath -> [FilePath]) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
words) (FilePath -> IO FilePath
readFile (FilePath
darcsdirFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"/prefs/tmpdir")) IO (Maybe FilePath)
-> (Maybe FilePath -> IO (Maybe FilePath)) -> IO (Maybe FilePath)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe FilePath -> IO (Maybe FilePath)
chkdir,
                  FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"DARCS_TMPDIR" IO (Maybe FilePath)
-> (Maybe FilePath -> IO (Maybe FilePath)) -> IO (Maybe FilePath)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe FilePath -> IO (Maybe FilePath)
chkdir,
                  IO FilePath
getTemporaryDirectory IO FilePath
-> (FilePath -> IO (Maybe FilePath)) -> IO (Maybe FilePath)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe FilePath -> IO (Maybe FilePath)
chkdir (Maybe FilePath -> IO (Maybe FilePath))
-> (FilePath -> Maybe FilePath) -> FilePath -> IO (Maybe FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just,
                  IO (Maybe FilePath)
getCurrentDirectorySansDarcs,
                  Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"."  -- always returns a Just
                ]
    where chkdir :: Maybe FilePath -> IO (Maybe FilePath)
chkdir Maybe FilePath
Nothing = Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
          chkdir (Just FilePath
d) = (\Bool
e -> if Bool
e then FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath
dFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"/") else Maybe FilePath
forall a. Maybe a
Nothing) (Bool -> Maybe FilePath) -> IO Bool -> IO (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Bool
doesDirectoryExist FilePath
d

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

getCurrentDirectorySansDarcs :: IO (Maybe FilePath)
getCurrentDirectorySansDarcs :: IO (Maybe FilePath)
getCurrentDirectorySansDarcs = do
  AbsolutePath
c <- IO AbsolutePath
getCurrentDirectory
  Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ [FilePath] -> Maybe FilePath
forall a. [a] -> Maybe a
listToMaybe ([FilePath] -> Maybe FilePath) -> [FilePath] -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ Int -> [FilePath] -> [FilePath]
forall a. Int -> [a] -> [a]
drop Int
5 ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile FilePath -> Bool
no_darcs ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
forall a. [a] -> [[a]]
inits (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ AbsolutePath -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath AbsolutePath
c
  where no_darcs :: FilePath -> Bool
no_darcs FilePath
x = FilePath
darcsdir FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` FilePath -> [FilePath]
splitDirectories FilePath
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 :: forall a. WithDirKind -> FilePath -> (AbsolutePath -> IO a) -> IO a
withDir WithDirKind
_ FilePath
"" AbsolutePath -> IO a
_ = FilePath -> IO a
forall a. HasCallStack => FilePath -> a
error FilePath
"withDir called with empty directory name"
withDir WithDirKind
kind FilePath
absoluteOrRelativeName AbsolutePath -> IO a
job = do
  FilePath
absoluteName <- if FilePath -> Bool
isRelative FilePath
absoluteOrRelativeName
                   then (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
absoluteOrRelativeName) IO FilePath
tempdirLoc
                   else FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
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 (FilePath -> IO AbsolutePath
createDir FilePath
absoluteName)
          (\AbsolutePath
dir -> do
              AbsolutePath -> IO ()
forall p. (HasCallStack, 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                      WithDirKind
Temp -> FilePath -> IO ()
cleanup (AbsolutePath -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath AbsolutePath
dir)
                      WithDirKind
Delayed -> IO () -> IO ()
atexit (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
cleanup (AbsolutePath -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath AbsolutePath
dir))
          AbsolutePath -> IO a
job
    where createDir :: FilePath -> IO AbsolutePath
          createDir :: FilePath -> IO AbsolutePath
createDir FilePath
name
              = do let (FilePath
parent,FilePath
dir) = FilePath -> (FilePath, FilePath)
splitFileName FilePath
name
                   FilePath -> FilePath -> IO FilePath
createTempDirectory FilePath
parent FilePath
dir IO FilePath -> (FilePath -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> IO ()
forall p. (HasCallStack, FilePathLike p) => p -> IO ()
setCurrentDirectory
                   IO AbsolutePath
getCurrentDirectory
          keepTempDir :: IO Bool
keepTempDir = Maybe FilePath -> Bool
forall a. Maybe a -> Bool
isJust (Maybe FilePath -> Bool) -> IO (Maybe FilePath) -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FilePath -> IO (Maybe FilePath)
lookupEnv FilePath
"DARCS_KEEP_TMPDIR"
          toDelete :: FilePath -> FilePath
toDelete FilePath
dir = FilePath
dir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"_done"
          cleanup :: FilePath -> IO ()
cleanup FilePath
path = do
              -- so asynchronous threads cannot add any more
              -- files while we are deleting
              FilePath -> IO ()
debugMessage (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords [FilePath
"atexit: renaming",FilePath
path,FilePath
"to",FilePath -> FilePath
toDelete FilePath
path]
              FilePath -> FilePath -> IO ()
renameDirectory FilePath
path (FilePath -> FilePath
toDelete FilePath
path)
              FilePath -> IO ()
debugMessage (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords [FilePath
"atexit: deleting",FilePath -> FilePath
toDelete FilePath
path]
              FilePath -> IO ()
removePathForcibly (FilePath -> FilePath
toDelete FilePath
path) 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 ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

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

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

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

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

readBinFile :: FilePathLike p => p -> IO B.ByteString
readBinFile :: forall p. FilePathLike p => p -> IO ByteString
readBinFile = FilePath -> IO ByteString
B.readFile (FilePath -> IO ByteString)
-> (p -> FilePath) -> p -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> FilePath
forall a. FilePathLike a => a -> FilePath
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 :: forall p. FilePathLike p => p -> IO [FilePath]
readTextFile p
f = do
  [FilePath]
result <- FilePath -> [FilePath]
lines (FilePath -> [FilePath]) -> IO FilePath -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
readFile (p -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath p
f)
  case [FilePath]
result of
    [] -> [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath]
result
    [FilePath]
xs -> [FilePath] -> FilePath
forall a. HasCallStack => [a] -> a
last [FilePath]
xs FilePath -> IO [FilePath] -> IO [FilePath]
forall a b. a -> b -> b
`seq` [FilePath] -> IO [FilePath]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath]
result

readDocBinFile :: FilePathLike p => p -> IO Doc
readDocBinFile :: forall p. FilePathLike p => p -> IO Doc
readDocBinFile p
fp = do ByteString
ps <- FilePath -> IO ByteString
B.readFile (FilePath -> IO ByteString) -> FilePath -> IO ByteString
forall a b. (a -> b) -> a -> b
$ p -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath p
fp
                       Doc -> IO Doc
forall a. a -> IO a
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 :: forall p. FilePathLike p => 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 :: forall p. FilePathLike p => p -> FilePath -> IO ()
appendTextFile p
f FilePath
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 -> FilePath -> IO ()
hPutStr Handle
h FilePath
s

appendDocBinFile :: FilePathLike p => p -> Doc -> IO ()
appendDocBinFile :: forall p. FilePathLike p => 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 :: forall p. FilePathLike p => 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 :: forall p. FilePathLike p => p -> FilePath -> IO ()
writeTextFile p
f FilePath
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 a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h
  Handle -> FilePath -> IO ()
hPutStr Handle
h FilePath
s

writeDocBinFile :: FilePathLike p => p -> Doc -> IO ()
writeDocBinFile :: forall p. FilePathLike p => 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 :: forall p. FilePathLike p => 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 :: forall p. FilePathLike p => 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 :: forall p. FilePathLike p => 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
$ FilePath -> (FilePath -> IO ()) -> IO ()
forall a. FilePath -> (FilePath -> IO a) -> IO a
withNamedTemp (p -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath p
f) ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
newf -> do
    FilePath -> [ByteString] -> IO ()
gzWriteFilePSs FilePath
newf [ByteString]
pss
    Bool
already_exists <- FilePath -> IO Bool
doesFileExist (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ p -> FilePath
forall a. FilePathLike a => a -> FilePath
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 a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FilePath -> IO FileStatus
getFileStatus (p -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath p
f)
                             FilePath -> FileMode -> IO ()
setFileMode FilePath
newf FileMode
mode
             IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    FilePath -> FilePath -> IO ()
renameFile FilePath
newf (p -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath p
f)

gzWriteDocFile :: FilePathLike p => p -> Doc -> IO ()
gzWriteDocFile :: forall p. FilePathLike p => 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 :: forall p.
FilePathLike p =>
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
$ FilePath -> (FilePath -> IO ()) -> IO ()
forall a. FilePath -> (FilePath -> IO a) -> IO a
withNamedTemp (p -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath p
f) ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
newf -> do
    (case FileType
t of
      FileType
Text -> FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile
      FileType
Binary -> FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile) FilePath
newf IOMode
WriteMode Handle -> IO ()
job
    Bool
already_exists <- FilePath -> IO Bool
doesFileExist (p -> FilePath
forall a. FilePathLike a => a -> FilePath
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 a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FilePath -> IO FileStatus
getFileStatus (p -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath p
f)
                             FilePath -> FileMode -> IO ()
setFileMode FilePath
newf FileMode
mode
             IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    FilePath -> FilePath -> IO ()
renameFile FilePath
newf (p -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath p
f)

appendToFile :: FilePathLike p => FileType -> p -> (Handle -> IO ()) -> IO ()
appendToFile :: forall p.
FilePathLike p =>
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 -> FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile
      FileType
Text -> FilePath -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile) (p -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath p
f) IOMode
AppendMode Handle -> IO ()
job


addToErrorLoc :: IOException
              -> String
              -> IOException
addToErrorLoc :: IOError -> FilePath -> IOError
addToErrorLoc IOError
ioe FilePath
s = IOError -> FilePath -> Maybe Handle -> Maybe FilePath -> IOError
annotateIOError IOError
ioe FilePath
s Maybe Handle
forall a. Maybe a
Nothing Maybe FilePath
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 :: FilePath -> IO () -> IO ()
withNewDirectory FilePath
name IO ()
action = do
  FilePath -> IO ()
createDirectory FilePath
name
  FilePath -> IO () -> IO ()
forall a. FilePath -> IO a -> IO a
withCurrentDirectory FilePath
name IO ()
action IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \SomeException
e -> do
    FilePath -> IO ()
removePathForcibly FilePath
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 ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (SomeException
e :: SomeException)