{-# 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 = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
d FilePath -> FilePath -> FilePath
</>) ([FilePath] -> [FilePath])
-> ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Bool
dirCruft) ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
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 (Bool -> FilePath -> Bool
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 [] = [FilePath] -> IO [FilePath]
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 = IO [FilePath] -> IO [FilePath]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ do
([FilePath]
files, [FilePath]
dirs') <- [FilePath]
-> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
collect [] []
([FilePath] -> IO ([FilePath], [FilePath]))
-> IO [FilePath] -> IO ([FilePath], [FilePath])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [FilePath] -> IO [FilePath] -> IO [FilePath]
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' [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
dirs)
[FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath]
files [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
files')
collect :: [FilePath]
-> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
collect [FilePath]
files [FilePath]
dirs' [] = ([FilePath], [FilePath]) -> IO ([FilePath], [FilePath])
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse [FilePath]
files, [FilePath] -> [FilePath]
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
entryFilePath -> [FilePath] -> [FilePath]
forall 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
entryFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
dirs') [FilePath]
entries
Maybe FileStatus
ms <- IO FileStatus -> IO (Maybe FileStatus)
forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
catchMaybeIO (IO FileStatus -> IO (Maybe FileStatus))
-> IO FileStatus -> IO (Maybe FileStatus)
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 ->
IO Bool
-> (IO ([FilePath], [FilePath]), IO ([FilePath], [FilePath]))
-> IO ([FilePath], [FilePath])
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 [] = [FilePath] -> IO [FilePath]
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 = IO [FilePath] -> IO [FilePath]
forall a. IO a -> IO a
unsafeInterleaveIO (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ do
[FilePath]
subdirs <- [FilePath] -> [FilePath] -> IO [FilePath]
go []
([FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (FileStatus -> Bool
isDirectory (FileStatus -> Bool)
-> (FilePath -> IO FileStatus) -> FilePath -> IO Bool
forall (f :: * -> *) a b c.
Functor f =>
(a -> b) -> (c -> f a) -> c -> f b
<$$> FilePath -> IO FileStatus
getSymbolicLinkStatus)
([FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [FilePath] -> IO [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO [] (FilePath -> IO [FilePath]
dirContents FilePath
dir)
[FilePath] -> [FilePath] -> IO [FilePath]
go ([FilePath]
subdirs[FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++FilePath
dirFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
c) [FilePath]
dirs
moveFile :: FilePath -> FilePath -> IO ()
moveFile :: FilePath -> FilePath -> IO ()
moveFile FilePath
src FilePath
dest = IO () -> IO (Either IOException ())
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO (FilePath -> FilePath -> IO ()
rename FilePath
src FilePath
dest) IO (Either IOException ())
-> (Either IOException () -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either IOException () -> IO ()
forall b. Either IOException b -> IO ()
onrename
where
onrename :: Either IOException b -> IO ()
onrename (Right b
_) = IO ()
forall (m :: * -> *). Monad m => m ()
noop
onrename (Left IOException
e)
| IOException -> Bool
isPermissionError IOException
e = IO ()
forall a. IO a
rethrow
| IOException -> Bool
isDoesNotExistError IOException
e = IO ()
forall a. IO a
rethrow
| Bool
otherwise = (FilePath -> FilePath -> IO ()) -> FilePath -> FilePath -> IO ()
forall (m :: * -> *) v.
(MonadMask m, MonadIO m) =>
(FilePath -> v -> m ()) -> FilePath -> v -> m ()
viaTmp FilePath -> FilePath -> IO ()
forall p. FilePath -> p -> IO ()
mv FilePath
dest FilePath
""
where
rethrow :: IO a
rethrow = IOException -> IO a
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
IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (FilePath -> IO Bool
isdir FilePath
dest) IO ()
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
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Either IOException ()
_ <- IO () -> IO (Either IOException ())
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
tmp
IOException -> IO ()
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 <- IO FileStatus -> IO (Either IOException FileStatus)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO (IO FileStatus -> IO (Either IOException FileStatus))
-> IO FileStatus -> IO (Either IOException FileStatus)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FileStatus
getFileStatus FilePath
f
case Either IOException FileStatus
r of
(Left IOException
_) -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
(Right FileStatus
s) -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ FileStatus -> Bool
isDirectory FileStatus
s
#endif
nukeFile :: FilePath -> IO ()
nukeFile :: FilePath -> IO ()
nukeFile FilePath
file = IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Maybe ())
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