From cce03c5e0f589d00f528645402cc609d62ed0a72 Mon Sep 17 00:00:00 2001 From: Harendra Kumar Date: Sun, 17 May 2026 09:04:12 +0530 Subject: [PATCH] Make UNC share name part of root in splitRoot splitRoot for a Windows UNC path now returns the entire \\server\share (or \\?\UNC\server\share) as the root, instead of treating the share name as the first component of path body. This makes the root self-contained and fixes the case-folding gap noted in f3b293c2f: the share name follows the root's case-insensitivity rule, not the body's. - splitRoot: for UNC paths, split point moves past the share name. - validatePath: a UNC path must now have a non-empty server and share separated by exactly one separator. Paths like "\\x\" (server only) are rejected. A valid share root itself remains a valid path under validatePath' since it is a listable directory. - eqPath / normalise: the entire UNC root (server + share) is folded case-insensitively; the share no longer follows ignoreCase. - Verbatim "\\?\..." paths still bypass all normalisation byte-for-byte. --- .../Internal/FileSystem/Path/Common.hs | 151 ++++++++++++------ .../Streamly/Internal/FileSystem/PosixPath.hs | 31 ++-- .../Internal/FileSystem/WindowsPath.hs | 40 ++--- test/Streamly/Test/FileSystem/WindowsPath.hs | 50 +++--- 4 files changed, 162 insertions(+), 110 deletions(-) diff --git a/core/src/Streamly/Internal/FileSystem/Path/Common.hs b/core/src/Streamly/Internal/FileSystem/Path/Common.hs index 4c24fb45ae..642274a74a 100644 --- a/core/src/Streamly/Internal/FileSystem/Path/Common.hs +++ b/core/src/Streamly/Internal/FileSystem/Path/Common.hs @@ -772,7 +772,75 @@ parseSegment arr sepOff = (segOff, segCnt) -- should not add another separator between root and path - thus joining root -- and path in this case is anyway special. --- | Split a path prefixed with "\\" into (drive, path) tuple. +-- | Parse a UNC-prefixed path. Caller must ensure 'isAbsoluteUNC' holds. +-- Returns @(splitOffset, isStructuralUNC, wellFormed)@: +-- +-- * @splitOffset@: first byte after the share name (or after the segment +-- following @\\\\?\\@ for raw verbatim paths). This is the split point +-- used by 'unsafeSplitUNC'. +-- +-- * @isStructuralUNC@: 'True' for paths whose root has the +-- @\\\\server\\share@ shape — either non-verbatim +-- (@\\\\server\\share[\\...]@) or verbatim +-- (@\\\\?\\UNC\\server\\share[\\...]@). 'False' for raw verbatim paths +-- that do not name a network share (e.g. @\\\\?\\C:\\...@, @\\\\.\\x@, +-- @\\\\??\\x@). +-- +-- * @wellFormed@: for structural UNC paths, 'True' iff the server and +-- share names are both non-empty and separated by exactly one +-- separator. For raw verbatim paths the share rule does not apply and +-- this is always 'True'. +unsafeParseUNCEnd :: (Unbox a, Integral a) => Array a -> (Int, Bool, Bool) +unsafeParseUNCEnd arr = + if cnt1 == 1 && unsafeIndexChar 2 arr == '?' + then + -- XXX Should mixed-case markers like "UnC" be accepted as the UNC + -- variant too? Currently only exact uppercase "UNC" is matched, so + -- "\\?\UnC\srv\share\x" falls through to the raw-verbatim branch + -- (where the server+share rule does not apply). The alternative + -- is to either match case-insensitively here, or reject mixed-case + -- markers outright in validatePath. Write test cases for whichever + -- choice we settle on. + if uncLen == 3 + && unsafeIndexChar uncOff arr == 'U' + && unsafeIndexChar (uncOff + 1) arr == 'N' + && unsafeIndexChar (uncOff + 2) arr == 'C' + then + -- \\?\UNC\server\share\... + let sepStart = serverOff + serverLen + (shareOff, shareLen) = parseSegment arr sepStart + in ( shareOff + shareLen + , True + , serverLen > 0 + && shareLen > 0 + && shareOff - sepStart == 1 + ) + else + -- \\?\... (raw verbatim, e.g. \\?\C:\...) + (sepOff1, False, True) + else + -- \\server\share\... + let (shareOff, shareLen) = parseSegment arr sepOff + in ( shareOff + shareLen + , True + , cnt1 > 0 + && shareLen > 0 + && shareOff - sepOff == 1 + ) + + where + + arr1 = snd $ Array.unsafeBreakAt 2 arr + cnt1 = countLeadingBy (not . isSeparatorWord Windows) arr1 + sepOff = 2 + cnt1 + + -- XXX it should either be UNC or two letter drive in a valid path + (uncOff, uncLen) = parseSegment arr sepOff + sepOff1 = uncOff + uncLen + (serverOff, serverLen) = parseSegment arr sepOff1 + +-- | Split a path prefixed with "\\" into (drive, path) tuple. The share +-- name (where present) is treated as part of the root. -- -- >>> toList (a,b) = (unpackPosix a, unpackPosix b) -- >>> split = toList . Common.unsafeSplitUNC . packPosix @@ -789,8 +857,11 @@ parseSegment arr sepOff = (segOff, segCnt) -- >>> split "\\\\server\\" -- ("\\\\server\\","") -- --- >>> split "\\\\server\\home" --- ("\\\\server\\","home") +-- >>> split "\\\\server\\share" +-- ("\\\\server\\share","") +-- +-- >>> split "\\\\server\\share\\home" +-- ("\\\\server\\share\\","home") -- -- >>> split "\\\\?\\c:" -- ("\\\\?\\c:","") @@ -807,32 +878,16 @@ parseSegment arr sepOff = (segOff, segCnt) -- >>> split "\\\\?\\UNC\\server" -- ("\\\\?\\UNC\\server","") -- --- >>> split "\\\\?\\UNC/server\\home" --- ("\\\\?\\UNC/server\\","home") +-- >>> split "\\\\?\\UNC/server\\share" +-- ("\\\\?\\UNC/server\\share","") +-- +-- >>> split "\\\\?\\UNC/server\\share\\home" +-- ("\\\\?\\UNC/server\\share\\","home") -- unsafeSplitUNC :: (Unbox a, Integral a) => Array a -> (Array a, Array a) unsafeSplitUNC arr = - if cnt1 == 1 && unsafeIndexChar 2 arr == '?' - then do - if uncLen == 3 - && unsafeIndexChar uncOff arr == 'U' - && unsafeIndexChar (uncOff + 1) arr == 'N' - && unsafeIndexChar (uncOff + 2) arr == 'C' - then unsafeSplitPrefix Windows (serverOff + serverLen) arr - else unsafeSplitPrefix Windows sepOff1 arr - else unsafeSplitPrefix Windows sepOff arr - - where - - arr1 = snd $ Array.unsafeBreakAt 2 arr - cnt1 = countLeadingBy (not . isSeparatorWord Windows) arr1 - sepOff = 2 + cnt1 - - -- XXX there should be only one separator in a valid path? - -- XXX it should either be UNC or two letter drive in a valid path - (uncOff, uncLen) = parseSegment arr sepOff - sepOff1 = uncOff + uncLen - (serverOff, serverLen) = parseSegment arr sepOff1 + let (off, _, _) = unsafeParseUNCEnd arr + in unsafeSplitPrefix Windows off arr -- XXX should we make the root Maybe? Both components will have to be Maybe to -- avoid an empty path. @@ -1333,7 +1388,7 @@ validatePathWith _ Posix path = then throwM $ InvalidPath $ "Null char found after " ++ show validLen ++ " characters." else pure () -validatePathWith allowRoot Windows path +validatePathWith _allowRoot Windows path | Array.null path = throwM $ InvalidPath "Empty path" | otherwise = do if hasDrive path && postDriveSep > 1 -- "C://" @@ -1348,13 +1403,17 @@ validatePathWith allowRoot Windows path then throwM $ InvalidPath -- XXX print the invalid component name "Special filename component found in share root" - else if rootEndSeps /= 1 -- "//share//x" + else if isStructuralUNC && not uncWellFormed -- "//x", "//x/" + then throwM $ InvalidPath + $ "A UNC path must have both a server and a share name " + ++ "separated by a single separator" + else if isStructuralUNC && rootEndSeps > 1 -- "//x/y//z" then throwM $ InvalidPath - $ "Share name is needed and exactly one separator is needed " - ++ "after the share root" - else if not allowRoot && Array.null stem -- "//share/" + "At most one separator is allowed after the share name" + else if not isStructuralUNC && rootEndSeps /= 1 -- "\\\\?\\c:x" then throwM $ InvalidPath - "the share root must be followed by a non-empty path" + $ "Exactly one separator is needed after the verbatim " + ++ "prefix segment" else pure () else pure () @@ -1384,6 +1443,10 @@ validatePathWith allowRoot Windows path rootEndSeps = countTrailingBy (isSeparatorWord Windows) root + -- Defined only when isAbsoluteUNC path holds; the only use sites below + -- are guarded by 'isAbsoluteUNC path' so it is fine to evaluate lazily. + (_, isStructuralUNC, uncWellFormed) = unsafeParseUNCEnd path + -- TBD: We are not currently validating the sharenames against disallowed -- file names. Apparently windows does not allow even sharenames with those -- names. To match against sharenames we will have to strip the separators @@ -1869,22 +1932,14 @@ isVerbatimRoot a = -- not be a plain root. If not then this function will not work correctly e.g. -- it might change \/ to // making the path a share name from a normal path. -- --- The drive letter (and the UNC server name that 'splitRoot' returns as the --- root) is always compared case-insensitively. Verbatim @\\\\?\\@ paths are --- compared byte-for-byte with no normalisation. --- --- Note: 'splitRoot' currently treats the UNC share name as the first body --- component, not as part of the root. The share name therefore follows the --- body's 'ignoreCase' rule, not this root-only rule. +-- The drive letter and the full UNC root (server and share name that +-- 'splitRoot' returns) are always compared case-insensitively. Verbatim +-- @\\\\?\\@ paths are compared byte-for-byte with no normalisation. eqWindowsRootWithDrive :: (Unbox a, Integral a) => Array a -> Array a -> Bool eqWindowsRootWithDrive a b | isVerbatimRoot a || isVerbatimRoot b = Array.byteEq a b | otherwise = - -- XXX We probably do not want to translate UnC etc. to UNC. - -- Such a path should either be rejected in splitRoot or we - -- should not translate that here. - -- XXX if so write test cases for that. let f = normalizeCaseAndSeparators . Array.unsafeCast in runIdentity $ Stream.eqBy (==) (f a) (f b) @@ -2009,10 +2064,8 @@ eqPath decoder os eqCfg@(EqCfg{..}) a b -- Canonicalisation rules: -- -- * Drive root: the drive letter is upper-cased (e.g. @c:\\@ -> @C:\\@). --- * UNC root: the root (currently just the server name) is lower-cased --- (e.g. @\\\\Server\\@ -> @\\\\server\\@). The share name is treated as --- the first body component by 'splitRoot' and is normalised by --- 'normaliseComponents' instead. +-- * UNC root: the entire root (server and share name) is lower-cased +-- (e.g. @\\\\Server\\Share\\@ -> @\\\\server\\share\\@). -- * Verbatim @\\\\?\\@ device paths are left untouched. -- -- Separators in non-verbatim roots are normalised to the primary separator. @@ -2021,10 +2074,6 @@ normaliseWindowsDriveRoot :: (Unbox a, Integral a) => normaliseWindowsDriveRoot a | isVerbatimRoot a = a | isAbsoluteUNC a = - -- XXX We probably do not want to translate UnC etc. to UNC. - -- Such a path should either be rejected in splitRoot or we - -- should not translate that here. - -- XXX if so write test cases for that. Array.fromPureStream $ fmap charToWord $ normalizeLowerCaseAndSeparators diff --git a/core/src/Streamly/Internal/FileSystem/PosixPath.hs b/core/src/Streamly/Internal/FileSystem/PosixPath.hs index 60a60471dd..c2f7d14393 100644 --- a/core/src/Streamly/Internal/FileSystem/PosixPath.hs +++ b/core/src/Streamly/Internal/FileSystem/PosixPath.hs @@ -534,6 +534,7 @@ addTrailingSeparator p@(OS_PATH _arr) = -- False -- -- Mixing path separators: +-- -- >>> isValid "/x\\y" -- True -- >>> isValid "\\/" -- ? @@ -558,7 +559,7 @@ addTrailingSeparator p@(OS_PATH _arr) = -- >>> isValid "\\\\x" -- False -- >>> isValid "\\\\x\\" --- True +-- False -- >>> isValid "\\\\x\\y" -- True -- >>> isValid "//x/y" @@ -593,7 +594,7 @@ addTrailingSeparator p@(OS_PATH _arr) = -- -- >>> isValid "\\\\?\\UnC\\x" -- UnC treated as share name -- True --- >>> isValid "\\\\?\\UNC\\x" -- XXX fix +-- >>> isValid "\\\\?\\UNC\\x" -- server x but no share -- False -- >>> isValid "\\\\?\\UNC\\c:\\x" -- True @@ -1042,6 +1043,10 @@ unsafeJoinPaths = undefined -- Splitting path ------------------------------------------------------------------------------ +-- NOTE: definition of a path root. A root is a valid directory path, its +-- contents can be listed. A root does not have a parent directory. +-- TODO: add a short definition of root in splitRoot. + #ifndef IS_WINDOWS -- | If a path is rooted then separate the root and the remaining path, -- otherwise return 'Nothing'. The non-root @@ -1531,10 +1536,9 @@ ignoreTrailingSeparators val conf = conf { _ignoreTrailingSeparators = val } -- | When set to 'False', comparison is case sensitive. -- -- On Windows this flag controls only the case-sensitivity of non-root path --- segments. The drive letter (and the UNC server name that 'splitRoot' --- returns as the root) is /always/ compared case-insensitively. The UNC --- share name is currently treated as a body segment and so follows this --- flag. Verbatim @\\\\?\\@ paths are always compared case-sensitively +-- segments. The drive letter and the full UNC root (server and share name +-- that 'splitRoot' returns) are /always/ compared case-insensitively. +-- Verbatim @\\\\?\\@ paths are always compared case-sensitively -- (byte-for-byte), independent of this flag. -- -- /Default/: False @@ -1740,11 +1744,11 @@ collapseDotDots (OS_PATH p) = #else -- | Convert the path to an equivalent but standard format for reliable -- comparison. Collapses redundant separators and removes @.@ components, --- normalises the root (drive letter upper-cased, UNC server name --- lower-cased, forward separators converted to backslash), and optionally --- folds case per the 'EqCfg' options. Verbatim @\\\\?\\@ paths are left --- untouched. Does /not/ collapse @..@ segments, as that is unsafe in the --- presence of symlinks. +-- normalises the root (drive letter upper-cased, UNC root — server and +-- share name — lower-cased, forward separators converted to backslash), +-- and optionally folds case per the 'EqCfg' options. Verbatim @\\\\?\\@ +-- paths are left untouched. Does /not/ collapse @..@ segments, as that is +-- unsafe in the presence of symlinks. -- -- A trailing separator is preserved unless 'ignoreTrailingSeparators' is set -- in the 'EqCfg'. @@ -1765,9 +1769,10 @@ collapseDotDots (OS_PATH p) = -- >>> f "c:\\x" -- "C:\\x" -- --- UNC server name is lower-cased; rest of the path follows ignoreCase: +-- UNC root (server and share name) is lower-cased; rest of the path +-- follows ignoreCase: -- --- >>> f "\\\\Server\\share\\x" +-- >>> f "\\\\Server\\Share\\x" -- "\\\\server\\share\\x" -- -- Verbatim paths are left untouched: diff --git a/core/src/Streamly/Internal/FileSystem/WindowsPath.hs b/core/src/Streamly/Internal/FileSystem/WindowsPath.hs index 1580fa6346..28938ed50c 100644 --- a/core/src/Streamly/Internal/FileSystem/WindowsPath.hs +++ b/core/src/Streamly/Internal/FileSystem/WindowsPath.hs @@ -16,9 +16,8 @@ -- -- XXX ADS - alternate data stream syntax - file.txt:stream . --- | Like 'validatePath' but more strict. The path must refer to a file system --- object. For example, a share root itself is not a valid file system object. --- it must be followed by a non-empty path. +-- | Like 'validatePath' but more strict. Currently equivalent to +-- 'validatePath' on Windows; reserved for future stricter checks. -- -- >>> isValid = isJust . Path.validatePath' . Path.encodeString -- @@ -117,14 +116,14 @@ isRooted (OS_PATH arr) = Common.isRooted Common.OS_NAME arr -- "x/y" -- -- Note "c:" and "/x" are both rooted paths, therefore, 'join' cannot be used --- to join them. Similarly for joining "//x/" and "/y". For these cases use +-- to join them. Similarly for joining "//x/y/" and "/z". For these cases use -- 'unsafeJoin'. 'unsafeJoin' can be used as a replacement for the -- joinDrive function from the filepath package. -- -- >>> f "c:" "/x" -- "c:/x" --- >>> f "//x/" "/y" --- "//x/y" +-- >>> f "//x/y/" "/z" +-- "//x/y/z" -- {-# INLINE unsafeJoin #-} unsafeJoin :: OS_PATH_TYPE -> OS_PATH_TYPE -> OS_PATH_TYPE @@ -143,7 +142,7 @@ unsafeJoin (OS_PATH a) (OS_PATH b) = -- the two because "c:x" is different from "c:/x". -- -- Note "c:" and "/x" are both rooted paths, therefore, 'join' cannot be used --- to join them. Similarly for joining "//x/" and "/y". For these cases use +-- to join them. Similarly for joining "//x/y/" and "/z". For these cases use -- 'unsafeJoin'. -- -- >>> f a b = Path.toString $ Path.join a b @@ -160,8 +159,8 @@ unsafeJoin (OS_PATH a) (OS_PATH b) = -- "\\x\\y" -- >>> f [path|c:/|] [path|y|] -- "c:/y" --- >>> f [path|//x/|] [path|y|] --- "//x/y" +-- >>> f [path|//x/y/|] [path|z|] +-- "//x/y/z" -- -- When second path is relative to current directory in a specific drive. -- TODO: fix these. @@ -195,7 +194,7 @@ unsafeJoin (OS_PATH a) (OS_PATH b) = -- True -- >>> fails $ f [path|x|] [path|/y|] -- True --- >>> fails $ f [path|//x/|] [path|/y|] +-- >>> fails $ f [path|//x/y/|] [path|/z|] -- True -- -- When second path is absolute. @@ -235,11 +234,9 @@ joinDir -- On Windows, the following is different: -- -- * forward slash and backslash are treated as equivalent path separators. --- * the drive letter (and the UNC server name) is /always/ compared --- case-insensitively, regardless of the 'ignoreCase' setting, because --- Windows file systems treat them as case-insensitive. The UNC share --- name is currently treated as a body component by 'splitRoot' and so --- still follows the 'ignoreCase' setting. +-- * the drive letter and the full UNC root (server and share name) are +-- /always/ compared case-insensitively, regardless of the 'ignoreCase' +-- setting, because Windows file systems treat them as case-insensitive. -- * verbatim @\\\\?\\@ device paths are compared byte-for-byte. They bypass -- all normalisation, including case folding, separator translation and -- trailing separator handling, regardless of the 'EqCfg' settings. @@ -348,11 +345,11 @@ eqPath cfg (OS_PATH a) (OS_PATH b) = -- >>> split "c:/" -- Just ("c:/",Nothing) -- --- >>> split "//x/" --- Just ("//x/",Nothing) --- -- >>> split "//x/y" --- Just ("//x/",Just "y") +-- Just ("//x/y",Nothing) +-- +-- >>> split "//x/y/z" +-- Just ("//x/y/",Just "z") -- splitRoot :: OS_PATH_TYPE -> Maybe (OS_PATH_TYPE, Maybe OS_PATH_TYPE) splitRoot (OS_PATH x) = @@ -379,7 +376,10 @@ splitRoot (OS_PATH x) = -- ["c:/","x"] -- -- >>> split "//x/y/" --- ["//x","y"] +-- ["//x/y"] +-- +-- >>> split "//x/y/z" +-- ["//x/y","z"] -- -- >>> split "./a" -- [".","a"] diff --git a/test/Streamly/Test/FileSystem/WindowsPath.hs b/test/Streamly/Test/FileSystem/WindowsPath.hs index 2e6441f1ab..4099f40028 100644 --- a/test/Streamly/Test/FileSystem/WindowsPath.hs +++ b/test/Streamly/Test/FileSystem/WindowsPath.hs @@ -132,17 +132,20 @@ testSplitRoot = describe "splitRoot" $ do let split = fmap toList . Path.splitRoot . p toList (a, b) = (str a, fmap str b) cases = - [ ("C:", Just ("C:", Nothing)) - , ("C:/", Just ("C:/", Nothing)) - , ("//x/", Just ("//x/", Nothing)) - , ("//x/y", Just ("//x/", Just "y")) + [ ("C:", Just ("C:", Nothing)) + , ("C:/", Just ("C:/", Nothing)) + -- UNC: share name is part of the root + , ("//x/y", Just ("//x/y", Nothing)) + , ("//x/y/", Just ("//x/y/", Nothing)) + , ("//x/y/z", Just ("//x/y/", Just "z")) -- Verbatim drive paths - , ("\\\\?\\c:\\", Just ("\\\\?\\c:\\", Nothing)) - , ("\\\\?\\c:\\home", - Just ("\\\\?\\c:\\", Just "home")) - -- Verbatim UNC paths + , ("\\\\?\\c:\\", Just ("\\\\?\\c:\\", Nothing)) + , ("\\\\?\\c:\\home", Just ("\\\\?\\c:\\", Just "home")) + -- Verbatim UNC paths: share name is part of the root , ("\\\\?\\UNC\\c:\\x", - Just ("\\\\?\\UNC\\c:\\", Just "x")) + Just ("\\\\?\\UNC\\c:\\x", Nothing)) + , ("\\\\?\\UNC\\srv\\share\\x", + Just ("\\\\?\\UNC\\srv\\share\\", Just "x")) ] mapM_ (\(input, expected) -> @@ -189,11 +192,8 @@ testEqPathDriveAlwaysIgnoresCase = eq "c:/x" "C:/x" `shouldBe` True it "UNC server name case-insensitive" $ eq "\\\\Server\\share\\x" "\\\\server\\share\\x" `shouldBe` True - -- Note: splitRoot currently treats the UNC share name as a body - -- component, so under default ignoreCase=False the share is - -- compared case-sensitively. - it "UNC share case follows ignoreCase (default sensitive)" $ - eq "\\\\server\\Share\\x" "\\\\server\\share\\x" `shouldBe` False + it "UNC share name case-insensitive (share is part of root)" $ + eq "\\\\server\\Share\\x" "\\\\server\\share\\x" `shouldBe` True it "Body case still respected with default" $ eq "C:/X" "C:/x" `shouldBe` False @@ -242,13 +242,10 @@ testNormalise = describe "normalise" $ do nrm "c:\\x" `shouldBe` "C:\\x" it "drive root only uppercased" $ nrm "c:" `shouldBe` "C:" - -- Note: splitRoot currently treats the UNC share as a body component, so - -- only the server is lowercased by the root normaliser; the share keeps - -- its case unless ignoreCase is also set. - it "UNC server lowercased; share kept (root-only normalisation)" $ - nrm "\\\\Server\\Share\\x" `shouldBe` "\\\\server\\Share\\x" - it "UNC server lowercased even when only root present" $ - nrm "\\\\Server\\Share\\" `shouldBe` "\\\\server\\Share\\" + it "UNC root (server and share) lowercased" $ + nrm "\\\\Server\\Share\\x" `shouldBe` "\\\\server\\share\\x" + it "UNC root lowercased when only root present" $ + nrm "\\\\Server\\Share\\" `shouldBe` "\\\\server\\share\\" it "verbatim path untouched" $ nrm "\\\\?\\C:\\Foo" `shouldBe` "\\\\?\\C:\\Foo" it "verbatim path with mixed case kept verbatim" $ @@ -347,7 +344,7 @@ testValidatePath = describe "validatePath" $ do , ("\\\\", False) , ("\\\\\\", False) , ("\\\\x", False) - , ("\\\\x\\", True) + , ("\\\\x\\", False) -- server only, no share , ("\\\\x\\y", True) , ("//x/y", True) , ("\\\\prn\\y", False) @@ -412,7 +409,7 @@ testUnsafeJoin = describe "unsafeJoin" $ do it "x/ /y" $ f "x/" "/y" `shouldBe` "x/y" -- joinDrive-equivalent cases it "c: /x" $ f "c:" "/x" `shouldBe` "c:/x" - it "//x/ /y" $ f "//x/" "/y" `shouldBe` "//x/y" + it "//x/y/ /z" $ f "//x/y/" "/z" `shouldBe` "//x/y/z" testJoinWindows :: Spec testJoinWindows = describe "join (windows-specific)" $ do @@ -422,12 +419,12 @@ testJoinWindows = describe "join (windows-specific)" $ do it "c:x y" $ f "c:x" "y" `shouldBe` "c:x\\y" it "\\x y" $ f "\\x" "y" `shouldBe` "\\x\\y" it "c:/ y" $ f "c:/" "y" `shouldBe` "c:/y" - it "//x/ y" $ f "//x/" "y" `shouldBe` "//x/y" + it "//x/y/ z" $ f "//x/y/" "z" `shouldBe` "//x/y/z" it "trailing forward slash kept" $ f "x/" "y" `shouldBe` "x/y" it "second-path /y rejected for any first" $ do mapM_ (\a -> fails (f a "/y") >>= (`shouldBe` True)) - ["c:/", "c:/x", "c:", "c:x", "/x", "x", "//x/"] + ["c:/", "c:/x", "c:", "c:x", "/x", "x", "//x/y/"] it "second-path c:/ rejected" $ fails (f "c:" "c:/") >>= (`shouldBe` True) ------------------------------------------------------------------------------- @@ -445,7 +442,8 @@ testSplitPath_ = describe "splitPath_ (windows-specific)" $ do [ ("c:x", ["c:", "x"]) , ("c:/", ["c:/"]) , ("c:/x", ["c:/", "x"]) - , ("//x/y/", ["//x", "y"]) + , ("//x/y/", ["//x/y"]) + , ("//x/y/z", ["//x/y", "z"]) , ("./a", [".", "a"]) , ("c:./a", ["c:", "a"]) , ("a/.", ["a"])