{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}
module System.Unix.Directory
( find
, removeRecursiveSafely
, unmountRecursiveSafely
, renameFileWithBackup
, withWorkingDirectory
, withTemporaryDirectory
, mkdtemp
)
where
import Control.Exception
import Data.List (isSuffixOf)
import System.Process
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import System.Posix.Files
import System.Posix.Types
import Foreign.C
find :: FilePath -> IO [(FilePath, FileStatus)]
find :: FilePath -> IO [(FilePath, FileStatus)]
find FilePath
path =
do
FileStatus
status <- FilePath -> IO FileStatus
getSymbolicLinkStatus FilePath
path
case FileStatus -> Bool
isDirectory FileStatus
status of
Bool
True ->
do
[(FilePath, FileStatus)]
subs <- FilePath -> IO [FilePath]
getDirectoryContents FilePath
path forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (FilePath
path 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
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [FilePath
".", FilePath
".."]) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO [(FilePath, FileStatus)]
find forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (FilePath
path, FileStatus
status) forall a. a -> [a] -> [a]
: [(FilePath, FileStatus)]
subs
Bool
False ->
forall (m :: * -> *) a. Monad m => a -> m a
return [(FilePath
path, FileStatus
status)]
traverse :: FilePath -> (FilePath -> IO ()) -> (FilePath -> IO ()) -> (FilePath -> IO ()) -> IO ()
traverse :: FilePath
-> (FilePath -> IO ())
-> (FilePath -> IO ())
-> (FilePath -> IO ())
-> IO ()
traverse FilePath
path FilePath -> IO ()
f FilePath -> IO ()
d FilePath -> IO ()
m =
do
Either SomeException FileStatus
result <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ FilePath -> IO FileStatus
getSymbolicLinkStatus FilePath
path
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ (SomeException
_ :: SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()) (FilePath -> FileStatus -> IO ()
doPath FilePath
path) Either SomeException FileStatus
result
where
doPath :: FilePath -> FileStatus -> IO ()
doPath FilePath
path FileStatus
status =
if FileStatus -> Bool
isDirectory FileStatus
status then
do
FilePath -> IO [FilePath]
getDirectoryContents FilePath
path forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int -> FileStatus -> FilePath -> FilePath -> IO ()
doDirectoryFile Int
1 FileStatus
status FilePath
path)
FilePath -> IO ()
d FilePath
path else
FilePath -> IO ()
f FilePath
path
doDirectoryFile :: Int -> FileStatus -> FilePath -> String -> IO ()
doDirectoryFile :: Int -> FileStatus -> FilePath -> FilePath -> IO ()
doDirectoryFile Int
_ FileStatus
_ FilePath
_ FilePath
"." = forall (m :: * -> *) a. Monad m => a -> m a
return ()
doDirectoryFile Int
_ FileStatus
_ FilePath
_ FilePath
".." = forall (m :: * -> *) a. Monad m => a -> m a
return ()
doDirectoryFile Int
tries FileStatus
_ FilePath
_ FilePath
_ | Int
tries forall a. Ord a => a -> a -> Bool
>= Int
5 =
forall a. HasCallStack => FilePath -> a
error (FilePath
"Couldn't unmount file system on " forall a. [a] -> [a] -> [a]
++ FilePath
path)
doDirectoryFile Int
tries FileStatus
status FilePath
path FilePath
name =
do
let child :: FilePath
child = FilePath
path FilePath -> FilePath -> FilePath
</> FilePath
name
FileStatus
childStatus <- FilePath -> IO FileStatus
getSymbolicLinkStatus FilePath
child
if FileStatus -> DeviceID
deviceID FileStatus
status forall a. Eq a => a -> a -> Bool
== FileStatus -> DeviceID
deviceID FileStatus
childStatus then
FilePath -> FileStatus -> IO ()
doPath FilePath
child FileStatus
childStatus else
do
if Int
tries forall a. Ord a => a -> a -> Bool
> Int
1 then Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath
"try " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Int
tries forall a. [a] -> [a] -> [a]
++ FilePath
":") else forall (m :: * -> *) a. Monad m => a -> m a
return ()
FilePath -> IO ()
m FilePath
child
Int -> FileStatus -> FilePath -> FilePath -> IO ()
doDirectoryFile (Int
tries forall a. Num a => a -> a -> a
+ Int
1) FileStatus
status FilePath
path FilePath
name
removeRecursiveSafely :: FilePath -> IO ()
removeRecursiveSafely :: FilePath -> IO ()
removeRecursiveSafely FilePath
path =
FilePath
-> (FilePath -> IO ())
-> (FilePath -> IO ())
-> (FilePath -> IO ())
-> IO ()
System.Unix.Directory.traverse FilePath
path FilePath -> IO ()
removeFile FilePath -> IO ()
removeDirectory FilePath -> IO ()
umount
where
umount :: FilePath -> IO ()
umount FilePath
path =
do
Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath
"-- removeRecursiveSafely: unmounting " forall a. [a] -> [a] -> [a]
++ FilePath
path)
let cmd :: FilePath
cmd = FilePath
"umount -l " forall a. [a] -> [a] -> [a]
++ FilePath
path
ExitCode
result <- FilePath -> IO ExitCode
system FilePath
cmd
case ExitCode
result of
ExitCode
ExitSuccess -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
ExitFailure Int
n -> forall a. HasCallStack => FilePath -> a
error (FilePath
"Failure: " forall a. [a] -> [a] -> [a]
++ FilePath
cmd forall a. [a] -> [a] -> [a]
++ FilePath
" -> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Int
n)
unmountRecursiveSafely :: FilePath -> IO ()
unmountRecursiveSafely :: FilePath -> IO ()
unmountRecursiveSafely FilePath
path =
FilePath
-> (FilePath -> IO ())
-> (FilePath -> IO ())
-> (FilePath -> IO ())
-> IO ()
System.Unix.Directory.traverse FilePath
path forall {m :: * -> *} {p}. Monad m => p -> m ()
noOp forall {m :: * -> *} {p}. Monad m => p -> m ()
noOp FilePath -> IO ()
umount
where
noOp :: p -> m ()
noOp p
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
umount :: FilePath -> IO ()
umount FilePath
path =
do
Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath
"-- unmountRecursiveSafely: unmounting " forall a. [a] -> [a] -> [a]
++ FilePath
path)
let cmd :: FilePath
cmd = FilePath
"umount -l " forall a. [a] -> [a] -> [a]
++ FilePath
path
ExitCode
code <- FilePath -> IO ExitCode
system FilePath
cmd
case ExitCode
code of
ExitCode
ExitSuccess -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
ExitFailure Int
n -> forall a. HasCallStack => FilePath -> a
error (FilePath
"Failure: " forall a. [a] -> [a] -> [a]
++ FilePath
cmd forall a. [a] -> [a] -> [a]
++ FilePath
" -> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Int
n)
renameFileWithBackup :: FilePath -> FilePath -> IO ()
renameFileWithBackup :: FilePath -> FilePath -> IO ()
renameFileWithBackup FilePath
src FilePath
dst =
do
FilePath -> IO ()
removeIfExists (FilePath
dst forall a. [a] -> [a] -> [a]
++ FilePath
"~")
FilePath -> FilePath -> IO ()
renameIfExists FilePath
dst (FilePath
dst forall a. [a] -> [a] -> [a]
++ FilePath
"~")
FilePath -> FilePath -> IO ()
System.Directory.renameFile FilePath
src FilePath
dst
where
removeIfExists :: FilePath -> IO ()
removeIfExists FilePath
path =
do Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
path
if Bool
exists then FilePath -> IO ()
removeFile FilePath
path else forall (m :: * -> *) a. Monad m => a -> m a
return ()
renameIfExists :: FilePath -> FilePath -> IO ()
renameIfExists FilePath
src FilePath
dst =
do Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
src
if Bool
exists then FilePath -> FilePath -> IO ()
System.Directory.renameFile FilePath
src FilePath
dst else forall (m :: * -> *) a. Monad m => a -> m a
return ()
withWorkingDirectory :: FilePath -> IO a -> IO a
withWorkingDirectory :: forall a. FilePath -> IO a -> IO a
withWorkingDirectory FilePath
dir IO a
action =
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO FilePath
getCurrentDirectory FilePath -> IO ()
setCurrentDirectory (\ FilePath
_ -> FilePath -> IO ()
setCurrentDirectory FilePath
dir forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
action)
withTemporaryDirectory :: FilePath -> (FilePath -> IO a) -> IO a
withTemporaryDirectory :: forall a. FilePath -> (FilePath -> IO a) -> IO a
withTemporaryDirectory FilePath
fp FilePath -> IO a
f =
do FilePath
sysTmpDir <- IO FilePath
getTemporaryDirectory
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (FilePath -> IO FilePath
mkdtemp (FilePath
sysTmpDir FilePath -> FilePath -> FilePath
</> FilePath
fp))
FilePath -> IO ()
removeRecursiveSafely
FilePath -> IO a
f
foreign import ccall unsafe "stdlib.h mkdtemp"
c_mkdtemp :: CString -> IO CString
mkdtemp :: FilePath -> IO FilePath
mkdtemp :: FilePath -> IO FilePath
mkdtemp FilePath
template =
forall a. FilePath -> (CString -> IO a) -> IO a
withCString (if FilePath
"XXXXXX" forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
template then FilePath
template else (FilePath
template forall a. [a] -> [a] -> [a]
++ FilePath
"XXXXXX")) forall a b. (a -> b) -> a -> b
$ \ CString
ptr -> do
CString
cname <- forall a. FilePath -> IO (Ptr a) -> IO (Ptr a)
throwErrnoIfNull FilePath
"mkdtemp" (CString -> IO CString
c_mkdtemp CString
ptr)
FilePath
name <- CString -> IO FilePath
peekCString CString
cname
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
name