Directory.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  RawFilePath.Directory
-- Copyright   :  (C) 2004 The University of Glasgow. (C) 2017 XT et al.
-- License     :  BSD-style (see the LICENSE file)
--
-- Maintainer  :  e@xtendo.org
-- Stability   :  experimental
-- Portability :  POSIX
--
-- This is the module for the 'RawFilePath' version of functions in the
-- @directory@ package.
--
-----------------------------------------------------------------------------

module RawFilePath.Directory
    ( RawFilePath
    -- ** Nondestructive (read-only)
    , doesPathExist
    , doesFileExist
    , doesDirectoryExist
    , getHomeDirectory
    , getTemporaryDirectory
    , listDirectory
    , getDirectoryFiles
    , getDirectoryFilesRecursive
    -- ** Destructive
    , createDirectory
    , createDirectoryIfMissing
    , removeFile
    , tryRemoveFile
    , removeDirectory
    , removeDirectoryRecursive
    ) where

import RawFilePath.Import

-- extra modules

import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified System.Posix.ByteString as U -- U for Unix

-- local modules

import RawFilePath.Directory.Internal

-- | Test whether the given path points to an existing filesystem object.  If
-- the user lacks necessary permissions to search the parent directories, this
-- function may return false even if the file does actually exist.
doesPathExist :: RawFilePath -> IO Bool
doesPathExist path = (True <$ U.getFileStatus path) `catchIOError`
      const (return False)

-- | Return 'True' if the argument file exists and is either a directory or a
-- symbolic link to a directory, and 'False' otherwise.
doesDirectoryExist :: RawFilePath -> IO Bool
doesDirectoryExist path = pathIsDirectory path `catchIOError`
    const (return False)

-- | Return 'True' if the argument file exists and is not a directory, and
-- 'False' otherwise.
doesFileExist :: RawFilePath -> IO Bool
doesFileExist path = (not <$> pathIsDirectory path) `catchIOError`
    const (return False)

-- | Returns the current user's home directory. More specifically, the value
-- of the @HOME@ environment variable.
--
-- The directory returned is expected to be writable by the current user, but
-- note that it isn't generally considered good practice to store
-- application-specific data here; use 'getXdgDirectory' or
-- 'getAppUserDataDirectory' instead.
--
-- The operation may fail with:
--
-- * 'UnsupportedOperation'
-- The operating system has no notion of home directory.
--
-- * 'isDoesNotExistError'
-- The home directory for the current user does not exist, or
-- cannot be found.
getHomeDirectory :: IO (Maybe RawFilePath)
getHomeDirectory = U.getEnv "HOME"

-- | Return the current directory for temporary files.  It first returns the
-- value of the @TMPDIR@ environment variable or \"\/tmp\" if the variable
-- isn\'t defined.
getTemporaryDirectory :: IO ByteString
getTemporaryDirectory = fromMaybe "/tmp" <$> U.getEnv "TMPDIR"

-- | Get a list of files in the specified directory, excluding "." and ".."
--
-- > ghci> listDirectory "/"
-- > ["home","sys","var","opt","lib64","sbin","usr","srv","dev","lost+found","bin","tmp","run","root","boot","proc","etc","lib"]
listDirectory
    :: RawFilePath -- ^ The path of directory to inspect
    -> IO [RawFilePath] -- ^ A list of files in the directory
listDirectory dirPath = filter f <$> getDirectoryFiles dirPath
  where
    f p = p /= "." && p /= ".."

-- | Get a list of files in the specified directory, including "." and ".."
--
-- > ghci> getDirectoryFiles "/"
-- > ["home","sys","var","opt","..","lib64","sbin","usr","srv","dev","lost+found","mnt","bin","tmp","run","root","boot",".","proc","etc","lib"]
getDirectoryFiles
    :: RawFilePath -- ^ The path of directory to inspect
    -> IO [RawFilePath] -- ^ A list of files in the directory
getDirectoryFiles dirPath = bracket open close repeatRead
  where
    open = U.openDirStream dirPath
    close = U.closeDirStream
    repeatRead stream = do
        d <- U.readDirStream stream
        if B.length d == 0 then return [] else do
            rest <- repeatRead stream
            return $ d : rest

-- | Recursively get all files in all subdirectories of the specified
-- directory.
--
-- > *System.RawFilePath> getDirectoryFilesRecursive "src"
-- > ["src/System/RawFilePath.hs"]
getDirectoryFilesRecursive
    :: RawFilePath -- ^ The path of directory to inspect
    -> IO [RawFilePath] -- ^ A list of relative paths
getDirectoryFilesRecursive path = do
    names <- map (path +/+) . filter (\x -> x /= ".." && x /= ".") <$>
        getDirectoryFiles path
    inspectedNames <- mapM inspect names
    return $ concat inspectedNames
  where
    inspect :: RawFilePath -> IO [RawFilePath]
    inspect p = fmap U.isDirectory (U.getFileStatus p) >>= \i -> if i
        then getDirectoryFilesRecursive p else return [p]

