Implement safer version of canonicalizePath for POSIX

Apply realpath to the largest prefix of the given path that is still
accessible (that can be stat successfully) so that canonicalizePath will
return reasonable results even for non-existent paths.  It should very
rarely throw exceptions now.

Fixes haskell#23.

System/Directory.hs

@@ -784,43 +784,71 @@ copyFile fromFPath toFPath =
 
           ignoreIOExceptions io = io `catchIOError` (\_ -> return ())
 
--- | Canonicalize the path of an existing file or directory.  The intent is
--- that two paths referring to the same file\/directory will map to the same
--- canonicalized path.
+-- | Make a path absolute and remove as many indirections from it as possible.
+-- Indirections include the two special directories @.@ and @..@, as well as
+-- any symbolic links.  The input path need not point to an existing file or
+-- directory.
 --
--- __Note__: if you only require an absolute path, consider using
--- @'makeAbsolute'@ instead, which is more reliable and does not have
--- unspecified behavior on nonexistent paths.
+-- __Note__: if you require only an absolute path, use @'makeAbsolute'@
+-- instead.  Most programs need not care about whether a path contains
+-- symbolic links.
 --
--- It is impossible to guarantee that the implication (same file\/dir \<=\>
--- same canonicalized path) holds in either direction: this function can make
--- only a best-effort attempt.
+-- Due to the fact that symbolic links and @..@ are dependent on the state of
+-- the existing filesystem, the function can only make a best-effort attempt.
+-- Nonetheless, if the input path points to an accessible file or directory,
+-- then the output shall also point to the same file or directory.
 --
--- The precise behaviour is that of the POSIX @realpath@ function (or
--- @GetFullPathNameW@ on Windows).  In particular, the behaviour on paths that
--- don't exist can vary from platform to platform.  Some platforms do not
--- alter the input, some do, and some throw an exception.
+-- Formally, symbolic links and @..@ are removed from the longest prefix of
+-- the path that still points to an existing file.  The function is not
+-- atomic.
 --
--- An empty path is considered to be equivalent to the current directory.
+-- (Despite the name, the function does not guarantee canonicity of the
+-- returned path due to the presence of hard links, mount points, etc.)
 --
--- /Known bug(s)/: on Windows, this function does not resolve symbolic links.
+-- Similar to 'normalise', an empty path is equivalent to the current
+-- directory.
+--
+-- /Known bug(s)/: on Windows, the function does not resolve symbolic links.
+--
+-- /Changes since 1.2.3.0:/ The function has been altered to be more robust
+-- and has the same exception behavior as 'makeAbsolute'.
 --
 canonicalizePath :: FilePath -> IO FilePath
-canonicalizePath ""    = canonicalizePath "."
-canonicalizePath fpath =
+canonicalizePath = \ path ->
+  modifyIOError ((`ioeSetLocation` "canonicalizePath") .
+                 (`ioeSetFileName` path)) $
+  -- normalise does more stuff, like upper-casing the drive letter
+  normalise <$> (transform =<< makeAbsolute path)
+  where
 #if defined(mingw32_HOST_OS)
-         do path <- Win32.getFullPathName fpath
+    transform path = Win32.getFullPathName path
+                     `catchIOError` \ _ -> return path
 #else
