{-# 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

-- | Traverse a directory and return a list of all the (path,
-- fileStatus) pairs.
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 IO [FilePath] -> ([FilePath] -> IO [FilePath]) -> IO [FilePath]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                      [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> IO [FilePath])
-> ([FilePath] -> [FilePath]) -> [FilePath] -> IO [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
path 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 -> [FilePath] -> Bool) -> [FilePath] -> FilePath -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [FilePath
".", FilePath
".."]) IO [FilePath]
-> ([FilePath] -> IO [[(FilePath, FileStatus)]])
-> IO [[(FilePath, FileStatus)]]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                      (FilePath -> IO [(FilePath, FileStatus)])
-> [FilePath] -> IO [[(FilePath, FileStatus)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO [(FilePath, FileStatus)]
find IO [[(FilePath, FileStatus)]]
-> ([[(FilePath, FileStatus)]] -> IO [(FilePath, FileStatus)])
-> IO [(FilePath, FileStatus)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                      [(FilePath, FileStatus)] -> IO [(FilePath, FileStatus)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(FilePath, FileStatus)] -> IO [(FilePath, FileStatus)])
-> ([[(FilePath, FileStatus)]] -> [(FilePath, FileStatus)])
-> [[(FilePath, FileStatus)]]
-> IO [(FilePath, FileStatus)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(FilePath, FileStatus)]] -> [(FilePath, FileStatus)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [(FilePath, FileStatus)] -> IO [(FilePath, FileStatus)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(FilePath, FileStatus)] -> IO [(FilePath, FileStatus)])
-> [(FilePath, FileStatus)] -> IO [(FilePath, FileStatus)]
forall a b. (a -> b) -> a -> b
$ (FilePath
path, FileStatus
status) (FilePath, FileStatus)
-> [(FilePath, FileStatus)] -> [(FilePath, FileStatus)]
forall a. a -> [a] -> [a]
: [(FilePath, FileStatus)]
subs
        Bool
False ->
            [(FilePath, FileStatus)] -> IO [(FilePath, FileStatus)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(FilePath
path, FileStatus
status)]

traverse :: FilePath -> (FilePath -> IO ()) -> (FilePath -> IO ()) -> (FilePath -> IO ()) -> IO ()
-- ^ Traverse a file system directory applying D to every directory, F
-- to every non-directory file, and M to every mount point.
-- NOTE: It is tempting to use the "find" function to returns a list
-- of the elements of the directory and then map that list over an
-- "unmount and remove" function.  However, because we are unmounting
-- as we traverse, the contents of the file list may change in ways
-- that could confuse the find function.
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 <- 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
$ FilePath -> IO FileStatus
getSymbolicLinkStatus FilePath
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 ()) (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 IO [FilePath] -> ([FilePath] -> IO [()]) -> IO [()]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FilePath -> IO ()) -> [FilePath] -> IO [()]
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
"." = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      doDirectoryFile Int
_ FileStatus
_ FilePath
_ FilePath
".." = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      doDirectoryFile Int
tries FileStatus
_ FilePath
_ FilePath
_ | Int
tries Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
5 =
          FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error (FilePath
"Couldn't unmount file system on " FilePath -> FilePath -> FilePath
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 DeviceID -> DeviceID -> Bool
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath
"try " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
tries FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":") else () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  FilePath -> IO ()
m FilePath
child
                  Int -> FileStatus -> FilePath -> FilePath -> IO ()
doDirectoryFile (Int
tries Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) FileStatus
status FilePath
path FilePath
name

-- |Recursively remove a directory contents on a single file system.
-- The adjective \"Safely\" refers to these features:
--   1. It will not follow symlinks
--   2. If it finds a directory that seems to be a mount point,
--	it will attempt to unmount it up to five times.  If it
--	still seems to be a mount point it gives up
--   3. It doesn't use /proc/mounts, which is ambiguous or wrong
--	when you are inside a chroot.
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 " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path)
            -- This is less likely to hang and more likely to succeed
            -- than regular umount.
            let cmd :: FilePath
