From 7115d1ec162b4059b3e8e8f84bd8d5898c1db025 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 14 May 2014 19:41:05 -0400 Subject: moved source code to src This is to work around OSX's brain-damange regarding filename case insensitivity. Avoided moving config.hs, because it's a config file. Put in a symlink to make build work. --- Utility/Directory.hs | 135 --------------------------------------------------- 1 file changed, 135 deletions(-) delete mode 100644 Utility/Directory.hs (limited to 'Utility/Directory.hs') diff --git a/Utility/Directory.hs b/Utility/Directory.hs deleted file mode 100644 index d92327c0..00000000 --- a/Utility/Directory.hs +++ /dev/null @@ -1,135 +0,0 @@ -{- directory manipulation - - - - Copyright 2011-2014 Joey Hess - - - - 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 -- cgit v1.2.3