-  do enc <- getFileSystemEncoding
-     GHC.withCString enc fpath $ \pInPath ->
-       allocaBytes long_path_size $ \pOutPath ->
-         do _ <- throwErrnoPathIfNull "canonicalizePath" fpath $ c_realpath pInPath pOutPath
-
-            -- NB: pOutPath will be passed thru as result pointer by c_realpath
-            path <- GHC.peekCString enc pOutPath
+    transform path = do
+      encoding <- getFileSystemEncoding
+      check encoding (reverse (zip prefixes suffixes)) path
+      where segments = splitPath path
+            prefixes = scanl1 (</>) segments
+            suffixes = tail (scanr (</>) "" segments)
+    check encoding ((prefix, suffix) : rest) path = do
+      exist <- doesPathExist prefix
+      if exist
+        then do
+          result <- tryIOError (realpath encoding prefix)
+          case result of
+            Right prefix' -> return (prefix' </> suffix)
+            Left _        -> check encoding rest path
+        else check encoding rest path
+    check _ _ path = return path
+    realpath encoding path =
+      GHC.withCString encoding path $ \ pathIn ->
+      allocaBytes long_path_size $ \ pathOut -> do
+        _ <- throwErrnoIfNull "" (c_realpath pathIn pathOut)
+        -- NB: pOutPath will be passed thru as result pointer by c_realpath
+        polish <$> GHC.peekCString encoding pathOut
+      where polish | hasTrailingPathSeparator path = addTrailingPathSeparator
+                   | otherwise                     = id
 #endif
-            return (normalise path)
-        -- normalise does more stuff, like upper-casing the drive letter
 
 #if !defined(mingw32_HOST_OS)
 foreign import ccall unsafe "realpath"
@@ -1074,9 +1102,15 @@ setCurrentDirectory path =
   Posix.changeWorkingDirectory path
 #endif
 
-#endif /* __GLASGOW_HASKELL__ */
+doesPathExist :: FilePath -> IO Bool
+doesPathExist path = (stat >> return True) `catchIOError` \ _ -> return False
+  where
+#ifdef mingw32_HOST_OS
+   stat = withFileStatus "" path $ \ _ -> return ()
+#else
+   stat = Posix.getFileStatus path
+#endif
 
-#ifdef __GLASGOW_HASKELL__
 {- |The operation 'doesDirectoryExist' returns 'True' if the argument file
 exists and is either a directory or a symbolic link to a directory,
 and 'False' otherwise.

tests/CanonicalizePath.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE CPP #-}
+module CanonicalizePath where
+#include "util.inl"
+import System.Directory
+import System.FilePath ((</>), normalise)
+
+main :: TestEnv -> IO ()
+main _t = do
+  dot <- canonicalizePath "."
+  nul <- canonicalizePath ""
+  T(expectEq) () dot nul
+
+  writeFile "bar" ""
+  bar <- canonicalizePath "bar"
+  T(expectEq) () bar (normalise (dot </> "bar"))
+
+  createDirectory "foo"
+  foo <- canonicalizePath "foo/"
+  T(expectEq) () foo (normalise (dot </> "foo/"))
+
+  -- should not fail for non-existent paths
+  fooNon <- canonicalizePath "foo/non-existent"
+  T(expectEq) () fooNon (normalise (foo </> "non-existent"))

tests/Main.hs

@@ -1,9 +1,11 @@
 module Main (main) where
 import qualified Util as T
+import qualified CanonicalizePath
 import qualified FileTime
 import qualified T8482
 
 main :: IO ()
 main = T.testMain $ \ _t -> do
+  T.isolatedRun _t "CanonicalizePath" CanonicalizePath.main
   T.isolatedRun _t "FileTime" FileTime.main
   T.isolatedRun _t "T8482" T8482.main

tests/Util.hs

@@ -89,6 +89,14 @@ expect t file line context x =
   ["True"]
   ["False, but True was expected"]
 
+expectEq :: (Eq a, Show a, Show b) =>
+            TestEnv -> String -> Integer -> b -> a -> a -> IO ()
+expectEq t file line context x y =
+  check t (x == y)
+  [showContext file line context]
+  [show x <> " equals "     <> show y]
+  [show x <> " is not equal to " <> show y]
+
 expectNear :: (Num a, Ord a, Show a, Show b) =>
               TestEnv -> String -> Integer -> b -> a -> a -> a -> IO ()
 expectNear t file line context x y diff =

tests/all.T

@@ -1,4 +1,3 @@
-test('canonicalizePath001',     normal, compile_and_run, [''])
 test('currentDirectory001',     normal, compile_and_run, [''])
 test('directory001',            normal, compile_and_run, [''])
 test('doesDirectoryExist001',   normal, compile_and_run, [''])