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   :  stable
-- 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

-- extra modules

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

-- local modules

import RawFilePath.Directory.Internal
import RawFilePath.Import
import qualified System.Posix.ByteString as U


-- | 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 =
    U.getFileStatus p
      >>= ( \i ->
              if i
                then getDirectoryFilesRecursive p
                else return [p]
          )
        . U.isDirectory


-- | 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]