diff --git a/System/Directory.hs b/System/Directory.hs --- a/System/Directory.hs +++ b/System/Directory.hs @@ -795,28 +795,27 @@ -- | 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 require only an absolute path, use 'makeAbsolute' instead. --- Most programs need not care about whether a path contains symbolic links. +-- any Unix symbolic links. The input path does not have to point to an +-- existing file or directory. -- --- Due to the fact that symbolic links and @..@ are dependent on the state of --- the existing filesystem, the function can only make a conservative, --- best-effort attempt. Nevertheless, if the input path points to an existing --- file or directory, then the output path shall also point to the same file --- or directory. +-- __Note__: if you only need an absolute path, use 'makeAbsolute' instead. +-- Most programs should not worry about whether a path contains symbolic links. -- --- 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, therefore concurrent changes in the filesystem may lead to --- incorrect results. +-- Since symbolic links and the special parent directory (@..@) are dependent +-- on the state of the existing filesystem, the function can only make a +-- conservative attempt by removing symbolic links and @..@ from the longest +-- prefix of the path that still points to an existing file or directory. If +-- the input path points to an existing file or directory, then the output +-- path shall also point to the same file or directory, provided that the +-- relevant parts of the filesystem have not changed in the meantime (the +-- function is not atomic). -- --- (Despite the name, the function does not guarantee canonicity of the --- returned path due to the presence of hard links, mount points, etc.) +-- Despite the name, the function does not guarantee canonicity of the +-- returned path due to the presence of hard links, mount points, etc. -- --- Similar to 'normalise', an empty path is equivalent to the current --- directory. +-- Similar to 'normalise', passing an empty path is equivalent to passing the +-- current directory. The function preserves the presence or absence of the +-- trailing path separator unless the path refers to the root directory @/@. -- -- /Known bug(s)/: on Windows, the function does not resolve symbolic links. -- @@ -828,13 +827,13 @@ modifyIOError ((`ioeSetLocation` "canonicalizePath") . (`ioeSetFileName` path)) $ -- normalise does more stuff, like upper-casing the drive letter - normalise <$> (transform =<< makeAbsolute path) + normalise <$> (transform =<< prependCurrentDirectory path) where #if defined(mingw32_HOST_OS) transform path = Win32.getFullPathName path `catchIOError` \ _ -> return path #else - transform path = copySlash path <$> do + transform path = matchTrailingSeparator path <$> do encoding <- getFileSystemEncoding realpathPrefix encoding (reverse (zip prefixes suffixes)) path where segments = splitPath path @@ -856,27 +855,59 @@ doesPathExist path = (Posix.getFileStatus path >> return True) `catchIOError` \ _ -> return False - - -- make sure trailing slash is preserved - copySlash path | hasTrailingPathSeparator path = addTrailingPathSeparator - | otherwise = id #endif --- | Make a path absolute by prepending the current directory (if it isn't --- already absolute) and applying 'normalise' to the result. +-- | Convert a path into an absolute path. If the given path is relative, the +-- current directory is prepended and then the combined result is +-- 'normalise'd. If the path is already absolute, the path is simply +-- 'normalise'd. The function preserves the presence or absence of the +-- trailing path separator unless the path refers to the root directory @/@. -- -- If the path is already absolute, the operation never fails. Otherwise, the -- operation may fail with the same exceptions as 'getCurrentDirectory'. -- -- @since 1.2.2.0 makeAbsolute :: FilePath -> IO FilePath -makeAbsolute = (normalise <$>) . absolutize - where absolutize path -- avoid the call to `getCurrentDirectory` if we can - | isRelative path = ( path) . addTrailingPathSeparator <$> - getCurrentDirectory - | otherwise = return path +makeAbsolute path = + modifyIOError ((`ioeSetLocation` "makeAbsolute") . + (`ioeSetFileName` path)) $ + matchTrailingSeparator path . normalise <$> prependCurrentDirectory path --- | 'makeRelative' the current directory. +-- | Convert a path into an absolute path. If the given path is relative, the +-- current directory is prepended. If the path is already absolute, the path +-- is returned unchanged. The function preserves the presence or absence of +-- the trailing path separator. +-- +-- If the path is already absolute, the operation never fails. Otherwise, the +-- operation may fail with the same exceptions as 'getCurrentDirectory'. +-- +-- (internal API) +prependCurrentDirectory :: FilePath -> IO FilePath +prependCurrentDirectory path = + modifyIOError ((`ioeSetLocation` "prependCurrentDirectory") . + (`ioeSetFileName` path)) $ + case path of + "" -> -- avoid trailing path separator + prependCurrentDirectory "." + _ -- avoid the call to `getCurrentDirectory` if we can + | isRelative path -> + ( path) . addTrailingPathSeparator <$> getCurrentDirectory + | otherwise -> + return path + +-- | Add or remove the trailing path separator in the second path so as to +-- match its presence in the first path. +-- +-- (internal API) +matchTrailingSeparator :: FilePath -> FilePath -> FilePath +matchTrailingSeparator path + | hasTrailingPathSeparator path = addTrailingPathSeparator + | otherwise = dropTrailingPathSeparator + +-- | Construct a path relative to the current directory, similar to +-- 'makeRelative'. +-- +-- The operation may fail with the same exceptions as 'getCurrentDirectory'. makeRelativeToCurrentDirectory :: FilePath -> IO FilePath makeRelativeToCurrentDirectory x = do cur <- getCurrentDirectory @@ -966,6 +997,8 @@ #ifdef __GLASGOW_HASKELL__ -- | Similar to 'listDirectory', but always includes the special entries (@.@ -- and @..@). (This applies to Windows as well.) +-- +-- The operation may fail with the same exceptions as 'listDirectory'. getDirectoryContents :: FilePath -> IO [FilePath] getDirectoryContents path = modifyIOError ((`ioeSetFileName` path) . @@ -1070,11 +1103,17 @@ -- #ifdef __GLASGOW_HASKELL__ getCurrentDirectory :: IO FilePath -getCurrentDirectory = do +getCurrentDirectory = + modifyIOError (`ioeSetLocation` "getCurrentDirectory") $ + specializeErrorString + "Current working directory no longer exists" + isDoesNotExistError + getCwd + where #ifdef mingw32_HOST_OS - Win32.getCurrentDirectory + getCwd = Win32.getCurrentDirectory #else - Posix.getWorkingDirectory + getCwd = Posix.getWorkingDirectory #endif -- | Change the working directory to the given path. @@ -1488,6 +1527,7 @@ case env of Left _ -> return Nothing Right value -> return (Just value) +#endif -- | Similar to 'try' but only catches a specify kind of 'IOError' as -- specified by the predicate. @@ -1497,13 +1537,17 @@ case result of Left err -> if check err then return (Left err) else ioError err Right val -> return (Right val) -#endif +specializeErrorString :: String -> (IOError -> Bool) -> IO a -> IO a +specializeErrorString str errType action = do + mx <- tryIOErrorType errType action + case mx of + Left e -> ioError (ioeSetErrorString e str) + Right x -> return x + -- | Obtain the path to a special directory for storing user-specific --- application data (traditional Unix location). Except for backward --- compatibility reasons, newer applications may prefer the the --- XDG-conformant location provided by 'getXdgDirectory', which offers a --- more fine-grained hierarchy as well as greater flexibility for the user +-- application data (traditional Unix location). Newer applications may +-- prefer the the XDG-conformant location provided by 'getXdgDirectory' -- (). -- -- The argument is usually the name of the application. Since it will be diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,6 +1,20 @@ Changelog for the [`directory`][1] package ========================================== +## 1.2.5.1 (February 2015) + + * Improve error message of `getCurrentDirectory` when the current working + directory no longer exists + ([#39](https://github.com/haskell/directory/issues/39)) + + * Fix the behavior of trailing path separators in `canonicalizePath` as well + as `makeAbsolute` when applied to the current directory; they should now + match the behavior of `canonicalizePath` prior to 1.2.3.0 (when the bug + was introduced) + ([#42](https://github.com/haskell/directory/issues/42)) + + * Set the location in IO errors from `makeAbsolute`. + ## 1.2.5.0 (December 2015) * Add `listDirectory`, which is similar to `getDirectoryContents` diff --git a/directory.cabal b/directory.cabal --- a/directory.cabal +++ b/directory.cabal @@ -1,5 +1,5 @@ name: directory -version: 1.2.5.0 +version: 1.2.5.1 -- NOTE: Don't forget to update ./changelog.md license: BSD3 license-file: LICENSE @@ -60,7 +60,7 @@ build-depends: base >= 4.5 && < 4.10, - time >= 1.4 && < 1.6, + time >= 1.4 && < 1.7, filepath >= 1.3 && < 1.5 if os(windows) build-depends: Win32 >= 2.2.2 && < 2.4 diff --git a/tests/CanonicalizePath.hs b/tests/CanonicalizePath.hs --- a/tests/CanonicalizePath.hs +++ b/tests/CanonicalizePath.hs @@ -2,13 +2,16 @@ module CanonicalizePath where #include "util.inl" import System.Directory -import System.FilePath ((), normalise) +import System.FilePath ((), hasTrailingPathSeparator, normalise) main :: TestEnv -> IO () main _t = do + dot' <- canonicalizePath "./" dot <- canonicalizePath "." nul <- canonicalizePath "" T(expectEq) () dot nul + T(expect) dot (not (hasTrailingPathSeparator dot)) + T(expect) dot' (hasTrailingPathSeparator dot') writeFile "bar" "" bar <- canonicalizePath "bar"