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
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
|
{- git-annex utility functions
-
- Copyright 2010 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Utility (
hGetContentsStrict,
readFileStrict,
parentDir,
absPath,
relPathCwdToDir,
relPathDirToDir,
boolSystem,
shellEscape,
shellUnEscape,
utilityEscape,
unsetFileMode,
readMaybe,
safeWriteFile,
dirContains,
prop_idempotent_shellEscape,
prop_idempotent_shellEscape_multiword,
prop_parentDir_basics,
prop_relPathDirToDir_basics
) where
import System.IO
import System.Exit
import System.Posix.Process
import System.Posix.Signals
import System.Posix.Files
import System.Posix.Types
import Data.String.Utils
import System.Path
import System.FilePath
import System.Directory
import Foreign (complement)
import Data.List
import Control.Monad (liftM2)
{- A version of hgetContents that is not lazy. Ensures file is
- all read before it gets closed. -}
hGetContentsStrict :: Handle -> IO String
hGetContentsStrict h = hGetContents h >>= \s -> length s `seq` return s
{- A version of readFile that is not lazy. -}
readFileStrict :: FilePath -> IO String
readFileStrict f = readFile f >>= \s -> length s `seq` return s
{- Returns the parent directory of a path. Parent of / is "" -}
parentDir :: FilePath -> FilePath
parentDir dir =
if not $ null dirs
then slash ++ join s (take (length dirs - 1) dirs)
else ""
where
dirs = filter (not . null) $ split s dir
slash = if isAbsolute dir then s else ""
s = [pathSeparator]
prop_parentDir_basics :: FilePath -> Bool
prop_parentDir_basics dir
| null dir = True
| dir == "/" = parentDir dir == ""
| otherwise = p /= dir
where
p = parentDir dir
{- Checks if the first FilePath is, or could be said to contain the second.
- For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc
- are all equivilant.
-}
dirContains :: FilePath -> FilePath -> Bool
dirContains a b = a == b || a' == b' || (a'++"/") `isPrefixOf` b'
where
norm p = case (absNormPath p ".") of
Just r -> r
Nothing -> ""
a' = norm a
b' = norm b
{- Converts a filename into a normalized, absolute path. -}
absPath :: FilePath -> IO FilePath
absPath file = do
cwd <- getCurrentDirectory
case absNormPath cwd file of
Just f -> return f
Nothing -> error $ "unable to normalize " ++ file
{- Constructs a relative path from the CWD to a directory.
-
- For example, assuming CWD is /tmp/foo/bar:
- relPathCwdToDir "/tmp/foo" == "../"
- relPathCwdToDir "/tmp/foo/bar" == ""
-}
relPathCwdToDir :: FilePath -> IO FilePath
relPathCwdToDir dir = liftM2 relPathDirToDir getCurrentDirectory (absPath dir)
{- Constructs a relative path from one directory to another.
-
- Both directories must be absolute, and normalized (eg with absNormpath).
-
- The path will end with "/", unless it is empty.
-}
relPathDirToDir :: FilePath -> FilePath -> FilePath
relPathDirToDir from to =
if not $ null path
then addTrailingPathSeparator path
else ""
where
s = [pathSeparator]
pfrom = split s from
pto = split s to
common = map fst $ filter same $ zip pfrom pto
same (c,d) = c == d
uncommon = drop numcommon pto
dotdots = replicate (length pfrom - numcommon) ".."
numcommon = length common
path = join s $ dotdots ++ uncommon
prop_relPathDirToDir_basics :: FilePath -> FilePath -> Bool
prop_relPathDirToDir_basics from to
| from == to = null r
| otherwise = not (null r) && (last r == '/')
where
r = relPathDirToDir from to
{- Run a system command, and returns True or False
- if it succeeded or failed.
-
- SIGINT(ctrl-c) is allowed to propigate and will terminate the program.
-}
boolSystem :: FilePath -> [String] -> IO Bool
boolSystem command params = do
-- Going low-level because all the high-level system functions
-- block SIGINT etc. We need to block SIGCHLD, but allow
-- SIGINT to do its default program termination.
let sigset = addSignal sigCHLD emptySignalSet
oldint <- installHandler sigINT Default Nothing
oldset <- getSignalMask
blockSignals sigset
childpid <- forkProcess $ childaction oldint oldset
mps <- getProcessStatus True False childpid
restoresignals oldint oldset
case mps of
Just (Exited ExitSuccess) -> return True
_ -> return False
where
restoresignals oldint oldset = do
_ <- installHandler sigINT oldint Nothing
setSignalMask oldset
childaction oldint oldset = do
restoresignals oldint oldset
executeFile command True params Nothing
{- Escapes a filename to be safely able to be exposed to the shell. -}
shellEscape :: FilePath -> String
shellEscape f = "'" ++ escaped ++ "'"
where
-- replace ' with '"'"'
escaped = join "'\"'\"'" $ split "'" f
{- Unescapes a set of shellEscaped words or filenames. -}
shellUnEscape :: String -> [String]
shellUnEscape [] = []
shellUnEscape s = word:(shellUnEscape rest)
where
(word, rest) = findword "" s
findword w [] = (w, "")
findword w (c:cs)
| c == ' ' = (w, cs)
| c == '\'' = inquote c w cs
| c == '"' = inquote c w cs
| otherwise = findword (w++[c]) cs
inquote _ w [] = (w, "")
inquote q w (c:cs)
| c == q = findword w cs
| otherwise = inquote q (w++[c]) cs
{- Ensures that a filename is safe to pass to a utility program. In particular
- since utilities tend to interpret things starting with a dash as
- an option, relative filenames starting with a dash are escaped. -}
utilityEscape :: FilePath -> FilePath
utilityEscape ('-':s) = "./-" ++ s
utilityEscape s = s
{- For quickcheck. -}
prop_idempotent_shellEscape :: String -> Bool
prop_idempotent_shellEscape s = [s] == (shellUnEscape $ shellEscape s)
prop_idempotent_shellEscape_multiword :: [String] -> Bool
prop_idempotent_shellEscape_multiword s = s == (shellUnEscape $ unwords $ map shellEscape s)
{- Removes a FileMode from a file.
- For example, call with otherWriteMode to chmod o-w -}
unsetFileMode :: FilePath -> FileMode -> IO ()
unsetFileMode f m = do
s <- getFileStatus f
setFileMode f $ fileMode s `intersectFileModes` complement m
{- Attempts to read a value from a String. -}
readMaybe :: (Read a) => String -> Maybe a
readMaybe s = case reads s of
((x,_):_) -> Just x
_ -> Nothing
{- Writes a file using a temp file that is renamed atomically into place. -}
safeWriteFile :: FilePath -> String -> IO ()
safeWriteFile file content = do
pid <- getProcessID
let tmpfile = file ++ ".tmp" ++ show pid
createDirectoryIfMissing True (parentDir file)
writeFile tmpfile content
renameFile tmpfile file
|
