e505c03bcc
nukeFile replaced with removeWhenExistsWith removeLink, which allows using RawFilePath. Utility.Directory cannot use RawFilePath since setup does not depend on posix. This commit was sponsored by Graham Spencer on Patreon.
150 lines
4.4 KiB
Haskell
150 lines
4.4 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
|
|
import Control.Applicative
|
|
import Control.Monad.IfElse
|
|
import System.IO.Unsafe (unsafeInterleaveIO)
|
|
import System.IO.Error
|
|
import Data.Maybe
|
|
import Prelude
|
|
|
|
#ifndef mingw32_HOST_OS
|
|
import Utility.SafeCommand
|
|
#endif
|
|
|
|
import Utility.SystemDirectory
|
|
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 []
|
|
=<< filterM (isDirectory <$$> getSymbolicLinkStatus)
|
|
=<< catchDefaultIO [] (dirContents dir)
|
|
go (subdirs++dir:c) 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 = viaTmp mv dest ()
|
|
where
|
|
rethrow = throwM e
|
|
|
|
mv tmp () = 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.
|
|
whenM (isdir dest) rethrow
|
|
ok <- boolSystem "mv" [Param "-f", Param src, Param tmp]
|
|
let e' = e
|
|
#else
|
|
r <- tryIO $ copyFile src tmp
|
|
let (ok, e') = case r of
|
|
Left err -> (False, err)
|
|
Right _ -> (True, e)
|
|
#endif
|
|
unless ok $ do
|
|
-- delete any partial
|
|
_ <- tryIO $ removeFile tmp
|
|
throwM e'
|
|
|
|
#ifndef mingw32_HOST_OS
|
|
isdir f = do
|
|
r <- tryIO $ getFileStatus f
|
|
case r of
|
|
(Left _) -> return False
|
|
(Right s) -> return $ isDirectory s
|
|
#endif
|
|
|
|
{- 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
|