Skip to content

Commit 6767c5e

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

File tree

3 files changed

+219
-13
lines changed

3 files changed

+219
-13
lines changed

‎file-io.cabal

+11-1
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
@@ -111,6 +119,8 @@ test-suite Properties
111119
main-is: Properties.hs
112120
type: exitcode-stdio-1.0
113121
default-language: Haskell2010
114-
build-depends: base >=4.13.0.0 && <5, bytestring, tasty, tasty-hunit, file-io, filepath, temporary
122+
build-depends: base >=4.13.0.0 && <5, bytestring, directory, 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

+33-1
Original file line numberDiff line numberDiff line change
@@ -18,12 +18,21 @@ import GHC.IO.Exception (IOErrorType(..), IOException(..))
1818
import System.IO
1919
import System.IO.Temp
2020
import qualified Data.ByteString as BS
21+
#if defined(LONG_PATHS)
22+
import Control.Monad (when)
23+
import System.Directory.OsPath (createDirectory)
24+
import System.IO.Error (catchIOError)
25+
#endif
2126

2227

2328
main :: IO ()
2429
main = defaultMain $ testGroup "All"
2530
[ testGroup "System.File.OsPath"
26-
[ testCase "readFile . writeFile" writeFileReadFile
31+
[
32+
#if defined(LONG_PATHS)
33+
testCase "writeFile (very long path)" writeFileLongPath,
34+
#endif
35+
testCase "readFile . writeFile" writeFileReadFile
2736
, testCase "readFile . writeFile . writeFile" writeWriteFileReadFile
2837
, testCase "readFile . appendFile . writeFile" appendFileReadFile
2938
, testCase "iomode: ReadFile does not allow write" iomodeReadFile
@@ -56,6 +65,29 @@ main = defaultMain $ testGroup "All"
5665
]
5766
]
5867

68+
#if defined(LONG_PATHS)
69+
writeFileLongPath :: Assertion
70+
writeFileLongPath = do
71+
withSystemTempDirectory "test" $ \baseDir' -> do
72+
baseDir <- OSP.encodeFS baseDir'
73+
let longName = mconcat (replicate 10 [osp|its_very_long|])
74+
let longDir = baseDir </> longName </> longName
75+
76+
supportsLongPaths <- do
77+
-- create 2 dirs because 1 path segment by itself can't exceed MAX_PATH
78+
-- tests: [createDirectory]
79+
createDirectory (baseDir </> longName)
80+
createDirectory longDir
81+
return True
82+
`catchIOError` \ _ ->
83+
return False
84+
85+
when supportsLongPaths $ do
86+
OSP.writeFile (longDir </> [osp|foo|]) "test"
87+
contents <- OSP.readFile (longDir </> [osp|foo|])
88+
"test" @=? contents
89+
#endif
90+
5991
writeFileReadFile :: Assertion
6092
writeFileReadFile = do
6193
withSystemTempDirectory "test" $ \baseDir' -> do

‎windows/System/File/Platform.hsc

+175-11
Original file line numberDiff line numberDiff line change
@@ -12,7 +12,6 @@ import System.OsPath.Windows ( WindowsPath )
1212
import qualified System.OsPath.Windows as WS
1313
import Foreign.C.Types
1414

15-
import qualified System.OsString.Windows as WS hiding (decodeFS)
1615
import System.OsString.Windows ( encodeUtf, WindowsString )
1716
import qualified System.Win32 as Win32
1817
import qualified System.Win32.WindowsString.File as WS
@@ -43,18 +42,29 @@ import Text.Printf (printf)
4342

4443
#if MIN_VERSION_filepath(1, 5, 0)
4544
import System.OsString.Encoding
46-
import "os-string" System.OsString.Internal.Types (WindowsString(..), WindowsChar(..))
47-
import qualified "os-string" System.OsString.Data.ByteString.Short as BC
4845
#else
4946
import Data.Coerce (coerce)
5047
import System.OsPath.Encoding
5148
import "filepath" System.OsString.Internal.Types (WindowsString(..), WindowsChar(..))
5249
import qualified "filepath" System.OsPath.Data.ByteString.Short.Word16 as BC
5350
#endif
5451

52+
import System.IO.Error (modifyIOError, ioeSetFileName)
53+
import GHC.IO.Encoding.UTF16 (mkUTF16le)
54+
import GHC.IO.Encoding.Failure (CodingFailureMode(TransliterateCodingFailure))
55+
import Control.Exception (displayException, Exception)
56+
57+
#if defined(LONG_PATHS)
58+
import System.IO.Error (ioeSetLocation, ioeGetLocation, catchIOError)
59+
import Data.Char (isAlpha, isAscii, toUpper)
60+
import qualified System.Win32.WindowsString.Info as WS
61+
#endif
62+
5563
-- | Open a file and return the 'Handle'.
5664
openFile :: WindowsPath -> IOMode -> IO Handle
57-
openFile fp iomode = bracketOnError
65+
openFile fp' iomode = (`ioeSetWsPath` fp') `modifyIOError` do
66+
fp <- furnishPath fp'
67+
bracketOnError
5868
(WS.createFile
5969
fp
6070
accessMode
@@ -104,7 +114,9 @@ writeShareMode =
104114

105115
-- | Open an existing file and return the 'Handle'.
106116
openExistingFile :: WindowsPath -> IOMode -> IO Handle
107-
openExistingFile fp iomode = bracketOnError
117+
openExistingFile fp' iomode = (`ioeSetWsPath` fp') `modifyIOError` do
118+
fp <- furnishPath fp'
119+
bracketOnError
108120
(WS.createFile
109121
fp
110122
accessMode
@@ -220,12 +232,12 @@ rand_string = do
220232
return $ WS.pack $ fmap (WS.unsafeFromChar) (printf "%x-%x-%x" r1 r2 r3)
221233

222234
lenientDecode :: WindowsString -> String
223-
lenientDecode ws = let utf16le' = WS.decodeWith utf16le_b ws
224-
ucs2' = WS.decodeWith ucs2le ws
225-
in case (utf16le', ucs2') of
226-
(Right s, ~_) -> s
227-
(_, Right s) -> s
228-
(Left _, Left _) -> error "lenientDecode: failed to decode"
235+
lenientDecode wstr = let utf16le' = WS.decodeWith utf16le_b wstr
236+
ucs2' = WS.decodeWith ucs2le wstr
237+
in case (utf16le', ucs2') of
238+
(Right s, ~_) -> s
239+
(_, Right s) -> s
240+
(Left _, Left _) -> error "lenientDecode: failed to decode"
229241

230242

231243
toHandle :: WindowsPath -> IOMode -> Win32.HANDLE -> IO Handle
@@ -248,3 +260,155 @@ any_ = coerce BC.any
248260

249261
#endif
250262

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