summaryrefslogtreecommitdiff
path: root/src/Utility/Directory.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Utility/Directory.hs')
-rw-r--r--src/Utility/Directory.hs135
1 files changed, 135 insertions, 0 deletions
diff --git a/src/Utility/Directory.hs b/src/Utility/Directory.hs
new file mode 100644
index 00000000..d92327c0
--- /dev/null
+++ b/src/Utility/Directory.hs
@@ -0,0 +1,135 @@
+{- directory manipulation
+ -
+ - Copyright 2011-2014 Joey Hess <joey@kitenet.net>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.Directory where
+
+import System.IO.Error
+import System.Directory
+import Control.Exception (throw)
+import Control.Monad
+import Control.Monad.IfElse
+import System.FilePath
+import Control.Applicative
+import System.IO.Unsafe (unsafeInterleaveIO)
+
+import Utility.PosixFiles
+import Utility.SafeCommand
+import Utility.Tmp
+import Utility.Exception
+import Utility.Monad
+import Utility.Applicative
+
+dirCruft :: FilePath -> Bool
+dirCruft "." = True
+dirCruft ".." = True
+dirCruft _ = False
+
+{- Lists the contents of a directory.
+ - Unlike getDirectoryContents, paths are not relative to the directory. -}
+dirContents :: FilePath -> IO [FilePath]
+dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents 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 = dirContentsRecursiveSkipping (const False) True
+
+{- Skips directories whose basenames match the skipdir. -}
+dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath]
+dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir = go [topdir]
+ where
+ go [] = return []
+ go (dir:dirs)
+ | skipdir (takeFileName dir) = go dirs
+ | otherwise = unsafeInterleaveIO $ do
+ (files, dirs') <- collect [] []
+ =<< catchDefaultIO [] (dirContents dir)
+ files' <- go (dirs' ++ dirs)
+ return (files ++ files')
+ collect files dirs' [] = return (reverse files, reverse dirs')
+ collect files dirs' (entry:entries)
+ | dirCruft entry = collect files dirs' entries
+ | otherwise = do
+ let skip = collect (entry:files) dirs' entries
+ let recurse = collect files (entry:dirs') entries
+ ms <- catchMaybeIO $ getSymbolicLinkStatus entry
+ case ms of
+ (Just s)
+ | isDirectory s -> recurse
+ | isSymbolicLink s && followsubdirsymlinks ->
+ ifM (doesDirectoryExist entry)
+ ( recurse
+ , skip
+ )
+ _ -> 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 skipdir topdir = go [] [topdir]
+ where
+ go c [] = return c
+ go c (dir:dirs)
+ | skipdir (takeFileName dir) = go c dirs
+ | otherwise = unsafeInterleaveIO $ do
+ subdirs <- go c
+ =<< filterM (isDirectory <$$> getSymbolicLinkStatus)
+ =<< catchDefaultIO [] (dirContents dir)
+ go (subdirs++[dir]) dirs
+
+{- Moves one filename to another.
+ - First tries a rename, but falls back to moving across devices if needed. -}
+moveFile :: FilePath -> FilePath -> IO ()
+moveFile src dest = tryIO (rename src dest) >>= onrename
+ where
+ onrename (Right _) = noop
+ onrename (Left e)
+ | isPermissionError e = rethrow
+ | isDoesNotExistError e = rethrow
+ | otherwise = do
+ -- copyFile is likely not as optimised as
+ -- the mv command, so we'll use the latter.
+ -- But, mv will move into a directory if
+ -- dest is one, which is not desired.
+ whenM (isdir dest) rethrow
+ viaTmp mv dest undefined
+ where
+ rethrow = throw e
+ mv tmp _ = do
+ ok <- boolSystem "mv" [Param "-f", Param src, Param tmp]
+ unless ok $ do
+ -- delete any partial
+ _ <- tryIO $ removeFile tmp
+ rethrow
+
+ isdir f = do
+ r <- tryIO $ getFileStatus f
+ case r of
+ (Left _) -> return False
+ (Right s) -> return $ isDirectory s
+
+{- 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 file = void $ tryWhenExists go
+ where
+#ifndef mingw32_HOST_OS
+ go = removeLink file
+#else
+ go = removeFile file
+#endif