1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
|
{- directory traversal and manipulation
-
- Copyright 2011-2025 Joey Hess <id@joeyh.name>
-
- License: BSD-2-clause
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Directory where
#ifdef WITH_OSPATH
import System.Directory.OsPath
#else
import Utility.SystemDirectory
#endif
import Control.Monad
import System.PosixCompat.Files (isDirectory, isSymbolicLink)
import Control.Applicative
import System.IO.Unsafe (unsafeInterleaveIO)
import Data.Maybe
import Prelude
import Utility.OsPath
import Utility.Exception
import Utility.Monad
import qualified Utility.RawFilePath as R
dirCruft :: [OsPath]
dirCruft = [literalOsPath ".", literalOsPath ".."]
{- Lists the contents of a directory.
- Unlike getDirectoryContents, paths are not relative to the directory. -}
dirContents :: OsPath -> IO [OsPath]
dirContents d = map (d </>) . filter (`notElem` dirCruft)
<$> getDirectoryContents d
{- Gets files in a directory, and then its subdirectories, recursively,
- and lazily.
-
- Does not follow symlinks to other subdirectories.
-
- Throws exception if the directory does not exist or otherwise cannot be
- accessed. However, does not throw exceptions when subdirectories cannot
- be accessed (the use of unsafeInterleaveIO would make it difficult to
- trap such exceptions).
-}
dirContentsRecursive :: OsPath -> IO [OsPath]
dirContentsRecursive = dirContentsRecursiveSkipping (const False) True
{- Skips directories whose basenames match the skipdir. -}
dirContentsRecursiveSkipping :: (OsPath -> Bool) -> Bool -> OsPath -> IO [OsPath]
dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir
| skipdir (takeFileName topdir) = return []
| otherwise = do
-- Get the contents of the top directory outside of
-- unsafeInterleaveIO, which allows throwing exceptions if
-- it cannot be accessed.
(files, dirs) <- collect [] []
=<< dirContents topdir
files' <- go dirs
return (files ++ files')
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 :: [OsPath] -> [OsPath] -> [OsPath] -> IO ([OsPath], [OsPath])
collect files dirs' [] = return (reverse files, reverse dirs')
collect files dirs' (entry:entries)
| entry `elem` dirCruft = collect files dirs' entries
| otherwise = do
let skip = collect (entry:files) dirs' entries
let recurse = collect files (entry:dirs') entries
ms <- catchMaybeIO $ R.getSymbolicLinkStatus (fromOsPath 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.
-
- Throws exception if the directory does not exist or otherwise cannot be
- accessed. However, does not throw exceptions when subdirectories cannot
- be accessed (the use of unsafeInterleaveIO would make it difficult to
- trap such exceptions).
-}
dirTreeRecursiveSkipping :: (OsPath -> Bool) -> OsPath -> IO [OsPath]
dirTreeRecursiveSkipping skipdir topdir
| skipdir (takeFileName topdir) = return []
| otherwise = do
subdirs <- filterM isdir =<< dirContents topdir
go [] subdirs
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 (fromOsPath p)
{- When the action fails due to the directory not existing, returns []. -}
emptyWhenDoesNotExist :: IO [a] -> IO [a]
emptyWhenDoesNotExist a = tryWhenExists a >>= return . \case
Just v -> v
Nothing -> []
{- 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
|
