@@ -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,29 @@ 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
48
import "filepath" System.OsString.Internal.Types (WindowsString (.. ), WindowsChar (.. ))
52
49
import qualified "filepath" System.OsPath.Data.ByteString.Short.Word16 as BC
53
50
#endif
54
51
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
+
55
63
-- | Open a file and return the 'Handle'.
56
64
openFile :: WindowsPath -> IOMode -> IO Handle
57
- openFile fp iomode = bracketOnError
65
+ openFile fp' iomode = (`ioeSetWsPath` fp') `modifyIOError` do
66
+ fp <- furnishPath fp'
67
+ bracketOnError
58
68
(WS. createFile
59
69
fp
60
70
accessMode
@@ -104,7 +114,9 @@ writeShareMode =
104
114
105
115
-- | Open an existing file and return the 'Handle'.
106
116
openExistingFile :: WindowsPath -> IOMode -> IO Handle
107
- openExistingFile fp iomode = bracketOnError
117
+ openExistingFile fp' iomode = (`ioeSetWsPath` fp') `modifyIOError` do
118
+ fp <- furnishPath fp'
119
+ bracketOnError
108
120
(WS. createFile
109
121
fp
110
122
accessMode
@@ -220,12 +232,12 @@ rand_string = do
220
232
return $ WS. pack $ fmap (WS. unsafeFromChar) (printf " %x-%x-%x" r1 r2 r3)
221
233
222
234
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"
229
241
230
242
231
243
toHandle :: WindowsPath -> IOMode -> Win32. HANDLE -> IO Handle
@@ -248,3 +260,155 @@ any_ = coerce BC.any
248
260
249
261
#endif
250
262
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