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