    {-# 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
          status <- FilePath -> IO FileStatus
    getSymbolicLinkStatus FilePath
    path
          case isDirectory status of
            Bool
    True ->
                do
                  subs <- FilePath -> IO [FilePath]
    getDirectoryContents FilePath
    path IO [FilePath] -> ([FilePath] -> IO [FilePath]) -> IO [FilePath]
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>=
                          [FilePath] -> IO [FilePath]
    forall a. a -> IO a
    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 a. Eq a => a -> [a] -> 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 a b. IO a -> (a -> IO b) -> IO b
    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)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM FilePath -> IO [(FilePath, FileStatus)]
    find IO [[(FilePath, FileStatus)]]
    -> ([[(FilePath, FileStatus)]] -> IO [(FilePath, FileStatus)])
    -> IO [(FilePath, FileStatus)]
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>=
                          [(FilePath, FileStatus)] -> IO [(FilePath, FileStatus)]
    forall a. a -> IO a
    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
                  return $ (path, status) : subs
            Bool
    False ->
                [(FilePath, FileStatus)] -> IO [(FilePath, FileStatus)]
    forall a. a -> IO a
    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
          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
          either (\ (SomeException
    _ :: SomeException) -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()) (doPath path) 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 a b. IO a -> (a -> IO b) -> IO b
    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)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
          doDirectoryFile Int
    _ FileStatus
    _ FilePath
    _ FilePath
    ".." = () -> IO ()
    forall a. a -> IO a
    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
                childStatus <- FilePath -> IO FileStatus
    getSymbolicLinkStatus FilePath
    child
                if deviceID status == deviceID childStatus then
                    doPath child childStatus else
                    do
                      if tries > 1 then hPutStrLn stderr ("try " ++ show tries ++ ":") else return ()
                      m child
                      doDirectoryFile (tries + 1) status path 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
                result <- FilePath -> IO ExitCode
    system FilePath
    cmd
                case result of
                  ExitCode
    ExitSuccess -> () -> IO ()
    forall a. a -> IO a
    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 a. a -> m a
    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
                code <- FilePath -> IO ExitCode
    system FilePath
    cmd
                case code of
                  ExitCode
    ExitSuccess -> () -> IO ()
    forall a. a -> IO a
    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 exists <- FilePath -> IO Bool
    doesFileExist FilePath
    path
                 if exists then removeFile path else return ()
          renameIfExists :: FilePath -> FilePath -> IO ()
    renameIfExists FilePath
    src FilePath
    dst =
              do exists <- FilePath -> IO Bool
    doesFileExist FilePath
    src
                 if exists then System.Directory.renameFile src dst else return ()

    -- |temporarily change the working directory to |dir| while running |action|
    withWorkingDirectory :: FilePath -> IO a -> IO a
    withWorkingDirectory :: forall a. 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 a b. IO a -> IO b -> IO b
    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 :: forall a. FilePath -> (FilePath -> IO a) -> IO a
    withTemporaryDirectory FilePath
    fp FilePath -> IO a
    f =
         do sysTmpDir <- IO FilePath
    getTemporaryDirectory
            bracket (mkdtemp (sysTmpDir </> fp))
                    removeRecursiveSafely
                    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
            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)
            name <- peekCString cname
            return name