Skip to content

Commit f0e82a4

Browse files
committed
Add long path support wrt #39
1 parent e2b5ebc commit f0e82a4

File tree

2 files changed

+155
-3
lines changed

2 files changed

+155
-3
lines changed

file-io.cabal

+8
Original file line numberDiff line numberDiff line change
@@ -29,6 +29,11 @@ flag os-string
2929
default: False
3030
manual: False
3131

32+
flag long-paths
33+
description: Enable a hack for ad-hoc long path support
34+
default: True
35+
manual: True
36+
3237
library
3338
default-language: Haskell2010
3439

@@ -51,6 +56,9 @@ library
5156
else
5257
build-depends: filepath >= 1.4.100.0 && < 1.5.0.0
5358

59+
if flag(long-paths)
60+
cpp-options: -DLONG_PATHS
61+
5462
exposed-modules:
5563
System.File.OsPath
5664
System.File.OsPath.Internal

windows/System/File/Platform.hsc

+147-3
Original file line numberDiff line numberDiff line change
@@ -4,18 +4,23 @@
44

55
module System.File.Platform where
66

7-
import Control.Exception (bracketOnError, try, SomeException, onException)
7+
import Control.Exception (bracketOnError, try, SomeException, onException, displayException, Exception)
88
import Data.Bits
99
import Data.Maybe (fromJust)
1010
import System.IO (IOMode(..), Handle)
1111
import System.OsPath.Windows ( WindowsPath )
1212
import qualified System.OsPath.Windows as WS
1313
import Foreign.C.Types
1414

15+
import System.IO.Error (ioeSetFileName, modifyIOError, ioeSetLocation, ioeGetLocation)
16+
import Data.Char (isAlpha, isAscii, toUpper)
1517
import qualified System.OsString.Windows as WS hiding (decodeFS)
1618
import System.OsString.Windows ( encodeUtf, WindowsString )
19+
import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure))
20+
import GHC.IO.Encoding.UTF16 (mkUTF16le)
1721
import qualified System.Win32 as Win32
1822
import qualified System.Win32.WindowsString.File as WS
23+
import qualified System.Win32.WindowsString.Info as WS
1924
import System.Win32.WindowsString.Types (withTString, peekTString)
2025
#if MIN_VERSION_Win32(2, 14, 0)
2126
import System.Win32.WindowsString.Types (withFilePath)
@@ -54,7 +59,9 @@ import qualified "filepath" System.OsPath.Data.ByteString.Short.Word16 as BC
5459