cmd = FilePath
"umount -l " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path
            ExitCode
result <- FilePath -> IO ExitCode
system FilePath
cmd
            case ExitCode
result of
              ExitCode
ExitSuccess -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              ExitFailure Int
n -> FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error (FilePath
"Failure: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
cmd FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" -> " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n)

unmountRecursiveSafely :: FilePath -> IO ()
-- ^ Like removeRecursiveSafely but doesn't remove any files, just
-- unmounts anything it finds mounted.  Note that this can be much
-- slower than Mount.umountBelow, use that instead.
unmountRecursiveSafely :: FilePath -> IO ()
unmountRecursiveSafely FilePath
path =
    FilePath
-> (FilePath -> IO ())
-> (FilePath -> IO ())
-> (FilePath -> IO ())
-> IO ()
System.Unix.Directory.traverse FilePath
path FilePath -> IO ()
forall (m :: * -> *) p. Monad m => p -> m ()
noOp FilePath -> IO ()
forall (m :: * -> *) p. Monad m => p -> m ()
noOp FilePath -> IO ()
umount
    where
      noOp :: p -> m ()
noOp p
_ = () -> m ()
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 " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path)
            -- This is less likely to hang and more likely to succeed
            -- than regular umount.
            let cmd :: FilePath
cmd = FilePath
"umount -l " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path
            ExitCode
code <- FilePath -> IO ExitCode
system FilePath
cmd
            case ExitCode
code of
              ExitCode
ExitSuccess -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              ExitFailure Int
n -> FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error (FilePath
"Failure: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
cmd FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" -> " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n)

-- |Rename src to dst, and if dst already exists move it to dst~.
-- If dst~ exists it is removed.
renameFileWithBackup :: FilePath -> FilePath -> IO ()
renameFileWithBackup :: FilePath -> FilePath -> IO ()
renameFileWithBackup FilePath
src FilePath
dst =
    do
      FilePath -> IO ()
removeIfExists (FilePath
dst FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"~")
      FilePath -> FilePath -> IO ()
renameIfExists FilePath
dst (FilePath
dst FilePath -> FilePath -> FilePath
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 () -> IO ()
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 () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- |temporarily change the working directory to |dir| while running |action|
withWorkingDirectory :: FilePath -> IO a -> IO a
withWorkingDirectory :: FilePath -> IO a -> IO a
withWorkingDirectory FilePath
dir IO a
action =
    IO FilePath -> (FilePath -> IO ()) -> (FilePath -> IO a) -> IO a
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 IO () -> IO a -> IO a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
action)

-- |create a temporary directory, run the action, remove the temporary directory
-- the first argument is a template for the temporary directory name
-- the directory will be created as a subdirectory of the directory returned by getTemporaryDirectory
-- the temporary directory will be automatically removed afterwards.
-- your working directory is not altered
withTemporaryDirectory :: FilePath -> (FilePath -> IO a) -> IO a
withTemporaryDirectory :: FilePath -> (FilePath -> IO a) -> IO a
withTemporaryDirectory FilePath
fp FilePath -> IO a
f =
     do FilePath
sysTmpDir <- IO FilePath
getTemporaryDirectory
        IO FilePath -> (FilePath -> IO ()) -> (FilePath -> IO a) -> IO a
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 =
      FilePath -> (CString -> IO FilePath) -> IO FilePath
forall a. FilePath -> (CString -> IO a) -> IO a
withCString (if FilePath
"XXXXXX" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
template then FilePath
template else (FilePath
template FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"XXXXXX")) ((CString -> IO FilePath) -> IO FilePath)
-> (CString -> IO FilePath) -> IO FilePath
forall a b. (a -> b) -> a -> b
$ \ CString
ptr -> do
        CString
cname <- FilePath -> IO CString -> IO CString
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
        FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
name