Skip to content

Commit

Permalink
TEST
Browse files Browse the repository at this point in the history
  • Loading branch information
@Rufflewind
Rufflewind committed Jan 23, 2024
1 parent 6e3ecc9 commit 11feadf
Show file tree
Hide file tree
Showing 6 changed files with 198 additions and 202 deletions.
11 changes: 0 additions & 11 deletions .github/workflows/build.yml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -14,17 +14,6 @@ jobs:
fail-fast: false
matrix:
include:
- { os: macos-latest, stack: lts-12.26, stack-extra-deps: "bytestring-0.11.3.0, filepath-1.4.100.0, unix-2.8.0.0" }
- { os: macos-latest, stack: lts-19.21, stack-extra-deps: "bytestring-0.11.3.0, filepath-1.4.100.0, unix-2.8.0.0" }
- { os: ubuntu-latest, ghc: 8.4.4, cabal: 3.0.0.0, overrides: "before_prepare() { sed -i.bak /utimensat/d configure.ac; }" }
- { os: ubuntu-latest, ghc: 8.6.5, cabal: 3.0.0.0, overrides: "before_prepare() { sed -i.bak /utimensat/d configure.ac; }" }
- { os: ubuntu-latest, ghc: 8.10.7, cabal: 3.8.1.0 }
- { os: ubuntu-latest, ghc: 9.0.2, cabal: 3.8.1.0 }
- { os: ubuntu-latest, ghc: 9.2.4, cabal: 3.8.1.0 }
- { os: ubuntu-latest, ghc: 9.4.3, cabal: 3.8.1.0 }
- { os: ubuntu-latest, ghc: latest, cabal: latest }
- { os: windows-latest, stack: lts-12.26, stack-extra-deps: "bytestring-0.11.3.0, filepath-1.4.100.0, time-1.8.0.2, Win32-2.13.3.0", overrides: "before_prepare() { sed -i.bak -e /CreateSymbolicLinkW/d -e /GetFinalPathNameByHandleW/d configure.ac; }" }
- { os: windows-latest, stack: lts-17.5, stack-extra-deps: "bytestring-0.11.3.0, filepath-1.4.100.0, time-1.9.3, Win32-2.13.3.0" }
- { os: windows-latest, stack: lts-22.7, stack-extra-deps: "bytestring-0.11.5.3, filepath-1.4.100.0, time-1.12.2, Win32-2.14.0.0" }
runs-on: ${{ matrix.os }}
env:
Expand Down
5 changes: 3 additions & 2 deletions System/Directory/Internal/Windows.hsc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -15,6 +15,7 @@ module System.Directory.Internal.Windows where
#include <System/Directory/Internal/utility.h>
#include <System/Directory/Internal/windows_ext.h>
import Prelude ()
import Debug.Trace
import System.Directory.Internal.Prelude
import System.Directory.Internal.Common
import System.Directory.Internal.Config (exeExtension)
Expand Down Expand Up @@ -332,7 +333,7 @@ toExtendedLengthPath path =
'\\' : '\\' : _ ->
os "\\\\?\\UNC" <> pack (drop 1 simplifiedPath')
_ -> os "\\\\?\\" <> simplifiedPath
where simplifiedPath = simplify path
where simplifiedPath = traceShow ("simplify", path, simplify path) (simplify path)
simplifiedPath' = unpack simplifiedPath

-- | Make a path absolute and convert to an extended length path, if possible.
Expand All @@ -343,7 +344,7 @@ toExtendedLengthPath path =
-- returns the path unchanged.
furnishPath :: OsPath -> IO WindowsPath
furnishPath path =
(toExtendedLengthPath <$> rawPrependCurrentDirectory path)
(toExtendedLengthPath <$> traceShow ("isRelative", path, isRelative path) (rawPrependCurrentDirectory path))
`catchIOError` \ _ ->
pure (getOsString path)

Expand Down
13 changes: 7 additions & 6 deletions System/Directory/OsPath.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -103,6 +103,7 @@ module System.Directory.OsPath

) where
import Prelude ()
import Debug.Trace
import System.Directory.Internal
import System.Directory.Internal.Prelude
import System.OsPath
Expand Down Expand Up @@ -872,13 +873,13 @@ canonicalizePath = \ path ->
(`ioeSetOsPath` path)) `modifyIOError` do
-- simplify does more stuff, like upper-casing the drive letter
dropTrailingPathSeparator . simplify <$>
(attemptRealpath realPath =<< prependCurrentDirectory path)
((\p -> traceShow ("prependCurrentDirectory", path, p) $ attemptRealpath realPath p) =<< prependCurrentDirectory path)
where

