Skip to content

Commit af17fb6

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

3 files changed

Lines changed: 191 additions & 3 deletions

File tree

‎file-io.cabal‎

Lines changed: 10 additions & 0 deletions
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 on Windows
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
@@ -113,4 +121,6 @@ test-suite Properties
113121
default-language: Haskell2010
114122
build-depends: base >=4.13.0.0 && <5, bytestring, tasty, tasty-hunit, file-io, filepath, temporary
115123
ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N10"
124+
if flag(long-paths)
125+
cpp-options: -DLONG_PATHS
116126

‎tests/Properties.hs‎

Lines changed: 15 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -23,7 +23,11 @@ import qualified Data.ByteString as BS
2323
main :: IO ()
2424
main = defaultMain $ testGroup "All"
2525
[ testGroup "System.File.OsPath"
26-
[ testCase "readFile . writeFile" writeFileReadFile
26+
[
27+
#if defined(LONG_PATHS)
28+
testCase "writeFile (very long path)" writeFileLongPath,
29+
#endif
30+
testCase "readFile . writeFile" writeFileReadFile
2731
, testCase "readFile . writeFile . writeFile" writeWriteFileReadFile
2832
, testCase "readFile . appendFile . writeFile" appendFileReadFile
2933
, testCase "iomode: ReadFile does not allow write" iomodeReadFile
@@ -56,6 +60,16 @@ main = defaultMain $ testGroup "All"
5660
]
5761
]
5862

63+
writeFileLongPath :: Assertion
64+
writeFileLongPath = do
65+
withSystemTempDirectory "test" $ \baseDir' -> do
66+
baseDir <- OSP.encodeFS baseDir'
67+
let longName = mconcat (replicate 10 "its_very_long")
68+
longFile <- baseDir </> longName </> longName
69+
OSP.writeFile longFile "test"
70+
contents <- OSP.readFile longFile
71+
"test" @=? contents
72+
5973
writeFileReadFile :: Assertion
6074
writeFileReadFile = do
6175
withSystemTempDirectory "test" $ \baseDir' -> do

‎windows/System/File/Platform.hsc‎

Lines changed: 166 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -52,9 +52,20 @@ import "filepath" System.OsString.Internal.Types (WindowsString(..), WindowsChar
5252
import qualified "filepath" System.OsPath.Data.ByteString.Short.Word16 as BC
5353
#endif
5454

55+
#if defined(LONG_PATHS)
56+
import Control.Exception (displayException, Exception)
57+
import System.IO.Error (ioeSetFileName, modifyIOError, ioeSetLocation, ioeGetLocation, catchIOError)
58+
import Data.Char (isAlpha, isAscii, toUpper)
59+
import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure))
60+
import GHC.IO.Encoding.UTF16 (mkUTF16le)
61+
import qualified System.Win32.WindowsString.Info as WS
62+
#endif
63+
5564
-- | Open a file and return the 'Handle'.
5665
openFile :: WindowsPath -> IOMode -> IO Handle
57-
openFile fp iomode = bracketOnError
66+
openFile fp' iomode = (`ioeSetWsPath` fp') `modifyIOError` $ do
67+
fp <- furnishPath fp'
68+
bracketOnError
5869
(WS.createFile
5970
fp
6071
accessMode
@@ -104,7 +115,9 @@ writeShareMode =
104115

105116
-- | Open an existing file and return the 'Handle'.
106117
openExistingFile :: WindowsPath -> IOMode -> IO Handle
107-
openExistingFile fp iomode = bracketOnError
118+
openExistingFile fp' iomode = (`ioeSetWsPath` fp') `modifyIOError` $ do
119+
fp <- furnishPath fp'
120+
bracketOnError
108121
(WS.createFile
109122
fp
110123
accessMode
@@ -248,3 +261,154 @@ any_ = coerce BC.any
248261

249262
#endif
250263

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

0 commit comments

Comments
 (0)