Skip to content

Commit

Permalink
Backport bugfix for splitFileName on windows
Browse files Browse the repository at this point in the history
Wrt #219
  • Loading branch information
hasufell committed Feb 18, 2024
1 parent 367f6bf commit 4316832
Show file tree
Hide file tree
Showing 4 changed files with 42 additions and 11 deletions.
45 changes: 35 additions & 10 deletions System/FilePath/Internal.hs
Original file line number Diff line number Diff line change
@@ -1,5 +1,6 @@
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE MultiWayIf #-}

-- This template expects CPP definitions for:
-- MODULE_NAME = Posix | Windows
Expand Down Expand Up @@ -602,6 +603,7 @@ isDrive x = not (null x) && null (dropDrive x)
-- > Posix: splitFileName "/" == ("/","")
-- > Windows: splitFileName "c:" == ("c:","")
-- > Windows: splitFileName "\\\\?\\A:\\fred" == ("\\\\?\\A:\\","fred")
-- > Windows: splitFileName "\\\\?\\A:" == ("\\\\?\\A:","")
splitFileName :: FILEPATH -> (STRING, STRING)
splitFileName x = if null path
then (dotSlash, file)
Expand Down Expand Up @@ -644,20 +646,43 @@ splitFileName_ fp
-- or UNC location "\\?\UNC\foo", where path separator is a part of the drive name.
-- We can test this by trying dropDrive and falling back to splitDrive.
| isWindows
, Just (s1, _s2, bs') <- uncons2 dirSlash
, isPathSeparator s1
-- If bs' is empty, then s2 as the last character of dirSlash must be a path separator,
-- so we are in the middle of shared drive.
-- Otherwise, since s1 is a path separator, we might be in the middle of UNC path.
, null bs' || maybe False isIncompleteUNC (readDriveUNC dirSlash)
= (fp, mempty)
= case uncons2 dirSlash of
Just (s1, s2, bs')
| isPathSeparator s1
-- If bs' is empty, then s2 as the last character of dirSlash must be a path separator,
-- so we are in the middle of shared drive.
-- Otherwise, since s1 is a path separator, we might be in the middle of UNC path.
, null bs' || maybe False isIncompleteUNC (readDriveUNC dirSlash)
-> (fp, mempty)
-- This handles inputs like "//?/A:" and "//?/A:foo"
| isPathSeparator s1
, isPathSeparator s2
, Just (s3, s4, bs'') <- uncons2 bs'
, s3 == _question
, isPathSeparator s4
, null bs''
, Just (drive, rest) <- readDriveLetter file
-> (dirSlash <> drive, rest)
_ -> (dirSlash, file)
| otherwise
= (dirSlash, file)
= (dirSlash, file)
where
(dirSlash, file) = breakEnd isPathSeparator fp

dropExcessTrailingPathSeparators x
| hasTrailingPathSeparator x
, let x' = dropWhileEnd isPathSeparator x
, otherwise = if | null x' -> singleton (last x)
| otherwise -> addTrailingPathSeparator x'
| otherwise = x

-- an "incomplete" UNC is one without a path (but potentially a drive)
isIncompleteUNC (pref, suff) = null suff && not (hasPenultimateColon pref)
hasPenultimateColon = maybe False (maybe False ((== _colon) . snd) . unsnoc . fst) . unsnoc

-- e.g. @//?/a:/@ or @//?/a://@, but not @//?/a:@
hasPenultimateColon pref
| hasTrailingPathSeparator pref
= maybe False (maybe False ((== _colon) . snd) . unsnoc . fst) . unsnoc . dropExcessTrailingPathSeparators $ pref
| otherwise = False

-- | Set the filename.
--
Expand Down
4 changes: 4 additions & 0 deletions changelog.md
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,10 @@

_Note: below all `FilePath` values are unquoted, so `\\` really means two backslashes._

## 1.4.101.0. *Jan 2024*

* Backport bugfix for [`splitFileName`](https://github.com/haskell/filepath/issues/219) on windows

## 1.4.100.4 *Jul 2023*

* Fix isInfixOf and breakSubString in Word16, wrt [#195](https://github.com/haskell/filepath/issues/195)
Expand Down
2 changes: 1 addition & 1 deletion filepath.cabal
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
cabal-version: 2.2
name: filepath
version: 1.4.100.4
version: 1.4.101.0

-- NOTE: Don't forget to update ./changelog.md
license: BSD-3-Clause
Expand Down
2 changes: 2 additions & 0 deletions tests/filepath-tests/TestGen.hs
Original file line number Diff line number Diff line change
Expand Up @@ -458,6 +458,8 @@ tests =
,("AFP_W.splitFileName (\"c:\") == ((\"c:\"), (\"\"))", property $ AFP_W.splitFileName ("c:") == (("c:"), ("")))
,("W.splitFileName \"\\\\\\\\?\\\\A:\\\\fred\" == (\"\\\\\\\\?\\\\A:\\\\\", \"fred\")", property $ W.splitFileName "\\\\?\\A:\\fred" == ("\\\\?\\A:\\", "fred"))
,("AFP_W.splitFileName (\"\\\\\\\\?\\\\A:\\\\fred\") == ((\"\\\\\\\\?\\\\A:\\\\\"), (\"fred\"))", property $ AFP_W.splitFileName ("\\\\?\\A:\\fred") == (("\\\\?\\A:\\"), ("fred")))
,("W.splitFileName \"\\\\\\\\?\\\\A:\" == (\"\\\\\\\\?\\\\A:\", \"\")", property $ W.splitFileName "\\\\?\\A:" == ("\\\\?\\A:", ""))
,("AFP_W.splitFileName (\"\\\\\\\\?\\\\A:\") == ((\"\\\\\\\\?\\\\A:\"), (\"\"))", property $ AFP_W.splitFileName ("\\\\?\\A:") == (("\\\\?\\A:"), ("")))
,("P.replaceFileName \"/directory/other.txt\" \"file.ext\" == \"/directory/file.ext\"", property $ P.replaceFileName "/directory/other.txt" "file.ext" == "/directory/file.ext")
,("W.replaceFileName \"/directory/other.txt\" \"file.ext\" == \"/directory/file.ext\"", property $ W.replaceFileName "/directory/other.txt" "file.ext" == "/directory/file.ext")
,("AFP_P.replaceFileName (\"/directory/other.txt\") (\"file.ext\") == (\"/directory/file.ext\")", property $ AFP_P.replaceFileName ("/directory/other.txt") ("file.ext") == ("/directory/file.ext"))
Expand Down

0 comments on commit 4316832

Please sign in to comment.