module Darcs.Util.Lock
( withLock
, withLockCanFail
, environmentHelpLocks
, withTemp
, withOpenTemp
, withTempDir
, withPermDir
, withDelayedDir
, withNamedTemp
, writeBinFile
, writeTextFile
, writeDocBinFile
, appendBinFile
, appendTextFile
, appendDocBinFile
, readBinFile
, readTextFile
, readDocBinFile
, writeAtomicFilePS
, gzWriteAtomicFilePS
, gzWriteAtomicFilePSs
, gzWriteDocFile
, removeFileMayNotExist
, canonFilename
, maybeRelink
, tempdirLoc
, environmentHelpTmpdir
, environmentHelpKeepTmpdir
, addToErrorLoc
, withNewDirectory
) where
import Darcs.Prelude
import Data.List ( inits )
import Data.Maybe ( fromJust, isJust, listToMaybe )
import System.Exit ( exitWith, ExitCode(..) )
import System.IO
( withFile, withBinaryFile, openBinaryTempFile
, hClose, Handle, hPutStr, hSetEncoding
, IOMode(WriteMode, AppendMode), hFlush, stdout
)
import System.IO.Error
( isAlreadyExistsError
, annotateIOError
, catchIOError
)
import Control.Exception
( IOException
, bracket
, throwIO
, catch
, try
, SomeException
)
import System.Directory
( removePathForcibly
, doesFileExist
, doesDirectoryExist
, createDirectory
, getTemporaryDirectory
, removePathForcibly
, renameFile
, renameDirectory
)
import System.FilePath.Posix ( splitDirectories, splitFileName )
import System.Environment ( lookupEnv )
import System.IO.Temp ( createTempDirectory )
import Control.Concurrent ( threadDelay )
import Control.Monad ( unless, when, liftM )
import System.Posix.Files ( fileMode, getFileStatus, setFileMode )
import GHC.IO.Encoding ( getFileSystemEncoding )
import Darcs.Util.URL ( isRelative )
import Darcs.Util.Exception
( firstJustIO
, catchall
)
import Darcs.Util.File ( withCurrentDirectory
, removeFileMayNotExist )
import Darcs.Util.Path ( AbsolutePath, FilePathLike, toFilePath,
getCurrentDirectory, setCurrentDirectory )
import Darcs.Util.ByteString ( gzWriteFilePSs )
import qualified Data.ByteString as B (null, readFile, hPut, ByteString)
import Darcs.Util.SignalHandler ( withSignalsBlocked )
import Darcs.Util.Printer ( Doc, hPutDoc, packedString, empty, renderPSs )
import Darcs.Util.AtExit ( atexit )
import Darcs.Util.Global ( darcsdir )
import Darcs.Util.Compat
( canonFilename
, maybeRelink
, atomicCreate
, sloppyAtomicCreate
)
import Darcs.Util.Progress ( debugMessage )
import Darcs.Util.Prompt ( askUser )
withLock :: String -> IO a -> IO a
withLock :: forall a. FilePath -> IO a -> IO a
withLock FilePath
s IO a
job = 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 (\FilePath
_ -> IO a
job)
releaseLock :: String -> IO ()
releaseLock :: FilePath -> IO ()
releaseLock = forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist
withLockCanFail :: String -> IO a -> IO (Either () a)
withLockCanFail :: forall a. FilePath -> IO a -> IO (Either () a)
withLockCanFail FilePath
s IO a
job =
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (forall p. FilePathLike p => p -> IO Bool
takeLock FilePath
s)
(\Bool
l -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
l forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
releaseLock FilePath
s)
(\Bool
l -> if Bool
l then forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. b -> Either a b
Right IO a
job
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ FilePath
"Couldn't get lock "forall a. [a] -> [a] -> [a]
++FilePath
lforall a. [a] -> [a] -> [a]
++FilePath
". Abort (yes or anything else)? "
case FilePath
yorn of
(Char
'y':FilePath
_) -> forall a. ExitCode -> IO a
exitWith 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
canonFilename FilePath
lbad
Bool
gotit <- forall p. FilePathLike p => p -> IO Bool
takeLock FilePath
l
if Bool
gotit then forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
l
else do FilePath -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ FilePath
"Waiting for lock "forall a. [a] -> [a] -> [a]
++FilePath
l
Handle -> IO ()
hFlush Handle
stdout
Int -> IO ()
threadDelay Int
2000000
FilePath -> Int -> IO FilePath
getlock FilePath
l (Int
tl 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 forall a b. (a -> b) -> a -> b
$ forall a. FilePathLike a => a -> FilePath
toFilePath p
fp
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \IOError
e -> if IOError -> Bool
isAlreadyExistsError IOError
e
then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else do AbsolutePath
pwd <- IO AbsolutePath
getCurrentDirectory
forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ IOError -> FilePath -> IOError
addToErrorLoc IOError
e
(FilePath
"takeLock "forall a. [a] -> [a] -> [a]
++forall a. FilePathLike a => a -> FilePath
toFilePath p
fpforall a. [a] -> [a] -> [a]
++FilePath
" in "forall a. [a] -> [a] -> [a]
++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
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \IOError
e -> if IOError -> Bool
isAlreadyExistsError IOError
e
then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else do AbsolutePath
pwd <- IO AbsolutePath
getCurrentDirectory
forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ IOError -> FilePath -> IOError
addToErrorLoc IOError
e
(FilePath
"takeFile "forall a. [a] -> [a] -> [a]
++FilePath
fpforall a. [a] -> [a] -> [a]
++FilePath
" in "forall a. [a] -> [a] -> [a]
++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."])
withTemp :: (FilePath -> IO a) -> IO a
withTemp :: forall a. (FilePath -> IO a) -> IO a
withTemp = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO FilePath
get_empty_file forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist
where get_empty_file :: IO FilePath
get_empty_file = do (FilePath
f,Handle
h) <- FilePath -> FilePath -> IO (FilePath, Handle)
openBinaryTempFile FilePath
"." FilePath
"darcs"
Handle -> IO ()
hClose Handle
h
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
f
withOpenTemp :: ((Handle, FilePath) -> IO a) -> IO a
withOpenTemp :: forall a. ((Handle, FilePath) -> IO a) -> IO a
withOpenTemp = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Handle, FilePath)
get_empty_file forall {p}. FilePathLike p => (Handle, p) -> IO ()
cleanup
where cleanup :: (Handle, p) -> IO ()
cleanup (Handle
h,p
f) = do Either SomeException ()
_ <- forall e a. Exception e => IO a -> IO (Either e a)
try (Handle -> IO ()
hClose Handle
h) :: IO (Either SomeException ())
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist p
f
get_empty_file :: IO (Handle, FilePath)
get_empty_file = forall {b} {a}. (b, a) -> (a, b)
invert forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FilePath -> FilePath -> IO (FilePath, Handle)
openBinaryTempFile FilePath
"." FilePath
"darcs"
invert :: (b, a) -> (a, b)
invert (b
a,a
b) = (a
b,b
a)
tempdirLoc :: IO FilePath
tempdirLoc :: IO FilePath
tempdirLoc = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$
forall a. [IO (Maybe a)] -> IO (Maybe a)
firstJustIO [ forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
words) (FilePath -> IO FilePath
readFile (FilePath
darcsdirforall a. [a] -> [a] -> [a]
++FilePath
"/prefs/tmpdir")) 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" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe FilePath -> IO (Maybe FilePath)
chkdir,
IO FilePath
getTemporaryDirectory forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe FilePath -> IO (Maybe FilePath)
chkdir forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just,
IO (Maybe FilePath)
getCurrentDirectorySansDarcs,
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just FilePath
"."
]
where chkdir :: Maybe FilePath -> IO (Maybe FilePath)
chkdir Maybe FilePath
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
chkdir (Just FilePath
d) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\Bool
e -> if Bool
e then forall a. a -> Maybe a
Just (FilePath
dforall a. [a] -> [a] -> [a]
++FilePath
"/") else forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
5 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile FilePath -> Bool
no_darcs forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]]
inits forall a b. (a -> b) -> a -> b
$ forall a. FilePathLike a => a -> FilePath
toFilePath AbsolutePath
c
where no_darcs :: FilePath -> Bool
no_darcs FilePath
x = FilePath
darcsdir forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` FilePath -> [FilePath]
splitDirectories FilePath
x
data WithDirKind = Perm | Temp | Delayed
withDir :: WithDirKind
-> FilePath
-> (AbsolutePath -> IO a) -> IO a
withDir :: forall a. WithDirKind -> FilePath -> (AbsolutePath -> IO a) -> IO a
withDir WithDirKind
_ FilePath
"" AbsolutePath -> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. [a] -> [a] -> [a]
++ FilePath
absoluteOrRelativeName) IO FilePath
tempdirLoc
else forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
absoluteOrRelativeName
AbsolutePath
formerdir <- IO AbsolutePath
getCurrentDirectory
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (FilePath -> IO AbsolutePath
createDir FilePath
absoluteName)
(\AbsolutePath
dir -> do
forall p. FilePathLike p => p -> IO ()
setCurrentDirectory AbsolutePath
formerdir
Bool
k <- IO Bool
keepTempDir
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
k forall a b. (a -> b) -> a -> b
$
case WithDirKind
kind of
WithDirKind
Perm -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
WithDirKind
Temp -> FilePath -> IO ()
cleanup (forall a. FilePathLike a => a -> FilePath
toFilePath AbsolutePath
dir)
WithDirKind
Delayed -> IO () -> IO ()
atexit forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
cleanup (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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall p. FilePathLike p => p -> IO ()
setCurrentDirectory
IO AbsolutePath
getCurrentDirectory
keepTempDir :: IO Bool
keepTempDir = forall a. Maybe a -> Bool
isJust 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 forall a. [a] -> [a] -> [a]
++ FilePath
"_done"
cleanup :: FilePath -> IO ()
cleanup FilePath
path = do
FilePath -> IO ()
debugMessage 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 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)
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 :: FilePath -> (AbsolutePath -> IO a) -> IO a
withPermDir :: forall a. FilePath -> (AbsolutePath -> IO a) -> IO a
withPermDir = forall a. WithDirKind -> FilePath -> (AbsolutePath -> IO a) -> IO a
withDir WithDirKind
Perm
withTempDir :: FilePath -> (AbsolutePath -> IO a) -> IO a
withTempDir :: forall a. FilePath -> (AbsolutePath -> IO a) -> IO a
withTempDir = 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 = 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 = forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall a b. (a -> b) -> a -> b
$ FilePath
"Failure creating temp named "forall a. [a] -> [a] -> [a]
++FilePath
f
wrt Int
n = let f_new :: FilePath
f_new = FilePath
fforall a. [a] -> [a] -> [a]
++FilePath
"-"forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> FilePath
show Int
n
in do Bool
ok <- FilePath -> IO Bool
takeFile FilePath
f_new
if Bool
ok then forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
f_new
else Int -> IO FilePath
wrt (Int
nforall 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
FilePath -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ FilePath
"withNamedTemp: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show FilePath
n
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (FilePath -> IO FilePath
worldReadableTemp FilePath
n) 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FilePathLike a => a -> FilePath
toFilePath
readTextFile :: FilePathLike p => p -> IO [String]
readTextFile :: forall p. FilePathLike p => p -> IO [FilePath]
readTextFile p
f = do
[FilePath]
result <- FilePath -> [FilePath]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
readFile (forall a. FilePathLike a => a -> FilePath
toFilePath p
f)
case [FilePath]
result of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath]
result
[FilePath]
xs -> forall a. [a] -> a
last [FilePath]
xs seq :: forall a b. a -> b -> b
`seq` 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 forall a b. (a -> b) -> a -> b
$ forall a. FilePathLike a => a -> FilePath
toFilePath p
fp
forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall p.
FilePathLike p =>
FileType -> p -> (Handle -> IO ()) -> IO ()
appendToFile FileType
Binary p
f 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 = forall p.
FilePathLike p =>
FileType -> p -> (Handle -> IO ()) -> IO ()
appendToFile FileType
Text p
f 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 = forall p.
FilePathLike p =>
FileType -> p -> (Handle -> IO ()) -> IO ()
appendToFile FileType
Binary p
f 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 = forall p.
FilePathLike p =>
FileType -> p -> (Handle -> IO ()) -> IO ()
writeToFile FileType
Binary p
f 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 = forall p.
FilePathLike p =>
FileType -> p -> (Handle -> IO ()) -> IO ()
writeToFile FileType
Text p
f forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
IO TextEncoding
getFileSystemEncoding 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 = forall p.
FilePathLike p =>
FileType -> p -> (Handle -> IO ()) -> IO ()
writeToFile FileType
Binary p
f 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 = forall p.
FilePathLike p =>
FileType -> p -> (Handle -> IO ()) -> IO ()
writeToFile FileType
Binary p
f 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 = 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 =
forall a. IO a -> IO a
withSignalsBlocked forall a b. (a -> b) -> a -> b
$ forall a. FilePath -> (FilePath -> IO a) -> IO a
withNamedTemp (forall a. FilePathLike a => a -> FilePath
toFilePath p
f) 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 forall a b. (a -> b) -> a -> b
$ forall a. FilePathLike a => a -> FilePath
toFilePath p
f
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
already_exists forall a b. (a -> b) -> a -> b
$ do FileMode
mode <- FileStatus -> FileMode
fileMode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FilePath -> IO FileStatus
getFileStatus (forall a. FilePathLike a => a -> FilePath
toFilePath p
f)
FilePath -> FileMode -> IO ()
setFileMode FilePath
newf FileMode
mode
forall a. IO a -> IO a -> IO a
`catchall` forall (m :: * -> *) a. Monad m => a -> m a
return ()
FilePath -> FilePath -> IO ()
renameFile FilePath
newf (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 = forall p. FilePathLike p => p -> [ByteString] -> IO ()
gzWriteAtomicFilePSs p
f 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 =
forall a. IO a -> IO a
withSignalsBlocked forall a b. (a -> b) -> a -> b
$ forall a. FilePath -> (FilePath -> IO a) -> IO a
withNamedTemp (forall a. FilePathLike a => a -> FilePath
toFilePath p
f) forall a b. (a -> b) -> a -> b
$ \FilePath
newf -> do
(case FileType
t of
FileType
Text -> forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile
FileType
Binary -> forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile) FilePath
newf IOMode
WriteMode Handle -> IO ()
job
Bool
already_exists <- FilePath -> IO Bool
doesFileExist (forall a. FilePathLike a => a -> FilePath
toFilePath p
f)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
already_exists forall a b. (a -> b) -> a -> b
$ do FileMode
mode <- FileStatus -> FileMode
fileMode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FilePath -> IO FileStatus
getFileStatus (forall a. FilePathLike a => a -> FilePath
toFilePath p
f)
FilePath -> FileMode -> IO ()
setFileMode FilePath
newf FileMode
mode
forall a. IO a -> IO a -> IO a
`catchall` forall (m :: * -> *) a. Monad m => a -> m a
return ()
FilePath -> FilePath -> IO ()
renameFile FilePath
newf (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 = forall a. IO a -> IO a
withSignalsBlocked forall a b. (a -> b) -> a -> b
$
(case FileType
t of
FileType
Binary -> forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile
FileType
Text -> forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile) (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 forall a. Maybe a
Nothing forall a. Maybe a
Nothing
withNewDirectory :: FilePath -> IO () -> IO ()
withNewDirectory :: FilePath -> IO () -> IO ()
withNewDirectory FilePath
name IO ()
action = do
FilePath -> IO ()
createDirectory FilePath
name
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory FilePath
name IO ()
action forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \SomeException
e -> do
FilePath -> IO ()
removePathForcibly FilePath
name forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ())
forall e a. Exception e => e -> IO a
throwIO (SomeException
e :: SomeException)