summaryrefslogtreecommitdiff
path: root/Utility/Path.hs
blob: 3ee5ff39d332986b804e16fd966999effdab6edf (plain)
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
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
{- path manipulation
 -
 - Copyright 2010-2014 Joey Hess <id@joeyh.name>
 -
 - License: BSD-2-clause
 -}

{-# LANGUAGE PackageImports, CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}

module Utility.Path where

import Data.String.Utils
import System.FilePath
import Data.List
import Data.Maybe
import Data.Char
import Control.Applicative
import Prelude

#ifdef mingw32_HOST_OS
import qualified System.FilePath.Posix as Posix
#else
import System.Posix.Files
import Utility.Exception
#endif

import qualified "MissingH" System.Path as MissingH
import Utility.Monad
import Utility.UserInfo
import Utility.Directory

{- Simplifies a path, removing any "." component, collapsing "dir/..", 
 - and removing the trailing path separator.
 -
 - On Windows, preserves whichever style of path separator might be used in
 - the input FilePaths. This is done because some programs in Windows
 - demand a particular path separator -- and which one actually varies!
 -
 - This does not guarantee that two paths that refer to the same location,
 - and are both relative to the same location (or both absolute) will
 - yeild the same result. Run both through normalise from System.FilePath
 - to ensure that.
 -}
simplifyPath :: FilePath -> FilePath
simplifyPath path = dropTrailingPathSeparator $ 
	joinDrive drive $ joinPath $ norm [] $ splitPath path'
  where
	(drive, path') = splitDrive path

	norm c [] = reverse c
	norm c (p:ps)
		| p' == ".." && not (null c) && dropTrailingPathSeparator (c !! 0) /= ".." = 
			norm (drop 1 c) ps
		| p' == "." = norm c ps
		| otherwise = norm (p:c) ps
	  where
		p' = dropTrailingPathSeparator p

{- Makes a path absolute.
 -
 - The first parameter is a base directory (ie, the cwd) to use if the path
 - is not already absolute, and should itsef be absolute.
 -
 - Does not attempt to deal with edge cases or ensure security with
 - untrusted inputs.
 -}
absPathFrom :: FilePath -> FilePath -> FilePath
absPathFrom dir path = simplifyPath (combine dir path)

{- On Windows, this converts the paths to unix-style, in order to run
 - MissingH's absNormPath on them. -}
absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath
#ifndef mingw32_HOST_OS
absNormPathUnix dir path = MissingH.absNormPath dir path
#else
absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos path)
  where
	fromdos = replace "\\" "/"
	todos = replace "/" "\\"
#endif

{- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -}
parentDir :: FilePath -> FilePath
parentDir = takeDirectory . dropTrailingPathSeparator

{- Just the parent directory of a path, or Nothing if the path has no
- parent (ie for "/" or ".") -}
upFrom :: FilePath -> Maybe FilePath
upFrom dir
	| length dirs < 2 = Nothing
	| otherwise = Just $ joinDrive drive (intercalate s $ init dirs)
  where
	-- on Unix, the drive will be "/" when the dir is absolute, otherwise ""
	(drive, path) = splitDrive dir
	dirs = filter (not . null) $ split s path
	s = [pathSeparator]

prop_upFrom_basics :: FilePath -> Bool
prop_upFrom_basics dir
	| null dir = True
	| dir == "/" = p == Nothing
	| otherwise = p /= Just dir
  where
	p = upFrom 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' || (addTrailingPathSeparator a') `isPrefixOf` b'
  where
	a' = norm a
	b' = norm b
	norm = normalise . simplifyPath

{- Converts a filename into an absolute path.
 -
 - Unlike Directory.canonicalizePath, this does not require the path
 - already exists. -}
absPath :: FilePath -> IO FilePath
absPath file = do
	cwd <- getCurrentDirectory
	return $ absPathFrom cwd file

{- Constructs a relative path from the CWD to a file.
 -
 - For example, assuming CWD is /tmp/foo/bar:
 -    relPathCwdToFile "/tmp/foo" == ".."
 -    relPathCwdToFile "/tmp/foo/bar" == "" 
 -}
relPathCwdToFile :: FilePath -> IO FilePath
relPathCwdToFile f = do
	c <- getCurrentDirectory
	relPathDirToFile c f

{- Constructs a relative path from a directory to a file. -}
relPathDirToFile :: FilePath -> FilePath -> IO FilePath
relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to

{- This requires the first path to be absolute, and the
 - second path cannot contain ../ or ./
 -
 - On Windows, if the paths are on different drives,
 - a relative path is not possible and the path is simply
 - returned as-is.
 -}
relPathDirToFileAbs :: FilePath -> FilePath -> FilePath
relPathDirToFileAbs from to
	| takeDrive from /= takeDrive to = to
	| otherwise = intercalate s $ dotdots ++ uncommon
  where
	s = [pathSeparator]
	pfrom = split s from
	pto = split s to
	common = map fst $ takeWhile same $ zip pfrom pto
	same (c,d) = c == d
	uncommon = drop numcommon pto
	dotdots = replicate (length pfrom - numcommon) ".."
	numcommon = length common

prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool
prop_relPathDirToFile_basics from to
	| null from || null to = True
	| from == to = null r
	| otherwise = not (null r)
  where
	r = relPathDirToFileAbs from to 

prop_relPathDirToFile_regressionTest :: Bool
prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
  where
	{- Two paths have the same directory component at the same
	 - location, but it's not really the same directory.
	 - Code used to get this wrong. -}
	same_dir_shortcurcuits_at_difference =
		relPathDirToFileAbs (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"])
			(joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])
				== joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]

