-- 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 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 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 l <- FilePath -> IO FilePath
makeAbsolute FilePath
lbad
                     gotit <- takeLock l
                     if gotit then return l
                              else do putStrLn $ "Waiting for lock "++l
                                      hFlush stdout -- for Windows
                                      threadDelay 2000000
                                      getLock l (tl - 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 pwd <- IO AbsolutePath
getCurrentDirectory
                        throwIO $ addToErrorLoc e
                                   ("takeLock "++toFilePath fp++" in "++toFilePath 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 pwd <- IO AbsolutePath
getCurrentDirectory
                        throwIO $ addToErrorLoc e
                                   ("takeFile "++fp++" in "++toFilePath 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
  c <- IO AbsolutePath
getCurrentDirectory
  return $ listToMaybe $ drop 5 $ reverse $ takeWhile no_darcs $ inits $ toFilePath 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
  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
  formerdir <- getCurrentDirectory
  bracket (createDir absoluteName)
          (\AbsolutePath
dir -> do
              AbsolutePath -> IO ()
forall p. (HasCallStack, FilePathLike p) => p -> IO ()
setCurrentDirectory AbsolutePath
formerdir
              k <- IO Bool
keepTempDir
              unless k $
                  case 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))
          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 ok <- FilePath -> IO Bool
takeFile FilePath
f_new
                        if ok then return f_new
                              else wrt (n+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
  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 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 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
                       return $ if B.null ps then empty else packedString 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
    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
    when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f)
                             setFileMode newf mode
             `catchall` return ()
    renameFile newf (toFilePath f)

gzWriteDocFile :: FilePathLike p => p -> Doc -> IO ()
gzWriteDocFile :: 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
    already_exists <- FilePath -> IO Bool
doesFileExist (p -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath p
f)
    when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f)
                             setFileMode newf mode
             `catchall` return ()
    renameFile newf (toFilePath 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. (HasCallStack, Exception e) => e -> IO a
throwIO (SomeException
e :: SomeException)