{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Directory (
module Utility.Directory,
module Utility.SystemDirectory
) where
import System.IO.Error
import Control.Monad
import System.FilePath
import System.PosixCompat.Files
import Control.Applicative
import System.IO.Unsafe (unsafeInterleaveIO)
import Data.Maybe
import Prelude
#ifndef mingw32_HOST_OS
import Utility.SafeCommand
import Control.Monad.IfElse
#endif
import Utility.SystemDirectory
import Utility.Tmp
import Utility.Exception
import Utility.Monad
import Utility.Applicative
dirCruft :: FilePath -> Bool
dirCruft :: FilePath -> Bool
dirCruft FilePath
"." = Bool
True
dirCruft FilePath
".." = Bool
True
dirCruft FilePath
_ = Bool
False
dirContents :: FilePath -> IO [FilePath]
dirContents :: FilePath -> IO [FilePath]
dirContents FilePath
d = forall a b. (a -> b) -> [a] -> [b]
map (FilePath
d FilePath -> FilePath -> FilePath
</>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Bool
dirCruft) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
getDirectoryContents FilePath
d
dirContentsRecursive :: FilePath -> IO [FilePath]
dirContentsRecursive :: FilePath -> IO [FilePath]
dirContentsRecursive = (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath]
dirContentsRecursiveSkipping (forall a b. a -> b -> a
const Bool
False) Bool
True
dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath]
dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath]
dirContentsRecursiveSkipping FilePath -> Bool
skipdir Bool
followsubdirsymlinks FilePath
topdir = [FilePath] -> IO [FilePath]
go [FilePath
topdir]
where
go :: [FilePath] -> IO [FilePath]
go [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
go (FilePath
dir:[FilePath]
dirs)
| FilePath -> Bool
skipdir (FilePath -> FilePath
takeFileName FilePath
dir) = [FilePath] -> IO [FilePath]
go [FilePath]
dirs
| Bool
otherwise = forall a. IO a -> IO a
unsafeInterleaveIO forall a b. (a -> b) -> a -> b
$ do
([FilePath]
files, [FilePath]
dirs') <- [FilePath]
-> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
collect [] []
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO [] (FilePath -> IO [FilePath]
dirContents FilePath
dir)
[FilePath]
files' <- [FilePath] -> IO [FilePath]
go ([FilePath]
dirs' forall a. [a] -> [a] -> [a]
++ [FilePath]
dirs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath]
files forall a. [a] -> [a] -> [a]
++ [FilePath]
files')
collect :: [FilePath]
-> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
collect [FilePath]
files [FilePath]
dirs' [] = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
reverse [FilePath]
files, forall a. [a] -> [a]
reverse [FilePath]
dirs')
collect [FilePath]
files [FilePath]
dirs' (FilePath
entry:[FilePath]
entries)
| FilePath -> Bool
dirCruft FilePath
entry = [FilePath]
-> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
collect [FilePath]
files [FilePath]
dirs' [FilePath]
entries
| Bool
otherwise = do
let skip :: IO ([FilePath], [FilePath])
skip = [FilePath]
-> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
collect (FilePath
entryforall a. a -> [a] -> [a]
:[FilePath]
files) [FilePath]
dirs' [FilePath]
entries
let recurse :: IO ([FilePath], [FilePath])
recurse = [FilePath]
-> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
collect [FilePath]
files (FilePath
entryforall a. a -> [a] -> [a]
:[FilePath]
dirs') [FilePath]
entries
Maybe FileStatus
ms <- forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
catchMaybeIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO FileStatus
getSymbolicLinkStatus FilePath
entry
case Maybe FileStatus
ms of
(Just FileStatus
s)
| FileStatus -> Bool
isDirectory FileStatus
s -> IO ([FilePath], [FilePath])
recurse
| FileStatus -> Bool
isSymbolicLink FileStatus
s Bool -> Bool -> Bool
&& Bool
followsubdirsymlinks ->
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (FilePath -> IO Bool
doesDirectoryExist FilePath
entry)
( IO ([FilePath], [FilePath])
recurse
, IO ([FilePath], [FilePath])
skip
)
Maybe FileStatus
_ -> IO ([FilePath], [FilePath])
skip
dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
dirTreeRecursiveSkipping FilePath -> Bool
skipdir FilePath
topdir = [FilePath] -> [FilePath] -> IO [FilePath]
go [] [FilePath
topdir]
where
go :: [FilePath] -> [FilePath] -> IO [FilePath]
go [FilePath]
c [] = forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath]
c
go [FilePath]
c (FilePath
dir:[FilePath]
dirs)
| FilePath -> Bool
skipdir (FilePath -> FilePath
takeFileName FilePath
dir) = [FilePath] -> [FilePath] -> IO [FilePath]
go [FilePath]
c [FilePath]
dirs
| Bool
otherwise = forall a. IO a -> IO a
unsafeInterleaveIO forall a b. (a -> b) -> a -> b
$ do
[FilePath]
subdirs <- [FilePath] -> [FilePath] -> IO [FilePath]
go []
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (FileStatus -> Bool
isDirectory forall (f :: * -> *) a b c.
Functor f =>
(a -> b) -> (c -> f a) -> c -> f b
<$$> FilePath -> IO FileStatus
getSymbolicLinkStatus)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO [] (FilePath -> IO [FilePath]
dirContents FilePath
dir)
[FilePath] -> [FilePath] -> IO [FilePath]
go ([FilePath]
subdirsforall a. [a] -> [a] -> [a]
++FilePath
dirforall a. a -> [a] -> [a]
:[FilePath]
c) [FilePath]
dirs
moveFile :: FilePath -> FilePath -> IO ()
moveFile :: FilePath -> FilePath -> IO ()
moveFile FilePath
src FilePath
dest = forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO (FilePath -> FilePath -> IO ()
rename FilePath
src FilePath
dest) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {b}. Either IOException b -> IO ()
onrename
where
onrename :: Either IOException b -> IO ()
onrename (Right b
_) = forall (m :: * -> *). Monad m => m ()
noop
onrename (Left IOException
e)
| IOException -> Bool
isPermissionError IOException
e = forall {a}. IO a
rethrow
| IOException -> Bool
isDoesNotExistError IOException
e = forall {a}. IO a
rethrow
| Bool
otherwise = forall (m :: * -> *) v.
(MonadMask m, MonadIO m) =>
(FilePath -> v -> m ()) -> FilePath -> v -> m ()
viaTmp forall {p}. FilePath -> p -> IO ()
mv FilePath
dest FilePath
""
where
rethrow :: IO a
rethrow = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM IOException
e
mv :: FilePath -> p -> IO ()
mv FilePath
tmp p
_ = do
#ifndef mingw32_HOST_OS
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (FilePath -> IO Bool
isdir FilePath
dest) forall {a}. IO a
rethrow
Bool
ok <- FilePath -> [CommandParam] -> IO Bool
boolSystem FilePath
"mv" [FilePath -> CommandParam
Param FilePath
"-f", FilePath -> CommandParam
Param FilePath
src, FilePath -> CommandParam
Param FilePath
tmp]
let e' :: IOException
e' = IOException
e
#else
r <- tryIO $ copyFile src tmp
let (ok, e') = case r of
Left err -> (False, err)
Right _ -> (True, e)
#endif
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok forall a b. (a -> b) -> a -> b
$ do
Either IOException ()
_ <- forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
tmp
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM IOException
e'
#ifndef mingw32_HOST_OS
isdir :: FilePath -> IO Bool
isdir FilePath
f = do
Either IOException FileStatus
r <- forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO FileStatus
getFileStatus FilePath
f
case Either IOException FileStatus
r of
(Left IOException
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
(Right FileStatus
s) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FileStatus -> Bool
isDirectory FileStatus
s
#endif
nukeFile :: FilePath -> IO ()
nukeFile :: FilePath -> IO ()
nukeFile FilePath
file = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
tryWhenExists IO ()
go
where
#ifndef mingw32_HOST_OS
go :: IO ()
go = FilePath -> IO ()
removeLink FilePath
file
#else
go = removeFile file
#endif