-- allow up to 64 cycles before giving up
attemptRealpath realpath =
attemptRealpathWith (64 :: Int) Nothing realpath
<=< canonicalizePathSimplify
attemptRealpath realpath p = do
p2 <- canonicalizePathSimplify p
traceShow ("canonicalizePathSimplify", p, p2) $ attemptRealpathWith (64 :: Int) Nothing realpath p2

-- n is a counter to make sure we don't run into an infinite loop; we
-- don't try to do any cycle detection here because an adversary could DoS
Expand All @@ -889,11 +890,11 @@ canonicalizePath = \ path ->
Just fallback | n <= 0 -> pure fallback
-- either mFallback == Nothing (first attempt)
-- or n > 0 (still have some attempts left)
_ -> realpathPrefix (reverse (zip prefixes suffixes))
_ -> realpathPrefix (traceShow ("realpathPrefix:inputs", (reverse (zip prefixes suffixes))) (reverse (zip prefixes suffixes)))

where

segments = splitDirectories path
segments = traceShow ("splitDirectories", splitDirectories path, path) (splitDirectories path)
prefixes = scanl1 (</>) segments
suffixes = NE.tail (NE.scanr (</>) mempty segments)

Expand Down
309 changes: 157 additions & 152 deletions tests/CanonicalizePath.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,155 +8,160 @@ import TestUtils

main :: TestEnv -> IO ()
main _t = do
dot <- canonicalizePath ""
dot2 <- canonicalizePath "."
dot3 <- canonicalizePath "./"
dot4 <- canonicalizePath "./."
T(expectEq) () dot (dropTrailingPathSeparator dot)
T(expectEq) () dot dot2
T(expectEq) () dot dot3
T(expectEq) () dot dot4

writeFile "bar" ""
bar <- canonicalizePath "bar"
bar2 <- canonicalizePath "bar/"
bar3 <- canonicalizePath "bar/."
bar4 <- canonicalizePath "bar/./"
bar5 <- canonicalizePath "./bar"
bar6 <- canonicalizePath "./bar/"
bar7 <- canonicalizePath "./bar/."
T(expectEq) () bar (normalise (dot </> "bar"))
T(expectEq) () bar bar2
T(expectEq) () bar bar3
T(expectEq) () bar bar4
T(expectEq) () bar bar5
T(expectEq) () bar bar6
T(expectEq) () bar bar7

createDirectory "foo"
foo <- canonicalizePath "foo"
foo2 <- canonicalizePath "foo/"
foo3 <- canonicalizePath "foo/."
foo4 <- canonicalizePath "foo/./"
foo5 <- canonicalizePath "./foo"
foo6 <- canonicalizePath "./foo/"
T(expectEq) () foo (normalise (dot </> "foo"))
T(expectEq) () foo foo2
T(expectEq) () foo foo3
T(expectEq) () foo foo4
T(expectEq) () foo foo5
T(expectEq) () foo foo6

-- should not fail for non-existent paths
fooNon <- canonicalizePath "foo/non-existent"
fooNon2 <- canonicalizePath "foo/non-existent/"
fooNon3 <- canonicalizePath "foo/non-existent/."
fooNon4 <- canonicalizePath "foo/non-existent/./"
fooNon5 <- canonicalizePath "./foo/non-existent"
fooNon6 <- canonicalizePath "./foo/non-existent/"
fooNon7 <- canonicalizePath "./foo/./non-existent"
fooNon8 <- canonicalizePath "./foo/./non-existent/"
T(expectEq) () fooNon (normalise (foo </> "non-existent"))
T(expectEq) () fooNon fooNon2
T(expectEq) () fooNon fooNon3
T(expectEq) () fooNon fooNon4
T(expectEq) () fooNon fooNon5
T(expectEq) () fooNon fooNon6
T(expectEq) () fooNon fooNon7
T(expectEq) () fooNon fooNon8

