module Darcs.Util.Lock
( withLock
, withLockCanFail
, environmentHelpLocks
, withTemp
, withOpenTemp
, withStdoutTemp
, withTempDir
, withPermDir
, withDelayedDir
, withNamedTemp
, writeBinFile
, writeTextFile
, writeDocBinFile
, appendBinFile
, appendTextFile
, appendDocBinFile
, readBinFile
, readTextFile
, readDocBinFile
, writeAtomicFilePS
, gzWriteAtomicFilePS
, gzWriteAtomicFilePSs
, gzWriteDocFile
, rmRecursive
, removeFileMayNotExist
, canonFilename
, maybeRelink
, tempdirLoc
, environmentHelpTmpdir
, environmentHelpKeepTmpdir
, addToErrorLoc
, withNewDirectory
) where
import Prelude ()
import Darcs.Prelude
import Data.List ( inits )
import Data.Maybe ( fromJust, isJust, listToMaybe )
import System.Exit ( exitWith, ExitCode(..) )
import System.IO
( withFile, withBinaryFile, openBinaryTempFile
, hClose, Handle, hPutStr, hSetEncoding
, IOMode(WriteMode, AppendMode), hFlush, stdout
)
import System.IO.Error
( isAlreadyExistsError
, annotateIOError
, catchIOError
)
import Control.Exception
( IOException
, bracket
, throwIO
, catch
, try
, SomeException
)
import System.Directory
( removeFile
, removeDirectory
, doesFileExist
, doesDirectoryExist
, getDirectoryContents
, createDirectory
, getTemporaryDirectory
, removeDirectoryRecursive
)
import System.FilePath.Posix ( splitDirectories )
import System.Environment ( lookupEnv )
import Control.Concurrent ( threadDelay )
import Control.Monad ( unless, when, liftM )
import System.Posix.Files ( fileMode, getFileStatus, setFileMode )
import GHC.IO.Encoding ( getFileSystemEncoding )
import Darcs.Util.URL ( isRelative )
import Darcs.Util.Exception
( firstJustIO
, catchall
)
import Darcs.Util.File ( withCurrentDirectory
, doesDirectoryReallyExist, removeFileMayNotExist )
import Darcs.Util.Path ( AbsolutePath, FilePathLike, toFilePath,
getCurrentDirectory, setCurrentDirectory )
import Darcs.Util.ByteString ( gzWriteFilePSs )
import qualified Data.ByteString as B (null, readFile, hPut, ByteString)
import Darcs.Util.SignalHandler ( withSignalsBlocked )
import Darcs.Util.Printer ( Doc, hPutDoc, packedString, empty, renderPSs )
import Darcs.Util.AtExit ( atexit )
import Darcs.Util.Global ( darcsdir )
import Darcs.Util.Workaround ( renameFile )
import Darcs.Util.Compat
( mkStdoutTemp
, canonFilename
, maybeRelink
, atomicCreate
, sloppyAtomicCreate
)
import Darcs.Util.Progress ( debugMessage )
import Darcs.Util.Prompt ( askUser )
withLock :: String -> IO a -> IO a
withLock :: String -> IO a -> IO a
withLock s :: String
s job :: IO a
job = IO String -> (String -> IO ()) -> (String -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> Int -> IO String
getlock String
s 30) String -> IO ()
releaseLock (\_ -> IO a
job)
releaseLock :: String -> IO ()
releaseLock :: String -> IO ()
releaseLock = String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist
withLockCanFail :: String -> IO a -> IO (Either () a)
withLockCanFail :: String -> IO a -> IO (Either () a)
withLockCanFail s :: String
s job :: IO a
job =
IO Bool
-> (Bool -> IO ())
-> (Bool -> IO (Either () a))
-> IO (Either () a)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> IO Bool
forall p. FilePathLike p => p -> IO Bool
takeLock String
s)
(\l :: Bool
l -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
l (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
releaseLock String
s)
(\l :: Bool
l -> if Bool
l then (a -> Either () a) -> IO a -> IO (Either () a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Either () a
forall a b. b -> Either a b
Right IO a
job
else Either () a -> IO (Either () a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either () a -> IO (Either () a))
-> Either () a -> IO (Either () a)
forall a b. (a -> b) -> a -> b
$ () -> Either () a
forall a b. a -> Either a b
Left ())
getlock :: String -> Int -> IO String
getlock :: String -> Int -> IO String
getlock l :: String
l 0 = do String
yorn <- String -> IO String
askUser (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ "Couldn't get lock "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
lString -> String -> String
forall a. [a] -> [a] -> [a]
++". Abort (yes or anything else)? "
case String
yorn of
('y':_) -> ExitCode -> IO String
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO String) -> ExitCode -> IO String
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure 1
_ -> String -> Int -> IO String
getlock String
l 30
getlock lbad :: String
lbad tl :: Int
tl = do String
l <- String -> IO String
canonFilename String
lbad
Bool
gotit <- String -> IO Bool
forall p. FilePathLike p => p -> IO Bool
takeLock String
l
if Bool
gotit then String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
l
else do String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Waiting for lock "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
l
Handle -> IO ()
hFlush Handle
stdout
Int -> IO ()
threadDelay 2000000
String -> Int -> IO String
getlock String
l (Int
tl Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
takeLock :: FilePathLike p => p -> IO Bool
takeLock :: p -> IO Bool
takeLock fp :: p
fp =
do String -> IO ()
atomicCreate (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ p -> String
forall a. FilePathLike a => a -> String
toFilePath p
fp
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
IO Bool -> (IOError -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \e :: IOError
e -> if IOError -> Bool
isAlreadyExistsError IOError
e
then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else do AbsolutePath
pwd <- IO AbsolutePath
getCurrentDirectory
IOError -> IO Bool
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO Bool) -> IOError -> IO Bool
forall a b. (a -> b) -> a -> b
$ IOError -> String -> IOError
addToErrorLoc IOError
e
("takeLock "String -> String -> String
forall a. [a] -> [a] -> [a]
++p -> String
forall a. FilePathLike a => a -> String
toFilePath p
fpString -> String -> String
forall a. [a] -> [a] -> [a]
++" in "String -> String -> String
forall a. [a] -> [a] -> [a]
++AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath AbsolutePath
pwd)
takeFile :: FilePath -> IO Bool
takeFile :: String -> IO Bool
takeFile fp :: String
fp =
do String -> IO ()
sloppyAtomicCreate String
fp
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
IO Bool -> (IOError -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \e :: IOError
e -> if IOError -> Bool
isAlreadyExistsError IOError
e
then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else do AbsolutePath
pwd <- IO AbsolutePath
getCurrentDirectory
IOError -> IO Bool
forall e a. Exception e => e -> IO a
throwIO (IOError -> IO Bool) -> IOError -> IO Bool
forall a b. (a -> b) -> a -> b
$ IOError -> String -> IOError
addToErrorLoc IOError
e
("takeFile "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
fpString -> String -> String
forall a. [a] -> [a] -> [a]
++" in "String -> String -> String
forall a. [a] -> [a] -> [a]
++AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath AbsolutePath
pwd)
environmentHelpLocks :: ([String],[String])
environmentHelpLocks :: ([String], [String])
environmentHelpLocks = (["DARCS_SLOPPY_LOCKS"],[
"If on some filesystems you get an error of the kind:",
"",
" darcs: takeLock [...]: atomic_create [...]: unsupported operation",
"",
"you may want to try to export DARCS_SLOPPY_LOCKS=True."])
withTemp :: (FilePath -> IO a) -> IO a
withTemp :: (String -> IO a) -> IO a
withTemp = IO String -> (String -> IO ()) -> (String -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO String
get_empty_file String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist
where get_empty_file :: IO String
get_empty_file = do (f :: String
f,h :: Handle
h) <- String -> String -> IO (String, Handle)
openBinaryTempFile "." "darcs"
Handle -> IO ()
hClose Handle
h
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
f
withOpenTemp :: ((Handle, FilePath) -> IO a) -> IO a
withOpenTemp :: ((Handle, String) -> IO a) -> IO a
withOpenTemp = IO (Handle, String)
-> ((Handle, String) -> IO ())
-> ((Handle, String) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Handle, String)
get_empty_file (Handle, String) -> IO ()
forall p. FilePathLike p => (Handle, p) -> IO ()
cleanup
where cleanup :: (Handle, p) -> IO ()
cleanup (h :: Handle
h,f :: p
f) = do Either SomeException ()
_ <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (Handle -> IO ()
hClose Handle
h) :: IO (Either SomeException ())
p -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist p
f
get_empty_file :: IO (Handle, String)
get_empty_file = (String, Handle) -> (Handle, String)
forall b a. (b, a) -> (a, b)
invert ((String, Handle) -> (Handle, String))
-> IO (String, Handle) -> IO (Handle, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> String -> IO (String, Handle)
openBinaryTempFile "." "darcs"
invert :: (b, a) -> (a, b)
invert (a :: b
a,b :: a
b) = (a
b,b
a)
withStdoutTemp :: (FilePath -> IO a) -> IO a
withStdoutTemp :: (String -> IO a) -> IO a
withStdoutTemp = IO String -> (String -> IO ()) -> (String -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> IO String
mkStdoutTemp "stdout_") String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist
tempdirLoc :: IO FilePath
tempdirLoc :: IO String
tempdirLoc = (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (IO (Maybe String) -> IO String) -> IO (Maybe String) -> IO String
forall a b. (a -> b) -> a -> b
$
[IO (Maybe String)] -> IO (Maybe String)
forall a. [IO (Maybe a)] -> IO (Maybe a)
firstJustIO [ (String -> Maybe String) -> IO String -> IO (Maybe String)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> (String -> String) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall a. [a] -> a
head ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words) (String -> IO String
readFile (String
darcsdirString -> String -> String
forall a. [a] -> [a] -> [a]
++"/prefs/tmpdir")) IO (Maybe String)
-> (Maybe String -> IO (Maybe String)) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe String -> IO (Maybe String)
chkdir,
String -> IO (Maybe String)
lookupEnv "DARCS_TMPDIR" IO (Maybe String)
-> (Maybe String -> IO (Maybe String)) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe String -> IO (Maybe String)
chkdir,
IO String
getTemporaryDirectory IO String -> (String -> IO (Maybe String)) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe String -> IO (Maybe String)
chkdir (Maybe String -> IO (Maybe String))
-> (String -> Maybe String) -> String -> IO (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just,
IO (Maybe String)
getCurrentDirectorySansDarcs,
Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just "."
]
where chkdir :: Maybe String -> IO (Maybe String)
chkdir Nothing = Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
chkdir (Just d :: String
d) = (Bool -> Maybe String) -> IO Bool -> IO (Maybe String)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\e :: Bool
e -> if Bool
e then String -> Maybe String
forall a. a -> Maybe a
Just (String
dString -> String -> String
forall a. [a] -> [a] -> [a]
++"/") else Maybe String
forall a. Maybe a
Nothing) (IO Bool -> IO (Maybe String)) -> IO Bool -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
d
environmentHelpTmpdir :: ([String], [String])
environmentHelpTmpdir :: ([String], [String])
environmentHelpTmpdir = (["DARCS_TMPDIR", "TMPDIR"], [
"Darcs often creates temporary directories. For example, the `darcs",
"diff` command creates two for the working trees to be diffed. By",
"default temporary directories are created in /tmp, or if that doesn't",
"exist, in _darcs (within the current repo). This can be overridden by",
"specifying some other directory in the file _darcs/prefs/tmpdir or the",
"environment variable $DARCS_TMPDIR or $TMPDIR."])
getCurrentDirectorySansDarcs :: IO (Maybe FilePath)
getCurrentDirectorySansDarcs :: IO (Maybe String)
getCurrentDirectorySansDarcs = do
AbsolutePath
c <- IO AbsolutePath
getCurrentDirectory
Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe ([String] -> Maybe String) -> [String] -> Maybe String
forall a b. (a -> b) -> a -> b
$ Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop 5 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile String -> Bool
no_darcs ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
forall a. [a] -> [[a]]
inits (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath AbsolutePath
c
where no_darcs :: String -> Bool
no_darcs x :: String
x = String
darcsdir String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String -> [String]
splitDirectories String
x
data WithDirKind = Perm | Temp | Delayed
withDir :: WithDirKind
-> FilePath
-> (AbsolutePath -> IO a) -> IO a
withDir :: WithDirKind -> String -> (AbsolutePath -> IO a) -> IO a
withDir _ "" _ = String -> IO a
forall a. String -> a
bug "withDir called with empty directory name"
withDir kind :: WithDirKind
kind absoluteOrRelativeName :: String
absoluteOrRelativeName job :: AbsolutePath -> IO a
job = do
String
absoluteName <- if String -> Bool
isRelative String
absoluteOrRelativeName
then (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
absoluteOrRelativeName) IO String
tempdirLoc
else String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
absoluteOrRelativeName
AbsolutePath
formerdir <- IO AbsolutePath
getCurrentDirectory
IO AbsolutePath
-> (AbsolutePath -> IO ()) -> (AbsolutePath -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> Int -> IO AbsolutePath
createDir String
absoluteName 0)
(\dir :: AbsolutePath
dir -> do AbsolutePath -> IO ()
forall p. FilePathLike p => p -> IO ()
setCurrentDirectory AbsolutePath
formerdir
Bool
k <- IO Bool
keepTempDir
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
k (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ case WithDirKind
kind of
Perm -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Temp -> String -> IO ()
rmRecursive (AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath AbsolutePath
dir)
Delayed -> IO () -> IO ()
atexit (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
rmRecursive (AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath AbsolutePath
dir))
AbsolutePath -> IO a
job
where newname :: String -> a -> String
newname name :: String
name 0 = String
name
newname name :: String
name n :: a
n = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ "-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n
createDir :: FilePath -> Int -> IO AbsolutePath
createDir :: String -> Int -> IO AbsolutePath
createDir name :: String
name n :: Int
n
= do String -> IO ()
createDirectory (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Int -> String
forall a. (Eq a, Num a, Show a) => String -> a -> String
newname String
name Int
n
String -> IO ()
forall p. FilePathLike p => p -> IO ()
setCurrentDirectory (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Int -> String
forall a. (Eq a, Num a, Show a) => String -> a -> String
newname String
name Int
n
IO AbsolutePath
getCurrentDirectory
IO AbsolutePath -> (IOError -> IO AbsolutePath) -> IO AbsolutePath
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\e :: IOError
e -> if IOError -> Bool
isAlreadyExistsError IOError
e
then String -> Int -> IO AbsolutePath
createDir String
name (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)
else IOError -> IO AbsolutePath
forall e a. Exception e => e -> IO a
throwIO IOError
e)
keepTempDir :: IO Bool
keepTempDir = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO (Maybe String)
lookupEnv "DARCS_KEEP_TMPDIR"
environmentHelpKeepTmpdir :: ([String], [String])
environmentHelpKeepTmpdir :: ([String], [String])
environmentHelpKeepTmpdir = (["DARCS_KEEP_TMPDIR"],[
"If the environment variable DARCS_KEEP_TMPDIR is defined, darcs will",
"not remove the temporary directories it creates. This is intended",
"primarily for debugging Darcs itself, but it can also be useful, for",
"example, to determine why your test preference (see `darcs setpref`)",
"is failing when you run `darcs record`, but working when run manually."])
withPermDir :: FilePath -> (AbsolutePath -> IO a) -> IO a
withPermDir :: String -> (AbsolutePath -> IO a) -> IO a
withPermDir = WithDirKind -> String -> (AbsolutePath -> IO a) -> IO a
forall a. WithDirKind -> String -> (AbsolutePath -> IO a) -> IO a
withDir WithDirKind
Perm
withTempDir :: FilePath -> (AbsolutePath -> IO a) -> IO a
withTempDir :: String -> (AbsolutePath -> IO a) -> IO a
withTempDir = WithDirKind -> String -> (AbsolutePath -> IO a) -> IO a
forall a. WithDirKind -> String -> (AbsolutePath -> IO a) -> IO a
withDir WithDirKind
Temp
withDelayedDir :: FilePath -> (AbsolutePath -> IO a) -> IO a
withDelayedDir :: String -> (AbsolutePath -> IO a) -> IO a
withDelayedDir = WithDirKind -> String -> (AbsolutePath -> IO a) -> IO a
forall a. WithDirKind -> String -> (AbsolutePath -> IO a) -> IO a
withDir WithDirKind
Delayed
rmRecursive :: FilePath -> IO ()
rmRecursive :: String -> IO ()
rmRecursive d :: String
d =
do Bool
isd <- String -> IO Bool
doesDirectoryReallyExist String
d
if Bool -> Bool
not Bool
isd
then String -> IO ()
removeFile String
d
else do [String]
conts <- IO [String]
actual_dir_contents
String -> IO () -> IO ()
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory String
d (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
(String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
rmRecursive [String]
conts
String -> IO ()
removeDirectory String
d
where actual_dir_contents :: IO [String]
actual_dir_contents =
do [String]
c <- String -> IO [String]
getDirectoryContents String
d
[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/=".") ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/="..") [String]
c
worldReadableTemp :: FilePath -> IO FilePath
worldReadableTemp :: String -> IO String
worldReadableTemp f :: String
f = Int -> IO String
wrt 0
where wrt :: Int -> IO FilePath
wrt :: Int -> IO String
wrt 100 = String -> IO String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ "Failure creating temp named "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
f
wrt n :: Int
n = let f_new :: String
f_new = String
fString -> String -> String
forall a. [a] -> [a] -> [a]
++"-"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
n
in do Bool
ok <- String -> IO Bool
takeFile String
f_new
if Bool
ok then String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
f_new
else Int -> IO String
wrt (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1)
withNamedTemp :: FilePath -> (FilePath -> IO a) -> IO a
withNamedTemp :: String -> (String -> IO a) -> IO a
withNamedTemp n :: String
n f :: String -> IO a
f = do
String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "withNamedTemp: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
n
IO String -> (String -> IO ()) -> (String -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> IO String
worldReadableTemp String
n) String -> IO ()
forall p. FilePathLike p => p -> IO ()
removeFileMayNotExist String -> IO a
f
readBinFile :: FilePathLike p => p -> IO B.ByteString
readBinFile :: p -> IO ByteString
readBinFile = String -> IO ByteString
B.readFile (String -> IO ByteString) -> (p -> String) -> p -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> String
forall a. FilePathLike a => a -> String
toFilePath
readTextFile :: FilePathLike p => p -> IO [String]
readTextFile :: p -> IO [String]
readTextFile f :: p
f = do
[String]
result <- String -> [String]
lines (String -> [String]) -> IO String -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile (p -> String
forall a. FilePathLike a => a -> String
toFilePath p
f)
case [String]
result of
[] -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
result
xs :: [String]
xs -> [String] -> String
forall a. [a] -> a
last [String]
xs String -> IO [String] -> IO [String]
forall a b. a -> b -> b
`seq` [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
result
readDocBinFile :: FilePathLike p => p -> IO Doc
readDocBinFile :: p -> IO Doc
readDocBinFile fp :: p
fp = do ByteString
ps <- String -> IO ByteString
B.readFile (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ p -> String
forall a. FilePathLike a => a -> String
toFilePath p
fp
Doc -> IO Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> IO Doc) -> Doc -> IO Doc
forall a b. (a -> b) -> a -> b
$ if ByteString -> Bool
B.null ByteString
ps then Doc
empty else ByteString -> Doc
packedString ByteString
ps
appendBinFile :: FilePathLike p => p -> B.ByteString -> IO ()
appendBinFile :: p -> ByteString -> IO ()
appendBinFile f :: p
f s :: ByteString
s = FileType -> p -> (Handle -> IO ()) -> IO ()
forall p.
FilePathLike p =>
FileType -> p -> (Handle -> IO ()) -> IO ()
appendToFile FileType
Binary p
f ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> Handle -> ByteString -> IO ()
B.hPut Handle
h ByteString
s
appendTextFile :: FilePathLike p => p -> String -> IO ()
appendTextFile :: p -> String -> IO ()
appendTextFile f :: p
f s :: String
s = FileType -> p -> (Handle -> IO ()) -> IO ()
forall p.
FilePathLike p =>
FileType -> p -> (Handle -> IO ()) -> IO ()
appendToFile FileType
Text p
f ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> Handle -> String -> IO ()
hPutStr Handle
h String
s
appendDocBinFile :: FilePathLike p => p -> Doc -> IO ()
appendDocBinFile :: p -> Doc -> IO ()
appendDocBinFile f :: p
f d :: Doc
d = FileType -> p -> (Handle -> IO ()) -> IO ()
forall p.
FilePathLike p =>
FileType -> p -> (Handle -> IO ()) -> IO ()
appendToFile FileType
Binary p
f ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> Handle -> Doc -> IO ()
hPutDoc Handle
h Doc
d
data FileType = Text | Binary
writeBinFile :: FilePathLike p => p -> B.ByteString -> IO ()
writeBinFile :: p -> ByteString -> IO ()
writeBinFile f :: p
f s :: ByteString
s = FileType -> p -> (Handle -> IO ()) -> IO ()
forall p.
FilePathLike p =>
FileType -> p -> (Handle -> IO ()) -> IO ()
writeToFile FileType
Binary p
f ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> Handle -> ByteString -> IO ()
B.hPut Handle
h ByteString
s
writeTextFile :: FilePathLike p => p -> String -> IO ()
writeTextFile :: p -> String -> IO ()
writeTextFile f :: p
f s :: String
s = FileType -> p -> (Handle -> IO ()) -> IO ()
forall p.
FilePathLike p =>
FileType -> p -> (Handle -> IO ()) -> IO ()
writeToFile FileType
Text p
f ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> do
IO TextEncoding
getFileSystemEncoding IO TextEncoding -> (TextEncoding -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h
Handle -> String -> IO ()
hPutStr Handle
h String
s
writeDocBinFile :: FilePathLike p => p -> Doc -> IO ()
writeDocBinFile :: p -> Doc -> IO ()
writeDocBinFile f :: p
f d :: Doc
d = FileType -> p -> (Handle -> IO ()) -> IO ()
forall p.
FilePathLike p =>
FileType -> p -> (Handle -> IO ()) -> IO ()
writeToFile FileType
Binary p
f ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> Handle -> Doc -> IO ()
hPutDoc Handle
h Doc
d
writeAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO ()
writeAtomicFilePS :: p -> ByteString -> IO ()
writeAtomicFilePS f :: p
f ps :: ByteString
ps = FileType -> p -> (Handle -> IO ()) -> IO ()
forall p.
FilePathLike p =>
FileType -> p -> (Handle -> IO ()) -> IO ()
writeToFile FileType
Binary p
f ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> Handle -> ByteString -> IO ()
B.hPut Handle
h ByteString
ps
gzWriteAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO ()
gzWriteAtomicFilePS :: p -> ByteString -> IO ()
gzWriteAtomicFilePS f :: p
f ps :: ByteString
ps = p -> [ByteString] -> IO ()
forall p. FilePathLike p => p -> [ByteString] -> IO ()
gzWriteAtomicFilePSs p
f [ByteString
ps]
gzWriteAtomicFilePSs :: FilePathLike p => p -> [B.ByteString] -> IO ()
gzWriteAtomicFilePSs :: p -> [ByteString] -> IO ()
gzWriteAtomicFilePSs f :: p
f pss :: [ByteString]
pss =
IO () -> IO ()
forall a. IO a -> IO a
withSignalsBlocked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> (String -> IO ()) -> IO ()
forall a. String -> (String -> IO a) -> IO a
withNamedTemp (p -> String
forall a. FilePathLike a => a -> String
toFilePath p
f) ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \newf :: String
newf -> do
String -> [ByteString] -> IO ()
gzWriteFilePSs String
newf [ByteString]
pss
Bool
already_exists <- String -> IO Bool
doesFileExist (String -> IO Bool) -> String -> IO Bool
forall a b. (a -> b) -> a -> b
$ p -> String
forall a. FilePathLike a => a -> String
toFilePath p
f
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
already_exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do FileMode
mode <- FileStatus -> FileMode
fileMode (FileStatus -> FileMode) -> IO FileStatus -> IO FileMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO FileStatus
getFileStatus (p -> String
forall a. FilePathLike a => a -> String
toFilePath p
f)
String -> FileMode -> IO ()
setFileMode String
newf FileMode
mode
IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
String -> String -> IO ()
renameFile String
newf (p -> String
forall a. FilePathLike a => a -> String
toFilePath p
f)
gzWriteDocFile :: FilePathLike p => p -> Doc -> IO ()
gzWriteDocFile :: p -> Doc -> IO ()
gzWriteDocFile f :: p
f d :: Doc
d = p -> [ByteString] -> IO ()
forall p. FilePathLike p => p -> [ByteString] -> IO ()
gzWriteAtomicFilePSs p
f ([ByteString] -> IO ()) -> [ByteString] -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> [ByteString]
renderPSs Doc
d
writeToFile :: FilePathLike p => FileType -> p -> (Handle -> IO ()) -> IO ()
writeToFile :: FileType -> p -> (Handle -> IO ()) -> IO ()
writeToFile t :: FileType
t f :: p
f job :: Handle -> IO ()
job =
IO () -> IO ()
forall a. IO a -> IO a
withSignalsBlocked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> (String -> IO ()) -> IO ()
forall a. String -> (String -> IO a) -> IO a
withNamedTemp (p -> String
forall a. FilePathLike a => a -> String
toFilePath p
f) ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \newf :: String
newf -> do
(case FileType
t of
Text -> String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile
Binary -> String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile) String
newf IOMode
WriteMode Handle -> IO ()
job
Bool
already_exists <- String -> IO Bool
doesFileExist (p -> String
forall a. FilePathLike a => a -> String
toFilePath p
f)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
already_exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do FileMode
mode <- FileStatus -> FileMode
fileMode (FileStatus -> FileMode) -> IO FileStatus -> IO FileMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO FileStatus
getFileStatus (p -> String
forall a. FilePathLike a => a -> String
toFilePath p
f)
String -> FileMode -> IO ()
setFileMode String
newf FileMode
mode
IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
String -> String -> IO ()
renameFile String
newf (p -> String
forall a. FilePathLike a => a -> String
toFilePath p
f)
appendToFile :: FilePathLike p => FileType -> p -> (Handle -> IO ()) -> IO ()
appendToFile :: FileType -> p -> (Handle -> IO ()) -> IO ()
appendToFile t :: FileType
t f :: p
f job :: Handle -> IO ()
job = IO () -> IO ()
forall a. IO a -> IO a
withSignalsBlocked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
(case FileType
t of
Binary -> String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile
Text -> String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile) (p -> String
forall a. FilePathLike a => a -> String
toFilePath p
f) IOMode
AppendMode Handle -> IO ()
job
addToErrorLoc :: IOException
-> String
-> IOException
addToErrorLoc :: IOError -> String -> IOError
addToErrorLoc ioe :: IOError
ioe s :: String
s = IOError -> String -> Maybe Handle -> Maybe String -> IOError
annotateIOError IOError
ioe String
s Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
withNewDirectory :: FilePath -> IO () -> IO ()
withNewDirectory :: String -> IO () -> IO ()
withNewDirectory name :: String
name action :: IO ()
action = do
String -> IO ()
createDirectory String
name
String -> IO () -> IO ()
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory String
name IO ()
action IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \e :: SomeException
e -> do
String -> IO ()
removeDirectoryRecursive String
name IO () -> (IOError -> IO ()) -> IO ()
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` (IO () -> IOError -> IO ()
forall a b. a -> b -> a
const (IO () -> IOError -> IO ()) -> IO () -> IOError -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (SomeException
e :: SomeException)