5560
-- | Open a file and return the 'Handle'.
5661
openFile :: WindowsPath -> IOMode -> IO Handle
57-
openFile fp iomode = bracketOnError
62+
openFile fp' iomode = do
63+
fp <- furnishPath fp'
64+
bracketOnError
5865
(WS.createFile
5966
fp
6067
accessMode
@@ -104,7 +111,9 @@ writeShareMode =
104111

105112
-- | Open an existing file and return the 'Handle'.
106113
openExistingFile :: WindowsPath -> IOMode -> IO Handle
107-
openExistingFile fp iomode = bracketOnError
114+
openExistingFile fp' iomode = do
115+
fp <- furnishPath fp'
116+
bracketOnError
108117
(WS.createFile
109118
fp
110119
accessMode
@@ -248,3 +257,138 @@ any_ = coerce BC.any
248257

249258
#endif
250259

260+
furnishPath :: WindowsPath -> IO WindowsPath
261+
#if !defined(LONG_PATHS)
262+
furnishPath path = pure path
263+
#else
264+
furnishPath path =
265+
(toExtendedLengthPath <$> rawPrependCurrentDirectory path)
266+
`catchIOError` \ _ ->
267+
pure path
268+
269+
toExtendedLengthPath :: WindowsPath -> WindowsPath
270+
toExtendedLengthPath path =
271+
if WS.isRelative path
272+
then simplifiedPath
273+
else
274+
case WS.toChar <$> simplifiedPath' of
275+
'\\' : '?' : '?' : '\\' : _ -> simplifiedPath
276+
'\\' : '\\' : '?' : '\\' : _ -> simplifiedPath
277+
'\\' : '\\' : '.' : '\\' : _ -> simplifiedPath
278+
'\\' : '\\' : _ ->
279+
os "\\\\?\\UNC" <> WS.pack (drop 1 simplifiedPath')
280+
_ -> os "\\\\?\\" <> simplifiedPath
281+
where simplifiedPath = simplifyWindows path
282+
simplifiedPath' = WS.unpack simplifiedPath
283+
284+
rawPrependCurrentDirectory :: WindowsPath -> IO WindowsPath
285+
rawPrependCurrentDirectory path
286+
| WS.isRelative path =
287+
((`ioeAddLocation` "prependCurrentDirectory") .
288+
(`ioeSetWsPath` path)) `modifyIOError` do
289+
getFullPathName path
290+
| otherwise = pure path
291+
292+
simplifyWindows :: WindowsPath -> WindowsPath
293+
simplifyWindows path
294+
| path == mempty = mempty
295+
| drive' == ws "\\\\?\\" = drive' <> subpath
296+
| otherwise = simplifiedPath
297+
where
298+
simplifiedPath = WS.joinDrive drive' subpath'
299+
(drive, subpath) = WS.splitDrive path
300+
drive' = upperDrive (normaliseTrailingSep (normalisePathSeps drive))
301+
subpath' = appendSep . avoidEmpty . prependSep . WS.joinPath .
302+
stripPardirs . expandDots . skipSeps .
303+
WS.splitDirectories $ subpath
304+
305+
upperDrive d = case WS.unpack d of
306+
c : k : s
307+
| isAlpha (WS.toChar c), WS.toChar k == ':', all WS.isPathSeparator s ->
308+
-- unsafeFromChar is safe here since all characters are ASCII.
309+
WS.pack (WS.unsafeFromChar (toUpper (WS.toChar c)) : WS.unsafeFromChar ':' : s)
310+
_ -> d
311+
skipSeps =
312+
(WS.pack <$>) .
313+
filter (not . (`elem` (pure <$> WS.pathSeparators))) .
314+
(WS.unpack <$>)
315+
stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== ws "..")
316+
| otherwise = id
317+
prependSep | subpathIsAbsolute = (WS.pack [WS.pathSeparator] <>)
318+
| otherwise = id
319+
avoidEmpty | not pathIsAbsolute
320+
, drive == mempty || hasTrailingPathSep -- prefer "C:" over "C:."
321+
= emptyToCurDir
322+
| otherwise = id
323+
appendSep p | hasTrailingPathSep, not (pathIsAbsolute && p == mempty)
324+
= WS.addTrailingPathSeparator p
325+
| otherwise = p
326+
pathIsAbsolute = not (WS.isRelative path)
327+
subpathIsAbsolute = any WS.isPathSeparator (take 1 (WS.unpack subpath))
328+
hasTrailingPathSep = WS.hasTrailingPathSeparator subpath
329+
330+
-- | Remove redundant trailing slashes and pick the right kind of slash.
331+
normaliseTrailingSep :: WindowsPath -> WindowsPath
332+
normaliseTrailingSep path = do
333+
let path' = reverse (WS.unpack path)
334+
let (sep, path'') = span WS.isPathSeparator path'
335+
let addSep = if null sep then id else (WS.pathSeparator :)
336+
pack (reverse (addSep path''))
337+
338+
normalisePathSeps :: WindowsPath -> WindowsPath
339+
normalisePathSeps p = WS.pack (normaliseChar <$> WS.unpack p)
340+
where normaliseChar c = if WS.isPathSeparator c then WS.pathSeparator else c
341+
342+
emptyToCurDir :: WindowsPath -> WindowsPath
343+
emptyToCurDir path
344+
| path == mempty = ws "."
345+
| otherwise = path
346+
347+
ws :: String -> WindowsString
348+
ws = rightOrError . WS.encodeUtf
349+
350+
rightOrError :: Exception e => Either e a -> a
351+
rightOrError (Left e) = error (displayException e)
352+
rightOrError (Right a) = a
353+
354+
getFullPathName :: WindowsPath -> IO WindowsPath
355+
getFullPathName path =
356+
fromExtendedLengthPath <$> WS.getFullPathName (toExtendedLengthPath path)
357+
358+
ioeSetWsPath :: IOError -> WindowsPath -> IOError
359+
ioeSetWsPath err =
360+
ioeSetFileName err .
361+
rightOrError .
362+
WS.decodeWith (mkUTF16le TransliterateCodingFailure)
363+
364+
ioeAddLocation :: IOError -> String -> IOError
365+
ioeAddLocation e loc = do
366+
ioeSetLocation e newLoc
367+
where
368+
newLoc = loc <> if null oldLoc then "" else ":" <> oldLoc
369+
oldLoc = ioeGetLocation e
370+
371+
fromExtendedLengthPath :: WindowsPath -> WindowsPath
372+
fromExtendedLengthPath ePath =
373+
case WS.unpack ePath of
374+
c1 : c2 : c3 : c4 : path
375+
| (WS.toChar <$> [c1, c2, c3, c4]) == "\\\\?\\" ->
376+
case path of
377+
c5 : c6 : c7 : subpath@(c8 : _)
378+
| (WS.toChar <$> [c5, c6, c7, c8]) == "UNC\\" ->
379+
WS.pack (c8 : subpath)
380+
drive : col : subpath
381+
-- if the path is not "regular", then the prefix is necessary
382+
-- to ensure the path is interpreted literally
383+
| WS.toChar col == ':', isDriveChar drive, isPathRegular subpath ->
384+
WS.pack path
385+
_ -> ePath
386+
_ -> ePath
387+
where
388+
isDriveChar drive = isAlpha (WS.toChar drive) && isAscii (WS.toChar drive)
389+
isPathRegular path =
390+
not ('/' `elem` (WS.toChar <$> path) ||
391+
ws "." `elem` WS.splitDirectories (WS.pack path) ||
392+
ws ".." `elem` WS.splitDirectories (WS.pack path))
393+
394+
#endif

0 commit comments

Comments
 (0)