{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP                 #-}
--------------------------------------------------------------------------------
-- | A module containing various file utility functions
module Hakyll.Core.Util.File
    ( makeDirectories
    , getRecursiveContents
    , removeDirectory
    , withPermissions
    ) where


--------------------------------------------------------------------------------
import           Control.Exception   (throw)
import           Control.Monad       (filterM, forM)
import           System.Directory    (createDirectoryIfMissing, doesPathExist,
                                      doesDirectoryExist, getDirectoryContents)
import           System.FilePath     (takeDirectory, (</>))
import           System.IO.Error     (catchIOError, isPermissionError)
#ifndef mingw32_HOST_OS
import           Control.Monad       (when)
import           System.Directory    (removeDirectoryRecursive)
#else
import           Control.Concurrent  (threadDelay)
import           Control.Exception   (SomeException, catch)
import           System.Directory    (removePathForcibly)
#endif


--------------------------------------------------------------------------------
-- | Given a path to a file, try to make the path writable by making
--   all directories on the path.
makeDirectories :: FilePath -> IO ()
makeDirectories :: FilePath -> IO ()
makeDirectories = Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> (FilePath -> FilePath) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeDirectory


--------------------------------------------------------------------------------
-- | Get all contents of a directory.
--
-- If a directory is encountered for which you do not have
-- permission, the directory will be skipped instead of
-- an exception being thrown.
--
-- If a dangling\/broken symbolic link is encountered, then it will
-- be skipped (since returning it may cause callers to throw exceptions).
getRecursiveContents :: (FilePath -> IO Bool)  -- ^ Ignore this file/directory
                     -> FilePath               -- ^ Directory to search
                     -> IO [FilePath]          -- ^ List of files found for which you have permissions
getRecursiveContents :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath]
getRecursiveContents FilePath -> IO Bool
ignore FilePath
top = FilePath -> IO [FilePath]
go FilePath
""
  where
    isProper :: FilePath -> IO Bool
isProper FilePath
x
        | FilePath
x FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
".", FilePath
".."] = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        | Bool
otherwise            = Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Bool
ignore FilePath
x

    getProperDirectoryContents :: FilePath -> IO [FilePath]
getProperDirectoryContents FilePath
absDir =
        (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
isProper ([FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [FilePath] -> [FilePath] -> IO [FilePath]
forall a. IO a -> a -> IO a
withPermissions (FilePath -> IO [FilePath]
getDirectoryContents FilePath
absDir) []

    go :: FilePath -> IO [FilePath]
go FilePath
relDir = do
        let absDir :: FilePath
absDir = FilePath
top FilePath -> FilePath -> FilePath
</> FilePath
relDir
        dirExists <- FilePath -> IO Bool
doesDirectoryExist FilePath
absDir
        if not dirExists
            then return []
            else do
                names <- getProperDirectoryContents absDir
                fmap concat . forM names $ \FilePath
name -> do
                    let relPath :: FilePath
relPath = FilePath
relDir FilePath -> FilePath -> FilePath
</> FilePath
name
                        absPath :: FilePath
absPath = FilePath
top FilePath -> FilePath -> FilePath
</> FilePath
relPath
                    isDirectory <- FilePath -> IO Bool
doesDirectoryExist FilePath
absPath
                    if isDirectory
                        then go relPath
                        else do
                            pathExists <- doesPathExist absPath
                            return $ if pathExists then [relPath] else []


--------------------------------------------------------------------------------
removeDirectory :: FilePath -> IO ()
#ifndef mingw32_HOST_OS
removeDirectory :: FilePath -> IO ()
removeDirectory FilePath
fp = do
    e <- FilePath -> IO Bool
doesDirectoryExist FilePath
fp
    when e $ removeDirectoryRecursive fp
#else
-- Deleting files on Windows is unreliable. If a file/directory is open by a program (e.g. antivirus),
-- then removing related directories *quickly* may fail with strange messages.
-- See here for discussions:
--      https://github.com/haskell/directory/issues/96
--      https://github.com/haskell/win32/pull/129
--
-- The hacky solution is to retry deleting directories a few times,
-- with a delay, on Windows only.
removeDirectory = retryWithDelay 10 . removePathForcibly

--------------------------------------------------------------------------------
-- | Retry an operation at most /n/ times (/n/ must be positive).
--   If the operation fails the /n/th time it will throw that final exception.
--   A delay of 100ms is introduced between every retry.
retryWithDelay :: Int -> IO a -> IO a
retryWithDelay i x
    | i <= 0    = error "Hakyll.Core.Util.File.retry: retry count must be 1 or more"
    | i == 1    = x
    | otherwise = catch x $ \(_::SomeException) -> threadDelay 100 >> retryWithDelay (i-1) x
#endif

--------------------------------------------------------------------------------
-- | Perform an IO action, catching any permission errors and returning
--   a default value in their place.  All other exceptions are rethrown.
withPermissions :: IO a
                -> a  -- ^ Default value to return in case of a permission error
                -> IO a
withPermissions :: forall a. IO a -> a -> IO a
withPermissions IO a
act a
onError
    = IO a
act IO a -> (IOError -> IO a) -> IO a
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` \IOError
e ->
        if IOError -> Bool
isPermissionError IOError
e
            then a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
onError
            else IOError -> IO a
forall a e. (HasCallStack, Exception e) => e -> a
throw IOError
e