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