{-# LANGUAGE CPP #-}
module Darcs.Util.File
    (
    -- * Files and directories
      getFileStatus
    , withCurrentDirectory
    , doesDirectoryReallyExist
    , removeFileMayNotExist
    -- * OS-dependent special directories
    , xdgCacheDir
    , osxCacheDir
    , getDirectoryContents
    , getRecursiveContents
    , getRecursiveContentsFullPath
    ) where

import Prelude ( lookup )
import Darcs.Prelude

import Control.Exception ( catch, bracket )
import Control.Monad ( when, unless, forM )

import System.Environment ( getEnvironment )
import System.Directory ( removeFile, getHomeDirectory,
                          getAppUserDataDirectory, doesDirectoryExist,
                          createDirectory, getDirectoryContents )
import System.IO.Error ( isDoesNotExistError, catchIOError )
import System.Posix.Files( getSymbolicLinkStatus, FileStatus, isDirectory )
#ifndef WIN32
import System.Posix.Files( setFileMode, ownerModes )
#endif
import System.FilePath.Posix ( (</>) )

import Darcs.Util.Exception ( catchall )
import Darcs.Util.Path( FilePathLike, getCurrentDirectory, setCurrentDirectory, toFilePath )

withCurrentDirectory :: FilePathLike p
                     => p
                     -> IO a
                     -> IO a
withCurrentDirectory :: p -> IO a -> IO a
withCurrentDirectory name :: p
name m :: IO a
m =
    IO AbsolutePath
-> (AbsolutePath -> IO ()) -> (AbsolutePath -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
        (do AbsolutePath
cwd <- IO AbsolutePath
getCurrentDirectory
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (p -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath p
name FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= "") (p -> IO ()
forall p. FilePathLike p => p -> IO ()
setCurrentDirectory p
name)
            AbsolutePath -> IO AbsolutePath
forall (m :: * -> *) a. Monad m => a -> m a
return AbsolutePath
cwd)
        (\oldwd :: AbsolutePath
oldwd -> AbsolutePath -> IO ()
forall p. FilePathLike p => p -> IO ()
setCurrentDirectory AbsolutePath
oldwd IO () -> IO () -> IO ()
forall a. IO a -> IO a -> IO a
`catchall` () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
        (IO a -> AbsolutePath -> IO a
forall a b. a -> b -> a
const IO a
m)

getFileStatus :: FilePath -> IO (Maybe FileStatus)
getFileStatus :: FilePath -> IO (Maybe FileStatus)
getFileStatus f :: FilePath
f =
  FileStatus -> Maybe FileStatus
forall a. a -> Maybe a
Just (FileStatus -> Maybe FileStatus)
-> IO FileStatus -> IO (Maybe FileStatus)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FilePath -> IO FileStatus
getSymbolicLinkStatus FilePath
f IO (Maybe FileStatus)
-> (IOError -> IO (Maybe FileStatus)) -> IO (Maybe FileStatus)
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` (\_-> Maybe FileStatus -> IO (Maybe FileStatus)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FileStatus
forall a. Maybe a
Nothing)

doesDirectoryReallyExist :: FilePath -> IO Bool
doesDirectoryReallyExist :: FilePath -> IO Bool
doesDirectoryReallyExist f :: FilePath
f =
    IO Bool -> Bool -> IO Bool
forall a. IO a -> a -> IO a
catchNonExistence (FileStatus -> Bool
isDirectory (FileStatus -> Bool) -> IO FileStatus -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FilePath -> IO FileStatus
getSymbolicLinkStatus FilePath
f) Bool
False

removeFileMayNotExist :: FilePathLike p => p -> IO ()
removeFileMayNotExist :: p -> IO ()
removeFileMayNotExist f :: p
f = IO () -> () -> IO ()
forall a. IO a -> a -> IO a
catchNonExistence (FilePath -> IO ()
removeFile (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ p -> FilePath
forall a. FilePathLike a => a -> FilePath
toFilePath p
f) ()

catchNonExistence :: IO a -> a -> IO a
catchNonExistence :: IO a -> a -> IO a
catchNonExistence job :: IO a
job nonexistval :: a
nonexistval =
    IO a -> (IOError -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO a
job ((IOError -> IO a) -> IO a) -> (IOError -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$
    \e :: IOError
e -> if IOError -> Bool
isDoesNotExistError IOError
e then a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
nonexistval
                                   else IOError -> IO a
forall a. IOError -> IO a
ioError IOError
e

-- |osxCacheDir assumes @~/Library/Caches/@ exists.
osxCacheDir :: IO (Maybe FilePath)
osxCacheDir :: IO (Maybe FilePath)
osxCacheDir = do
    FilePath
home <- IO FilePath
getHomeDirectory
    Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
home FilePath -> FilePath -> FilePath
</> "Library" FilePath -> FilePath -> FilePath
</> "Caches"
    IO (Maybe FilePath) -> IO (Maybe FilePath) -> IO (Maybe FilePath)
forall a. IO a -> IO a -> IO a
`catchall` Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing

-- |xdgCacheDir returns the $XDG_CACHE_HOME environment variable,
-- or @~/.cache@ if undefined. See the FreeDesktop specification:
-- http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html
xdgCacheDir :: IO (Maybe FilePath)
xdgCacheDir :: IO (Maybe FilePath)
xdgCacheDir = do
    [(FilePath, FilePath)]
env <- IO [(FilePath, FilePath)]
getEnvironment
    FilePath
d <- case FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "XDG_CACHE_HOME" [(FilePath, FilePath)]
env of
           Just d :: FilePath
d  -> FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
d
           Nothing -> FilePath -> IO FilePath
getAppUserDataDirectory "cache"
    Bool
exists <- FilePath -> IO Bool
doesDirectoryExist FilePath
d

    -- If directory does not exist, create it with permissions 0700
    -- as specified by the FreeDesktop standard.
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do FilePath -> IO ()
createDirectory FilePath
d
#ifndef WIN32
    -- see http://bugs.darcs.net/issue2334
                       FilePath -> FileMode -> IO ()
setFileMode FilePath
d FileMode
ownerModes
#endif
    Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
d
    IO (Maybe FilePath) -> IO (Maybe FilePath) -> IO (Maybe FilePath)
forall a. IO a -> IO a -> IO a
`catchall` Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing

-- |getRecursiveContents returns all files under topdir that aren't
-- directories.
getRecursiveContents :: FilePath -> IO [FilePath]
getRecursiveContents :: FilePath -> IO [FilePath]
getRecursiveContents topdir :: FilePath
topdir = do
  [FilePath]
names <- FilePath -> IO [FilePath]
getDirectoryContents FilePath
topdir
  let properNames :: [FilePath]
properNames = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [".", ".."]) [FilePath]
names
  [[FilePath]]
paths <- [FilePath] -> (FilePath -> IO [FilePath]) -> IO [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
properNames ((FilePath -> IO [FilePath]) -> IO [[FilePath]])
-> (FilePath -> IO [FilePath]) -> IO [[FilePath]]
forall a b. (a -> b) -> a -> b
$ \name :: FilePath
name -> do
    let path :: FilePath
path = FilePath
topdir FilePath -> FilePath -> FilePath
</> FilePath
name
    Bool
isDir <- FilePath -> IO Bool
doesDirectoryExist FilePath
path
    if Bool
isDir
      then FilePath -> IO [FilePath]
getRecursiveContents FilePath
path
      else [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath
name]
  [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FilePath]]
paths)

-- |getRecursiveContentsFullPath returns all files under topdir
-- that aren't directories.
-- Unlike getRecursiveContents this function returns the full path.
getRecursiveContentsFullPath :: FilePath -> IO [FilePath]
getRecursiveContentsFullPath :: FilePath -> IO [FilePath]
getRecursiveContentsFullPath topdir :: FilePath
topdir = do
  [FilePath]
names <- FilePath -> IO [FilePath]
getDirectoryContents FilePath
topdir
  let properNames :: [FilePath]
properNames = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [".", ".."]) [FilePath]
names
  [[FilePath]]
paths <- [FilePath] -> (FilePath -> IO [FilePath]) -> IO [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
properNames ((FilePath -> IO [FilePath]) -> IO [[FilePath]])
-> (FilePath -> IO [FilePath]) -> IO [[FilePath]]
forall a b. (a -> b) -> a -> b
$ \name :: FilePath
name -> do
    let path :: FilePath
path = FilePath
topdir FilePath -> FilePath -> FilePath
</> FilePath
name
    Bool
isDir <- FilePath -> IO Bool
doesDirectoryExist FilePath
path
    if Bool
isDir
      then FilePath -> IO [FilePath]
getRecursiveContentsFullPath FilePath
path
      else [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath
path]
  [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FilePath]]
paths)