@@ -52,9 +52,20 @@ import "filepath" System.OsString.Internal.Types (WindowsString(..), WindowsChar
52
52
import qualified "filepath" System.OsPath.Data.ByteString.Short.Word16 as BC
53
53
#endif
54
54
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
+
55
64
-- | Open a file and return the 'Handle'.
56
65
openFile :: WindowsPath -> IOMode -> IO Handle
57
- openFile fp iomode = bracketOnError
66
+ openFile fp' iomode = (`ioeSetWsPath` fp') `modifyIOError` $ do
67
+ fp <- furnishPath fp'
68
+ bracketOnError
58
69
(WS. createFile
59
70
fp
60
71
accessMode
@@ -104,7 +115,9 @@ writeShareMode =
104
115
105
116
-- | Open an existing file and return the 'Handle'.
106
117
openExistingFile :: WindowsPath -> IOMode -> IO Handle
107
- openExistingFile fp iomode = bracketOnError
118
+ openExistingFile fp' iomode = (`ioeSetWsPath` fp') `modifyIOError` $ do
119
+ fp <- furnishPath fp'
120
+ bracketOnError
108
121
(WS. createFile
109
122
fp
110
123
accessMode
@@ -248,3 +261,155 @@ any_ = coerce BC.any
248
261
249
262
#endif
250
263
264
+ -- inlined stuff from directory package
265
+ furnishPath :: WindowsPath -> IO WindowsPath
266
+ #if !defined(LONG_PATHS)
267
+ furnishPath path = pure path
268
+ #else
269
+ furnishPath path =
270
+ (toExtendedLengthPath <$> rawPrependCurrentDirectory path)
271
+ `catchIOError` \ _ ->
272
+ pure path
273
+
274
+ toExtendedLengthPath :: WindowsPath -> WindowsPath
275
+ toExtendedLengthPath path =
276
+ if WS. isRelative path
277
+ then simplifiedPath
278
+ else
279
+ case WS. toChar <$> simplifiedPath' of
280
+ ' \\ ' : ' ?' : ' ?' : ' \\ ' : _ -> simplifiedPath
281
+ ' \\ ' : ' \\ ' : ' ?' : ' \\ ' : _ -> simplifiedPath
282
+ ' \\ ' : ' \\ ' : ' .' : ' \\ ' : _ -> simplifiedPath
283
+ ' \\ ' : ' \\ ' : _ ->
284
+ ws " \\\\ ?\\ UNC" <> WS. pack (drop 1 simplifiedPath')
285
+ _ -> ws " \\\\ ?\\ " <> simplifiedPath
286
+ where simplifiedPath = simplifyWindows path
287
+ simplifiedPath' = WS. unpack simplifiedPath
288
+
289
+ rawPrependCurrentDirectory :: WindowsPath -> IO WindowsPath
290
+ rawPrependCurrentDirectory path
291
+ | WS. isRelative path =
292
+ ((`ioeAddLocation` " prependCurrentDirectory" ) .
293
+ (`ioeSetWsPath` path)) `modifyIOError` do
294
+ getFullPathName path
295
+ | otherwise = pure path
296
+
297
+ simplifyWindows :: WindowsPath -> WindowsPath
298
+ simplifyWindows path
299
+ | path == mempty = mempty
300
+ | drive' == ws " \\\\ ?\\ " = drive' <> subpath
301
+ | otherwise = simplifiedPath
302
+ where
303
+ simplifiedPath = WS. joinDrive drive' subpath'
304
+ (drive, subpath) = WS. splitDrive path
305
+ drive' = upperDrive (normaliseTrailingSep (normalisePathSeps drive))
306
+ subpath' = appendSep . avoidEmpty . prependSep . WS. joinPath .
307
+ stripPardirs . expandDots . skipSeps .
308
+ WS. splitDirectories $ subpath
309
+
310
+ upperDrive d = case WS. unpack d of
311
+ c : k : s
312
+ | isAlpha (WS. toChar c), WS. toChar k == ' :' , all WS. isPathSeparator s ->
313
+ -- unsafeFromChar is safe here since all characters are ASCII.
314
+ WS. pack (WS. unsafeFromChar (toUpper (WS. toChar c)) : WS. unsafeFromChar ' :' : s)
315
+ _ -> d
316
+ skipSeps =
317
+ (WS. pack <$> ) .
318
+ filter (not . (`elem` (pure <$> WS. pathSeparators))) .
319
+ (WS. unpack <$> )
320
+ stripPardirs | pathIsAbsolute || subpathIsAbsolute = dropWhile (== ws " .." )
321
+ | otherwise = id
322
+ prependSep | subpathIsAbsolute = (WS. pack [WS. pathSeparator] <> )
323
+ | otherwise = id
324
+ avoidEmpty | not pathIsAbsolute
325
+ , drive == mempty || hasTrailingPathSep -- prefer "C:" over "C:."
326
+ = emptyToCurDir
327
+ | otherwise = id
328
+ appendSep p | hasTrailingPathSep, not (pathIsAbsolute && p == mempty )
329
+ = WS. addTrailingPathSeparator p
330
+ | otherwise = p
331
+ pathIsAbsolute = not (WS. isRelative path)
332
+ subpathIsAbsolute = any WS. isPathSeparator (take 1 (WS. unpack subpath))
333
+ hasTrailingPathSep = WS. hasTrailingPathSeparator subpath
334
+
335
+ expandDots :: [WindowsPath ] -> [WindowsPath ]
336
+ expandDots = reverse . go []
337
+ where
338
+ go ys' xs' =
339
+ case xs' of
340
+ [] -> ys'
341
+ x : xs
342
+ | x == ws " ." -> go ys' xs
343
+ | x == ws " .." ->
344
+ case ys' of
345
+ [] -> go (x : ys') xs
346
+ y : ys
347
+ | y == ws " .." -> go (x : ys') xs
348
+ | otherwise -> go ys xs
349
+ | otherwise -> go (x : ys') xs
350
+
351
+ -- | Remove redundant trailing slashes and pick the right kind of slash.
352
+ normaliseTrailingSep :: WindowsPath -> WindowsPath
353
+ normaliseTrailingSep path = do
354
+ let path' = reverse (WS. unpack path)
355
+ let (sep, path'') = span WS. isPathSeparator path'
356
+ let addSep = if null sep then id else (WS. pathSeparator : )
357
+ WS. pack (reverse (addSep path''))
358
+
359
+ normalisePathSeps :: WindowsPath -> WindowsPath
360
+ normalisePathSeps p = WS. pack (normaliseChar <$> WS. unpack p)
361
+ where normaliseChar c = if WS. isPathSeparator c then WS. pathSeparator else c
362
+
363
+ emptyToCurDir :: WindowsPath -> WindowsPath
364
+ emptyToCurDir path
365
+ | path == mempty = ws " ."
366
+ | otherwise = path
367
+
368
+ ws :: String -> WindowsString
369
+ ws = rightOrError . WS. encodeUtf
370
+
371
+ rightOrError :: Exception e => Either e a -> a
372
+ rightOrError (Left e) = error (displayException e)
373
+ rightOrError (Right a) = a
374
+
375
+ getFullPathName :: WindowsPath -> IO WindowsPath
376
+ getFullPathName path =
377
+ fromExtendedLengthPath <$> WS. getFullPathName (toExtendedLengthPath path)
378
+
379
+ ioeSetWsPath :: IOError -> WindowsPath -> IOError
380
+ ioeSetWsPath err =
381
+ ioeSetFileName err .
382
+ rightOrError .
383
+ WS. decodeWith (mkUTF16le TransliterateCodingFailure )
384
+
385
+ ioeAddLocation :: IOError -> String -> IOError
386
+ ioeAddLocation e loc = do
387
+ ioeSetLocation e newLoc
388
+ where
389
+ newLoc = loc <> if null oldLoc then " " else " :" <> oldLoc
390
+ oldLoc = ioeGetLocation e
391
+
392
+ fromExtendedLengthPath :: WindowsPath -> WindowsPath
393
+ fromExtendedLengthPath ePath =
394
+ case WS. unpack ePath of
395
+ c1 : c2 : c3 : c4 : path
396
+ | (WS. toChar <$> [c1, c2, c3, c4]) == " \\\\ ?\\ " ->
397
+ case path of
398
+ c5 : c6 : c7 : subpath@ (c8 : _)
399
+ | (WS. toChar <$> [c5, c6, c7, c8]) == " UNC\\ " ->
400
+ WS. pack (c8 : subpath)
401
+ drive : col : subpath
402
+ -- if the path is not "regular", then the prefix is necessary
403
+ -- to ensure the path is interpreted literally
404
+ | WS. toChar col == ' :' , isDriveChar drive, isPathRegular subpath ->
405
+ WS. pack path
406
+ _ -> ePath
407
+ _ -> ePath
408
+ where
409
+ isDriveChar drive = isAlpha (WS. toChar drive) && isAscii (WS. toChar drive)
410
+ isPathRegular path =
411
+ not (' /' `elem` (WS. toChar <$> path) ||
412
+ ws " ." `elem` WS. splitDirectories (WS. pack path) ||
413
+ ws " .." `elem` WS. splitDirectories (WS. pack path))
414
+
415
+ #endif
0 commit comments