    {- directory traversal and manipulation
     -
     - Copyright 2011-2014 Joey Hess <id@joeyh.name>
     -
     - License: BSD-2-clause
     -}

    {-# LANGUAGE CPP #-}
    {-# OPTIONS_GHC -fno-warn-tabs #-}

    module Utility.Directory (
    	module Utility.Directory,
    	module Utility.SystemDirectory
    ) where

    import System.IO.Error
    import Control.Monad
    import System.FilePath
    import System.PosixCompat.Files
    import Control.Applicative
    import System.IO.Unsafe (unsafeInterleaveIO)
    import Data.Maybe
    import Prelude

    #ifndef mingw32_HOST_OS
    import Utility.SafeCommand
    import Control.Monad.IfElse
    #endif

    import Utility.SystemDirectory
    import Utility.Tmp
    import Utility.Exception
    import Utility.Monad
    import Utility.Applicative

    dirCruft :: FilePath -> Bool
    dirCruft :: FilePath -> Bool
    dirCruft FilePath
    "." = Bool
    True
    dirCruft FilePath
    ".." = Bool
    True
    dirCruft FilePath
    _ = Bool
    False

    {- Lists the contents of a directory.
     - Unlike getDirectoryContents, paths are not relative to the directory. -}
    dirContents :: FilePath -> IO [FilePath]
    dirContents :: FilePath -> IO [FilePath]
    dirContents FilePath
    d = (FilePath -> FilePath) -> [FilePath] -> [FilePath]
    forall a b. (a -> b) -> [a] -> [b]
    map (FilePath
    d 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 -> Bool
    dirCruft) ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> FilePath -> IO [FilePath]
    getDirectoryContents FilePath
    d

    {- Gets files in a directory, and then its subdirectories, recursively,
     - and lazily.
     -
     - Does not follow symlinks to other subdirectories.
     -
     - When the directory does not exist, no exception is thrown,
     - instead, [] is returned. -}
    dirContentsRecursive :: FilePath -> IO [FilePath]
    dirContentsRecursive :: FilePath -> IO [FilePath]
    dirContentsRecursive = (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath]
    dirContentsRecursiveSkipping (Bool -> FilePath -> Bool
    forall a b. a -> b -> a
    const Bool
    False) Bool
    True

    {- Skips directories whose basenames match the skipdir. -}
    dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath]
    dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath]
    dirContentsRecursiveSkipping FilePath -> Bool
    skipdir Bool
    followsubdirsymlinks FilePath
    topdir = [FilePath] -> IO [FilePath]
    go [FilePath
    topdir]
      where
    	go :: [FilePath] -> IO [FilePath]
    go [] = [FilePath] -> IO [FilePath]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
    	go (FilePath
    dir:[FilePath]
    dirs)
    		| FilePath -> Bool
    skipdir (FilePath -> FilePath
    takeFileName FilePath
    dir) = [FilePath] -> IO [FilePath]
    go [FilePath]
    dirs
    		| Bool
    otherwise = IO [FilePath] -> IO [FilePath]
    forall a. IO a -> IO a
    unsafeInterleaveIO (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
    forall a b. (a -> b) -> a -> b
    $ do
    			([FilePath]
    files, [FilePath]
    dirs') <- [FilePath]
    -> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
    collect [] []
    				([FilePath] -> IO ([FilePath], [FilePath]))
    -> IO [FilePath] -> IO ([FilePath], [FilePath])
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< [FilePath] -> IO [FilePath] -> IO [FilePath]
    forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
    catchDefaultIO [] (FilePath -> IO [FilePath]
    dirContents FilePath
    dir)
    			[FilePath]
    files' <- [FilePath] -> IO [FilePath]
    go ([FilePath]
    dirs' [FilePath] -> [FilePath] -> [FilePath]
    forall a. [a] -> [a] -> [a]
    ++ [FilePath]
    dirs)
    			[FilePath] -> IO [FilePath]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([FilePath]
    files [FilePath] -> [FilePath] -> [FilePath]
    forall a. [a] -> [a] -> [a]
    ++ [FilePath]
    files')
    	collect :: [FilePath]
    -> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
    collect [FilePath]
    files [FilePath]
    dirs' [] = ([FilePath], [FilePath]) -> IO ([FilePath], [FilePath])
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([FilePath] -> [FilePath]
    forall a. [a] -> [a]
    reverse [FilePath]
    files, [FilePath] -> [FilePath]
    forall a. [a] -> [a]
    reverse [FilePath]
    dirs')
    	collect [FilePath]
    files [FilePath]
    dirs' (FilePath
    entry:[FilePath]
    entries)
    		| FilePath -> Bool
    dirCruft FilePath
    entry = [FilePath]
    -> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
    collect [FilePath]
    files [FilePath]
    dirs' [FilePath]
    entries
    		| Bool
    otherwise = do
    			let skip :: IO ([FilePath], [FilePath])
    skip = [FilePath]
    -> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
    collect (FilePath
    entryFilePath -> [FilePath] -> [FilePath]
    forall a. a -> [a] -> [a]
    :[FilePath]
    files) [FilePath]
    dirs' [FilePath]
    entries
    			let recurse :: IO ([FilePath], [FilePath])
    recurse = [FilePath]
    -> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
    collect [FilePath]
    files (FilePath
    entryFilePath -> [FilePath] -> [FilePath]
    forall a. a -> [a] -> [a]
    :[FilePath]
    dirs') [FilePath]
    entries
    			Maybe FileStatus
    ms <- IO FileStatus -> IO (Maybe FileStatus)
    forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
    catchMaybeIO (IO FileStatus -> IO (Maybe FileStatus))
    -> IO FileStatus -> IO (Maybe FileStatus)
    forall a b. (a -> b) -> a -> b
    $ FilePath -> IO FileStatus
    getSymbolicLinkStatus FilePath
    entry
    			case Maybe FileStatus
    ms of
    				(Just FileStatus
    s)
    					| FileStatus -> Bool
    isDirectory FileStatus
    s -> IO ([FilePath], [FilePath])
    recurse
    					| FileStatus -> Bool
    isSymbolicLink FileStatus
    s Bool -> Bool -> Bool
    && Bool
    followsubdirsymlinks ->
    						IO Bool
    -> (IO ([FilePath], [FilePath]), IO ([FilePath], [FilePath]))
    -> IO ([FilePath], [FilePath])
    forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
    ifM (FilePath -> IO Bool
    doesDirectoryExist FilePath
    entry)
    							( IO ([FilePath], [FilePath])
    recurse
    							, IO ([FilePath], [FilePath])
    skip
    							)
    				Maybe FileStatus
    _ -> IO ([FilePath], [FilePath])
    skip

    {- Gets the directory tree from a point, recursively and lazily,
     - with leaf directories **first**, skipping any whose basenames
     - match the skipdir. Does not follow symlinks. -}
    dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
    dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
    dirTreeRecursiveSkipping FilePath -> Bool
    skipdir FilePath
    topdir = [FilePath] -> [FilePath] -> IO [FilePath]
    go [] [FilePath
    topdir]
      where
    	go :: [FilePath] -> [FilePath] -> IO [FilePath]
    go [FilePath]
    c [] = [FilePath] -> IO [FilePath]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [FilePath]
    c
    	go [FilePath]
    c (FilePath
    dir:[FilePath]
    dirs)
    		| FilePath -> Bool
    skipdir (FilePath -> FilePath
    takeFileName FilePath
    dir) = [FilePath] -> [FilePath] -> IO [FilePath]
    go [FilePath]
    c [FilePath]
    dirs
    		| Bool
    otherwise = IO [FilePath] -> IO [FilePath]
    forall a. IO a -> IO a
    unsafeInterleaveIO (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
    forall a b. (a -> b) -> a -> b
    $ do
    			[FilePath]
    subdirs <- [FilePath] -> [FilePath] -> IO [FilePath]
    go []
    				([FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
    forall (m :: * -> *) a.
    Applicative m =>
    (a -> m Bool) -> [a] -> m [a]
    filterM (FileStatus -> Bool
    isDirectory (FileStatus -> Bool)
    -> (FilePath -> IO FileStatus) -> FilePath -> IO Bool
    forall (f :: * -> *) a b c.
    Functor f =>
    (a -> b) -> (c -> f a) -> c -> f b
    <$$> FilePath -> IO FileStatus
    getSymbolicLinkStatus)
    				([FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< [FilePath] -> IO [FilePath] -> IO [FilePath]
    forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
    catchDefaultIO [] (FilePath -> IO [FilePath]
    dirContents FilePath
    dir)
    			[FilePath] -> [FilePath] -> IO [FilePath]
    go ([FilePath]
    subdirs[FilePath] -> [FilePath] -> [FilePath]
    forall a. [a] -> [a] -> [a]
    ++FilePath
    dirFilePath -> [FilePath] -> [FilePath]
    forall a. a -> [a] -> [a]
    :[FilePath]
    c) [FilePath]
    dirs

    {- Moves one filename to another.
     - First tries a rename, but falls back to moving across devices if needed. -}
    moveFile :: FilePath -> FilePath -> IO ()
    moveFile :: FilePath -> FilePath -> IO ()
    moveFile FilePath
    src FilePath
    dest = IO () -> IO (Either IOException ())
    forall (m :: * -> *) a.
    MonadCatch m =>
    m a -> m (Either IOException a)
    tryIO (FilePath -> FilePath -> IO ()
    rename FilePath
    src FilePath
    dest) IO (Either IOException ())
    -> (Either IOException () -> 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
    >>= Either IOException () -> IO ()
    forall {b}. Either IOException b -> IO ()
    onrename
      where
    	onrename :: Either IOException b -> IO ()
    onrename (Right b
    _) = IO ()
    forall (m :: * -> *). Monad m => m ()
    noop
    	onrename (Left IOException
    e)
    		| IOException -> Bool
    isPermissionError IOException
    e = IO ()
    forall {a}. IO a
    rethrow
    		| IOException -> Bool
    isDoesNotExistError IOException
    e = IO ()
    forall {a}. IO a
    rethrow
    		| Bool
    otherwise = (FilePath -> FilePath -> IO ()) -> FilePath -> FilePath -> IO ()
    forall (m :: * -> *) v.
    (MonadMask m, MonadIO m) =>
    (FilePath -> v -> m ()) -> FilePath -> v -> m ()
    viaTmp FilePath -> FilePath -> IO ()
    forall {p}. FilePath -> p -> IO ()
    mv FilePath
    dest FilePath
    ""
    	  where
    		rethrow :: IO a
    rethrow = IOException -> IO a
    forall e a. Exception e => e -> IO a
    forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
    throwM IOException
    e

    		mv :: FilePath -> p -> IO ()
    mv FilePath
    tmp p
    _ = do
    		-- copyFile is likely not as optimised as
    		-- the mv command, so we'll use the command.
    		--
    		-- But, while Windows has a "mv", it does not seem very
    		-- reliable, so use copyFile there.
    #ifndef mingw32_HOST_OS
    			-- If dest is a directory, mv would move the file
    			-- into it, which is not desired.
    			IO Bool -> IO () -> IO ()
    forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
    whenM (FilePath -> IO Bool
    isdir FilePath
    dest) IO ()
    forall {a}. IO a
    rethrow
    			Bool
    ok <- FilePath -> [CommandParam] -> IO Bool
    boolSystem FilePath
    "mv" [FilePath -> CommandParam
    Param FilePath
    "-f", FilePath -> CommandParam
    Param FilePath
    src, FilePath -> CommandParam
    Param FilePath
    tmp]
    			let e' :: IOException
    e' = IOException
    e
    #else
    			r <- tryIO $ copyFile src tmp
    			let (ok, e') = case r of
    				Left err -> (False, err)
    				Right _ -> (True, e)
    #endif
    			Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless Bool
    ok (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
    				-- delete any partial
    				Either IOException ()
    _ <- IO () -> IO (Either IOException ())
    forall (m :: * -> *) a.
    MonadCatch m =>
    m a -> m (Either IOException a)
    tryIO (IO () -> IO (Either IOException ()))
    -> IO () -> IO (Either IOException ())
    forall a b. (a -> b) -> a -> b
    $ FilePath -> IO ()
    removeFile FilePath
    tmp
    				IOException -> IO ()
    forall e a. Exception e => e -> IO a
    forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
    throwM IOException
    e'

    #ifndef mingw32_HOST_OS
    	isdir :: FilePath -> IO Bool
    isdir FilePath
    f = do
    		Either IOException FileStatus
    r <- IO FileStatus -> IO (Either IOException FileStatus)
    forall (m :: * -> *) a.
    MonadCatch m =>
    m a -> m (Either IOException a)
    tryIO (IO FileStatus -> IO (Either IOException FileStatus))
    -> IO FileStatus -> IO (Either IOException FileStatus)
    forall a b. (a -> b) -> a -> b
    $ FilePath -> IO FileStatus
    getFileStatus FilePath
    f
    		case Either IOException FileStatus
    r of
    			(Left IOException
    _) -> Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
    			(Right FileStatus
    s) -> Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool -> IO Bool) -> Bool -> IO Bool
    forall a b. (a -> b) -> a -> b
    $ FileStatus -> Bool
    isDirectory FileStatus
    s
    #endif

    {- Removes a file, which may or may not exist, and does not have to
     - be a regular file.
     -
     - Note that an exception is thrown if the file exists but
     - cannot be removed. -}
    nukeFile :: FilePath -> IO ()
    nukeFile :: FilePath -> IO ()
    nukeFile FilePath
    file = IO (Maybe ()) -> IO ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ IO () -> IO (Maybe ())
    forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
    tryWhenExists IO ()
    go
      where
    #ifndef mingw32_HOST_OS
    	go :: IO ()
    go = FilePath -> IO ()
    removeLink FilePath
    file
    #else
    	go = removeFile file
    #endif