{- Given an original list of paths, and an expanded list derived from it,
 - which may be arbitrarily reordered, generates a list of lists, where
 - each sublist corresponds to one of the original paths.
 -
 - When the original path is a directory, any items in the expanded list
 - that are contained in that directory will appear in its segment.
 -
 - The order of the original list of paths is attempted to be preserved in
 - the order of the returned segments. However, doing so has a O^NM
 - growth factor. So, if the original list has more than 100 paths on it,
 - we stop preserving ordering at that point. Presumably a user passing
 - that many paths in doesn't care too much about order of the later ones.
 -}
segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]]
segmentPaths [] new = [new]
segmentPaths [_] new = [new] -- optimisation
segmentPaths (l:ls) new = found : segmentPaths ls rest
  where
	(found, rest) = if length ls < 100
		then partition (l `dirContains`) new
		else break (\p -> not (l `dirContains` p)) new

{- This assumes that it's cheaper to call segmentPaths on the result,
 - than it would be to run the action separately with each path. In
 - the case of git file list commands, that assumption tends to hold.
 -}
runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
runSegmentPaths a paths = segmentPaths paths <$> a paths

{- Converts paths in the home directory to use ~/ -}
relHome :: FilePath -> IO String
relHome path = do
	home <- myHomeDir
	return $ if dirContains home path
		then "~/" ++ relPathDirToFileAbs home path
		else path

{- Checks if a command is available in PATH.
 -
 - The command may be fully-qualified, in which case, this succeeds as
 - long as it exists. -}
inPath :: String -> IO Bool
inPath command = isJust <$> searchPath command

{- Finds a command in PATH and returns the full path to it.
 -
 - The command may be fully qualified already, in which case it will
 - be returned if it exists.
 -}
searchPath :: String -> IO (Maybe FilePath)
searchPath command
	| isAbsolute command = check command
	| otherwise = getSearchPath >>= getM indir
  where
	indir d = check $ d </> command
	check f = firstM doesFileExist
#ifdef mingw32_HOST_OS
		[f, f ++ ".exe"]
#else
		[f]
#endif

{- Checks if a filename is a unix dotfile. All files inside dotdirs
 - count as dotfiles. -}
dotfile :: FilePath -> Bool
dotfile file
	| f == "." = False
	| f == ".." = False
	| f == "" = False
	| otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file)
  where
	f = takeFileName file

{- Converts a DOS style path to a msys2 style path. Only on Windows.
 - Any trailing '\' is preserved as a trailing '/' 
 - 
 - Taken from: http://sourceforge.net/p/msys2/wiki/MSYS2%20introduction/i
 -
 - The virtual filesystem contains:
 -  /c, /d, ...	mount points for Windows drives
 -}
toMSYS2Path :: FilePath -> FilePath
#ifndef mingw32_HOST_OS
toMSYS2Path = id
#else
toMSYS2Path p
	| null drive = recombine parts
	| otherwise = recombine $ "/" : driveletter drive : parts
  where
	(drive, p') = splitDrive p
	parts = splitDirectories p'
	driveletter = map toLower . takeWhile (/= ':')
	recombine = fixtrailing . Posix.joinPath
	fixtrailing s
		| hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s
		| otherwise = s
#endif

{- Maximum size to use for a file in a specified directory.
 -
 - Many systems have a 255 byte limit to the name of a file, 
 - so that's taken as the max if the system has a larger limit, or has no
 - limit.
 -}
fileNameLengthLimit :: FilePath -> IO Int
#ifdef mingw32_HOST_OS
fileNameLengthLimit _ = return 255
#else
fileNameLengthLimit dir = do
	-- getPathVar can fail due to statfs(2) overflow
	l <- catchDefaultIO 0 $
		fromIntegral <$> getPathVar dir FileNameLimit
	if l <= 0
		then return 255
		else return $ minimum [l, 255]
#endif

{- Given a string that we'd like to use as the basis for FilePath, but that
 - was provided by a third party and is not to be trusted, returns the closest
 - sane FilePath.
 -
 - All spaces and punctuation and other wacky stuff are replaced
 - with '_', except for '.'
 - "../" will thus turn into ".._", which is safe.
 -}
sanitizeFilePath :: String -> FilePath
sanitizeFilePath = map sanitize
  where
	sanitize c
		| c == '.' = c
		| isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_'
		| otherwise = c

{- Similar to splitExtensions, but knows that some things in FilePaths
 - after a dot are too long to be extensions. -}
splitShortExtensions :: FilePath -> (FilePath, [String])
splitShortExtensions = splitShortExtensions' 5 -- enough for ".jpeg"
splitShortExtensions' :: Int -> FilePath -> (FilePath, [String])
splitShortExtensions' maxextension = go []
  where
	go c f
		| len > 0 && len <= maxextension && not (null base) = 
			go (ext:c) base
		| otherwise = (f, c)
	  where
		(base, ext) = splitExtension f
		len = length ext