-- make sure ".." gets expanded properly by 'toExtendedLengthPath'
-- (turns out this test won't detect the problem because GetFullPathName
-- would expand them for us if we don't, but leaving it here anyway)
T(expectEq) () foo =<< canonicalizePath (foo </> ".." </> "foo")

supportsSymbolicLinks <- supportsSymlinks
when supportsSymbolicLinks $ do

let barQux = dot </> "bar" </> "qux"

-- note: this also checks that "../bar" gets normalized to "..\\bar"
-- since Windows does not like "/" in symbolic links targets
createFileLink "../bar" "foo/bar"
T(expectEq) () bar =<< canonicalizePath "foo/bar"
T(expectEq) () barQux =<< canonicalizePath "foo/bar/qux"

createDirectoryLink "foo" "lfoo"
T(expectEq) () foo =<< canonicalizePath "lfoo"
T(expectEq) () foo =<< canonicalizePath "lfoo/"
T(expectEq) () bar =<< canonicalizePath "lfoo/bar"
T(expectEq) () barQux =<< canonicalizePath "lfoo/bar/qux"

-- create a haphazard chain of links
createDirectoryLink "./../foo/../foo/." "./foo/./somelink3"
createDirectoryLink ".././foo/somelink3" "foo/somelink2"
createDirectoryLink "./foo/somelink2" "somelink"
T(expectEq) () foo =<< canonicalizePath "somelink"

-- regression test for #64
createFileLink "../foo/non-existent" "foo/qux"
removeDirectoryLink "foo/somelink3" -- break the chain made earlier
qux <- canonicalizePath "foo/qux"
T(expectEq) () qux =<< canonicalizePath "foo/non-existent"
T(expectEq) () (foo </> "somelink3") =<< canonicalizePath "somelink"

-- make sure it can handle loops
createFileLink "loop1" "loop2"
createFileLink "loop2" "loop1"
loop1 <- canonicalizePath "loop1"
loop2 <- canonicalizePath "loop2"
T(expectEq) () loop1 (normalise (dot </> "loop1"))
T(expectEq) () loop2 (normalise (dot </> "loop2"))

-- make sure ".." gets expanded properly by 'toExtendedLengthPath'
createDirectoryLink (foo </> ".." </> "foo") "foolink"
_ <- listDirectory "foolink" -- make sure directory is accessible
T(expectEq) () foo =<< canonicalizePath "foolink"

caseInsensitive <-
(False <$ createDirectory "FOO")
`catch` \ e ->
if isAlreadyExistsError e
then pure True
else throwIO e

-- if platform is case-insensitive, we expect case to be canonicalized too
when caseInsensitive $ do
foo7 <- canonicalizePath "FOO"
foo8 <- canonicalizePath "FOO/"
T(expectEq) () foo foo7
T(expectEq) () foo foo8

fooNon9 <- canonicalizePath "FOO/non-existent"
fooNon10 <- canonicalizePath "fOo/non-existent/"
fooNon11 <- canonicalizePath "foO/non-existent/."
fooNon12 <- canonicalizePath "FoO/non-existent/./"
fooNon13 <- canonicalizePath "./fOO/non-existent"
fooNon14 <- canonicalizePath "./FOo/non-existent/"
cfooNon15 <- canonicalizePath "./FOO/./NON-EXISTENT"
cfooNon16 <- canonicalizePath "./FOO/./NON-EXISTENT/"
T(expectEq) () fooNon fooNon9
T(expectEq) () fooNon fooNon10
T(expectEq) () fooNon fooNon11
T(expectEq) () fooNon fooNon12
T(expectEq) () fooNon fooNon13
T(expectEq) () fooNon fooNon14
T(expectEq) () fooNon (dropFileName cfooNon15 <>
(os (toLower <$> so (takeFileName cfooNon15))))
T(expectEq) () fooNon (dropFileName cfooNon16 <>
(os (toLower <$> so (takeFileName cfooNon16))))
T(expectNe) () fooNon cfooNon15
T(expectNe) () fooNon cfooNon16

setCurrentDirectory "foo"
foo9 <- canonicalizePath "../FOO"
foo10 <- canonicalizePath "../FOO/"
T(expectEq) () foo foo9
T(expectEq) () foo foo10

-- Make sure long file names can be canonicalized too
-- (i.e. GetLongPathName by itself won't work)
createDirectory "verylongdirectoryname"
vldn <- canonicalizePath "verylongdirectoryname"
vldn2 <- canonicalizePath "VERYLONGDIRECTORYNAME"
T(expectEq) () vldn vldn2
-- dot <- canonicalizePath ""
-- dot2 <- canonicalizePath "."
-- dot3 <- canonicalizePath "./"
-- dot4 <- canonicalizePath "./."
-- T(expectEq) () dot (dropTrailingPathSeparator dot)
-- T(expectEq) () dot dot2
-- T(expectEq) () dot dot3
-- T(expectEq) () dot dot4

-- writeFile "bar" ""
-- bar <- canonicalizePath "bar"
-- bar2 <- canonicalizePath "bar/"
-- bar3 <- canonicalizePath "bar/."
-- bar4 <- canonicalizePath "bar/./"
-- bar5 <- canonicalizePath "./bar"
-- bar6 <- canonicalizePath "./bar/"
-- bar7 <- canonicalizePath "./bar/."
-- T(expectEq) () bar (normalise (dot </> "bar"))
-- T(expectEq) () bar bar2
-- T(expectEq) () bar bar3
-- T(expectEq) () bar bar4
-- T(expectEq) () bar bar5
-- T(expectEq) () bar bar6
-- T(expectEq) () bar bar7

-- createDirectory "foo"
-- foo <- canonicalizePath "foo"
-- foo2 <- canonicalizePath "foo/"
-- foo3 <- canonicalizePath "foo/."
-- foo4 <- canonicalizePath "foo/./"
-- foo5 <- canonicalizePath "./foo"
-- foo6 <- canonicalizePath "./foo/"
-- T(expectEq) () foo (normalise (dot </> "foo"))
-- T(expectEq) () foo foo2
-- T(expectEq) () foo foo3
-- T(expectEq) () foo foo4
-- T(expectEq) () foo foo5
-- T(expectEq) () foo foo6

-- -- should not fail for non-existent paths
-- fooNon <- canonicalizePath "foo/non-existent"
-- fooNon2 <- canonicalizePath "foo/non-existent/"
-- fooNon3 <- canonicalizePath "foo/non-existent/."
-- fooNon4 <- canonicalizePath "foo/non-existent/./"
-- fooNon5 <- canonicalizePath "./foo/non-existent"
-- fooNon6 <- canonicalizePath "./foo/non-existent/"
-- fooNon7 <- canonicalizePath "./foo/./non-existent"
-- fooNon8 <- canonicalizePath "./foo/./non-existent/"
-- T(expectEq) () fooNon (normalise (foo </> "non-existent"))
-- T(expectEq) () fooNon fooNon2
-- T(expectEq) () fooNon fooNon3
-- T(expectEq) () fooNon fooNon4
-- T(expectEq) () fooNon fooNon5
-- T(expectEq) () fooNon fooNon6
-- T(expectEq) () fooNon fooNon7
-- T(expectEq) () fooNon fooNon8

-- -- make sure ".." gets expanded properly by 'toExtendedLengthPath'
-- -- (turns out this test won't detect the problem because GetFullPathName
-- -- would expand them for us if we don't, but leaving it here anyway)
-- T(expectEq) () foo =<< canonicalizePath (foo </> ".." </> "foo")

-- supportsSymbolicLinks <- supportsSymlinks
-- when supportsSymbolicLinks $ do

-- let barQux = dot </> "bar" </> "qux"

-- -- note: this also checks that "../bar" gets normalized to "..\\bar"
-- -- since Windows does not like "/" in symbolic links targets
-- createFileLink "../bar" "foo/bar"
-- T(expectEq) () bar =<< canonicalizePath "foo/bar"
-- T(expectEq) () barQux =<< canonicalizePath "foo/bar/qux"

-- createDirectoryLink "foo" "lfoo"
-- T(expectEq) () foo =<< canonicalizePath "lfoo"
-- T(expectEq) () foo =<< canonicalizePath "lfoo/"
-- T(expectEq) () bar =<< canonicalizePath "lfoo/bar"
-- T(expectEq) () barQux =<< canonicalizePath "lfoo/bar/qux"

-- -- create a haphazard chain of links
-- createDirectoryLink "./../foo/../foo/." "./foo/./somelink3"
-- createDirectoryLink ".././foo/somelink3" "foo/somelink2"
-- createDirectoryLink "./foo/somelink2" "somelink"
-- T(expectEq) () foo =<< canonicalizePath "somelink"

-- -- regression test for #64
-- createFileLink "../foo/non-existent" "foo/qux"
-- removeDirectoryLink "foo/somelink3" -- break the chain made earlier
-- qux <- canonicalizePath "foo/qux"
-- T(expectEq) () qux =<< canonicalizePath "foo/non-existent"
-- T(expectEq) () (foo </> "somelink3") =<< canonicalizePath "somelink"

-- -- make sure it can handle loops
-- createFileLink "loop1" "loop2"
-- createFileLink "loop2" "loop1"
-- loop1 <- canonicalizePath "loop1"
-- loop2 <- canonicalizePath "loop2"
-- T(expectEq) () loop1 (normalise (dot </> "loop1"))
-- T(expectEq) () loop2 (normalise (dot </> "loop2"))

-- -- make sure ".." gets expanded properly by 'toExtendedLengthPath'
-- createDirectoryLink (foo </> ".." </> "foo") "foolink"
-- _ <- listDirectory "foolink" -- make sure directory is accessible
-- T(expectEq) () foo =<< canonicalizePath "foolink"

-- caseInsensitive <-
-- (False <$ createDirectory "FOO")
-- `catch` \ e ->
-- if isAlreadyExistsError e
-- then pure True
-- else throwIO e

-- -- if platform is case-insensitive, we expect case to be canonicalized too
-- when caseInsensitive $ do
-- foo7 <- canonicalizePath "FOO"
-- foo8 <- canonicalizePath "FOO/"
-- T(expectEq) () foo foo7
-- T(expectEq) () foo foo8

-- fooNon9 <- canonicalizePath "FOO/non-existent"
-- fooNon10 <- canonicalizePath "fOo/non-existent/"
-- fooNon11 <- canonicalizePath "foO/non-existent/."
-- fooNon12 <- canonicalizePath "FoO/non-existent/./"
-- fooNon13 <- canonicalizePath "./fOO/non-existent"
-- fooNon14 <- canonicalizePath "./FOo/non-existent/"
-- cfooNon15 <- canonicalizePath "./FOO/./NON-EXISTENT"
-- cfooNon16 <- canonicalizePath "./FOO/./NON-EXISTENT/"
-- T(expectEq) () fooNon fooNon9
-- T(expectEq) () fooNon fooNon10
-- T(expectEq) () fooNon fooNon11
-- T(expectEq) () fooNon fooNon12
-- T(expectEq) () fooNon fooNon13
-- T(expectEq) () fooNon fooNon14
-- T(expectEq) () fooNon (dropFileName cfooNon15 <>
-- (os (toLower <$> so (takeFileName cfooNon15))))
-- T(expectEq) () fooNon (dropFileName cfooNon16 <>
-- (os (toLower <$> so (takeFileName cfooNon16))))
-- T(expectNe) () fooNon cfooNon15
-- T(expectNe) () fooNon cfooNon16

-- setCurrentDirectory "foo"
-- foo9 <- canonicalizePath "../FOO"
-- foo10 <- canonicalizePath "../FOO/"
-- T(expectEq) () foo foo9
-- T(expectEq) () foo foo10

-- -- Make sure long file names can be canonicalized too
-- -- (i.e. GetLongPathName by itself won't work)
-- createDirectory "verylongdirectoryname"
-- vldn <- canonicalizePath "verylongdirectoryname"
-- vldn2 <- canonicalizePath "VERYLONGDIRECTORYNAME"
-- T(expectEq) () vldn vldn2

#if defined(mingw32_HOST_OS)
-- https://github.com/haskell/directory/issues/170
T(expectEq) () "\\\\localhost" =<< canonicalizePath "\\\\localhost"
#endif
Loading

0 comments on commit 11feadf

Please sign in to comment.