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