54ad1b4cfb
Works around this bug in unix-compat: https://github.com/jacobstanley/unix-compat/issues/56 getFileStatus and other FilePath using functions in unix-compat do not do UNC conversion on Windows. Made Utility.RawFilePath use convertToWindowsNativeNamespace to do the necessary conversion on windows to support long filenames. Audited all imports of System.PosixCompat.Files to make sure that no functions that operate on FilePath were imported from it. Instead, use the equvilants from Utility.RawFilePath. In particular the re-export of that module in Common had to be removed, which led to lots of other changes throughout the code. The changes to Build.Configure, Build.DesktopFile, and Build.TestConfig make Utility.Directory not be needed to build setup. And so let it use Utility.RawFilePath, which depends on unix, which cannot be in setup-depends. Sponsored-by: Dartmouth College's Datalad project
101 lines
3.2 KiB
Haskell
101 lines
3.2 KiB
Haskell
{- directory traversal and manipulation
|
|
-
|
|
- Copyright 2011-2020 Joey Hess <id@joeyh.name>
|
|
-
|
|
- License: BSD-2-clause
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# OPTIONS_GHC -fno-warn-tabs #-}
|
|
|
|
module Utility.Directory (
|
|
module Utility.Directory,
|
|
module Utility.SystemDirectory
|
|
) where
|
|
|
|
import Control.Monad
|
|
import System.FilePath
|
|
import System.PosixCompat.Files (isDirectory, isSymbolicLink)
|
|
import Control.Applicative
|
|
import System.IO.Unsafe (unsafeInterleaveIO)
|
|
import Data.Maybe
|
|
import Prelude
|
|
|
|
import Utility.SystemDirectory
|
|
import Utility.Exception
|
|
import Utility.Monad
|
|
import Utility.FileSystemEncoding
|
|
import qualified Utility.RawFilePath as R
|
|
|
|
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 $ R.getSymbolicLinkStatus (toRawFilePath 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 []
|
|
=<< filterM isdir
|
|
=<< catchDefaultIO [] (dirContents dir)
|
|
go (subdirs++dir:c) dirs
|
|
isdir p = isDirectory <$> R.getSymbolicLinkStatus (toRawFilePath p)
|
|
|
|
{- Use with an action that removes something, which may or may not exist.
|
|
-
|
|
- If an exception is thrown due to it not existing, it is ignored.
|
|
-}
|
|
removeWhenExistsWith :: (a -> IO ()) -> a -> IO ()
|
|
removeWhenExistsWith f a = void $ tryWhenExists $ f a
|