-- | Create a new directory.
--
-- > ghci> createDirectory "/tmp/mydir"
-- > ghci> getDirectoryFiles "/tmp/mydir"
-- > [".",".."]
-- > ghci> createDirectory "/tmp/mydir/anotherdir"
-- > ghci> getDirectoryFiles "/tmp/mydir"
-- > [".","..","anotherdir"]
createDirectory :: RawFilePath -> IO ()
createDirectory dir = U.createDirectory dir 0o755

-- | Create a new directory if it does not already exist.  If the first
-- argument is 'True' the function will also create all parent directories
-- when they are missing.
createDirectoryIfMissing
    :: Bool -- ^ Create parent directories or not
    -> RawFilePath -- ^ The path of the directory to create
    -> IO ()
createDirectoryIfMissing willCreateParents path
    | willCreateParents = createDirs parents
    | otherwise = createDir path ioError
  where
    createDirs []         = return ()
    createDirs [dir]   = createDir dir ioError
    createDirs (dir : dirs) = createDir dir $ \ _ ->
        -- Create parent directories (recursively) only when they are missing
        createDirs dirs >> createDir dir ioError
    createDir dir notExistHandler = tryIOError (createDirectory dir) >>= \ case 
        Right ()                   -> return ()
        Left  e
          | isDoesNotExistError  e -> notExistHandler e
          -- createDirectory (and indeed POSIX mkdir) does not distinguish
          -- between a dir already existing and a file already existing. So we
          -- check for it here. Unfortunately there is a slight race condition
          -- here, but we think it is benign. It could report an exeption in
          -- the case that the dir did exist but another process deletes the
          -- directory and creates a file in its place before we can check
          -- that the directory did indeed exist.  We also follow this path
          -- when we get a permissions error, as trying to create "." when in
          -- the root directory on Windows fails with
          --     CreateDirectory ".": permission denied (Access is denied.)
          -- This caused GHCi to crash when loading a module in the root
          -- directory.
          | isAlreadyExistsError e
         || isPermissionError    e -> do
              canIgnore <- catchIOError (pathIsDirectory dir) $ \ _ ->
                return (isAlreadyExistsError e)
              unless canIgnore (ioError e)
          | otherwise              -> ioError e
    parents = reverse $ scanl1 (+/+) $ B.split (w8 '/') $ stripSlash path

-- | Remove a file. This function internally calls @unlink@. If the file does
-- not exist, an exception is thrown.
removeFile :: RawFilePath -> IO ()
removeFile = U.removeLink

-- | A function that "tries" to remove a file. If the file does not exist,
-- nothing happens.
tryRemoveFile :: RawFilePath -> IO ()
tryRemoveFile path = catchIOError (U.removeLink path) $
    \ e -> unless (isDoesNotExistError e) $ ioError e

-- | Remove a directory. The target directory needs to be empty; Otherwise an
-- exception will be thrown.
removeDirectory :: RawFilePath -> IO ()
removeDirectory = U.removeDirectory

-- | Remove an existing directory /dir/ together with its contents and
-- subdirectories. Within this directory, symbolic links are removed without
-- affecting their targets.
removeDirectoryRecursive :: RawFilePath -> IO ()
removeDirectoryRecursive path =
  (`ioeAddLocation` "removeDirectoryRecursive") `modifyIOError` do
    m <- U.getSymbolicLinkStatus path
    case fileTypeFromMetadata m of
      Directory ->
        removeContentsRecursive path
      DirectoryLink ->
        ioError (err `ioeSetErrorString` "is a directory symbolic link")
      _ ->
        ioError (err `ioeSetErrorString` "not a directory")
  where err = mkIOError InappropriateType "" Nothing (Just (B8.unpack path))

-- | Remove an existing file or directory at /path/ together with its contents
-- and subdirectories. Symbolic links are removed without affecting their the
-- targets.
removePathRecursive :: RawFilePath -> IO ()
removePathRecursive path =
  (`ioeAddLocation` "removePathRecursive") `modifyIOError` do
    m <- U.getSymbolicLinkStatus path
    case fileTypeFromMetadata m of
      Directory     -> removeContentsRecursive path
      DirectoryLink -> U.removeDirectory path
      _             -> U.removeLink path

-- | Remove the contents of the directory /dir/ recursively. Symbolic links
-- are removed without affecting their the targets.
removeContentsRecursive :: RawFilePath -> IO ()
removeContentsRecursive path =
  (`ioeAddLocation` "removeContentsRecursive") `modifyIOError` do
    cont <- listDirectory path
    mapM_ removePathRecursive [path +/+ x | x <- cont]
    U.removeDirectory path


w8 :: Char -> Word8
w8 = fromIntegral . ord

stripSlash :: ByteString -> ByteString
stripSlash p = if B.last p == w8 '/' then B.init p else p

pathIsDirectory :: RawFilePath -> IO Bool
pathIsDirectory path = U.isDirectory <$> U.getFileStatus path


-- An extremely simplistic approach for path concatenation.
infixr 5  +/+
(+/+) :: RawFilePath -> RawFilePath -> RawFilePath
a +/+ b = mconcat [a, "/", b]