{- 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 = forall a b. (a -> b) -> [a] -> [b]
map (FilePath
d FilePath -> FilePath -> FilePath
</>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Bool
dirCruft) 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 (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 [] = 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 = forall a. IO a -> IO a
unsafeInterleaveIO forall a b. (a -> b) -> a -> b
$ do
			([FilePath]
files, [FilePath]
dirs') <- [FilePath]
-> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
collect [] []
				forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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' forall a. [a] -> [a] -> [a]
++ [FilePath]
dirs)
			forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath]
files forall a. [a] -> [a] -> [a]
++ [FilePath]
files')
	collect :: [FilePath]
-> [FilePath] -> [FilePath] -> IO ([FilePath], [FilePath])
collect [FilePath]
files [FilePath]
dirs' [] = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
reverse [FilePath]
files, 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
entryforall 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
entryforall a. a -> [a] -> [a]
:[FilePath]
dirs') [FilePath]
entries
			Maybe FileStatus
ms <- forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
catchMaybeIO 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 ->
						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 [] = 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 = forall a. IO a -> IO a
unsafeInterleaveIO forall a b. (a -> b) -> a -> b
$ do
			[FilePath]
subdirs <- [FilePath] -> [FilePath] -> IO [FilePath]
go []
				forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (FileStatus -> Bool
isDirectory forall (f :: * -> *) a b c.
Functor f =>
(a -> b) -> (c -> f a) -> c -> f b
<$$> FilePath -> IO FileStatus
getSymbolicLinkStatus)
				forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO [] (FilePath -> IO [FilePath]
dirContents FilePath
dir)
			[FilePath] -> [FilePath] -> IO [FilePath]
go ([FilePath]
subdirsforall a. [a] -> [a] -> [a]
++FilePath
dirforall 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 = forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO (FilePath -> FilePath -> IO ()
rename FilePath
src FilePath
dest) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {b}. Either IOException b -> IO ()
onrename
  where
	onrename :: Either IOException b -> IO ()
onrename (Right b
_) = forall (m :: * -> *). Monad m => m ()
noop
	onrename (Left IOException
e)
		| IOException -> Bool
isPermissionError IOException
e = forall {a}. IO a
rethrow
		| IOException -> Bool
isDoesNotExistError IOException
e = forall {a}. IO a
rethrow
		| Bool
otherwise = forall (m :: * -> *) v.
(MonadMask m, MonadIO m) =>
(FilePath -> v -> m ()) -> FilePath -> v -> m ()
viaTmp forall {p}. FilePath -> p -> IO ()
mv FilePath
dest FilePath
""
	  where
		rethrow :: IO a
rethrow = 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.
			forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (FilePath -> IO Bool
isdir FilePath
dest) 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
			forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok forall a b. (a -> b) -> a -> b
$ do
				-- delete any partial
				Either IOException ()
_ <- forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
tmp
				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 <- forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO FileStatus
getFileStatus FilePath
f
		case Either IOException FileStatus
r of
			(Left IOException
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
			(Right FileStatus
s) -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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