Merge pull request haskell#8 from gintas/master

System/Directory.hs

@@ -679,17 +679,31 @@ Either path refers to an existing directory.
 
 renameFile :: FilePath -> FilePath -> IO ()
 renameFile opath npath = (`ioeSetLocation` "renameFile") `modifyIOError` do
-   -- XXX this test isn't performed atomically with the following rename
-   dirType <- getDirectoryType opath
-   case dirType of
-     Directory -> ioError . (`ioeSetErrorString` "is a directory") $
-                  mkIOError InappropriateType "" Nothing (Just opath)
-     _         -> return ()
+   -- XXX the tests are not performed atomically with the rename
+   checkNotDir opath
 #ifdef mingw32_HOST_OS
    Win32.moveFileEx opath npath Win32.mOVEFILE_REPLACE_EXISTING
 #else
    Posix.rename opath npath
 #endif
+     -- The underlying rename implementation can throw odd exceptions when the
+     -- destination is a directory.  For example, Windows typically throws a
+     -- permission error, while POSIX systems may throw a resource busy error
+     -- if one of the paths refers to the current directory.  In these cases,
+     -- we check if the destination is a directory and, if so, throw an
+     -- InappropriateType error.
+     `catchIOError` \ err -> do
+       checkNotDir npath
+       ioError err
+   where checkNotDir path = do
+           dirType <- getDirectoryType path
+                      `catchIOError` \ _ -> return NotDirectory
+           case dirType of
+             Directory     -> errIsDir path
+             DirectoryLink -> errIsDir path
+             NotDirectory  -> return ()
+         errIsDir path = ioError . (`ioeSetErrorString` "is a directory") $
+                         mkIOError InappropriateType "" Nothing (Just path)
 
 #endif /* __GLASGOW_HASKELL__ */
 

tests/.gitignore

@@ -23,3 +23,4 @@
 /getPermissions001
 /renameFile001
 /renameFile001.tmp1
+/T8482

tests/T8482.hs

@@ -0,0 +1,16 @@
+import System.Directory
+import Control.Exception
+
+tmp1 = "T8482.tmp1"
+testdir = "T8482.dir"
+
+main = do
+  writeFile tmp1 "hello"
+  createDirectory testdir
+  tryRenameFile testdir tmp1 >>= print  -- InappropriateType
+  tryRenameFile tmp1 testdir >>= print  -- InappropriateType
+  tryRenameFile tmp1 "." >>= print  -- InappropriateType
+  removeDirectory testdir
+  removeFile tmp1
+  where tryRenameFile :: FilePath -> FilePath -> IO (Either IOException ())
+        tryRenameFile opath npath = try $ renameFile opath npath

tests/T8482.stdout

@@ -0,0 +1,3 @@
+Left T8482.dir: renameFile: inappropriate type (is a directory)
+Left T8482.dir: renameFile: inappropriate type (is a directory)
+Left .: renameFile: inappropriate type (is a directory)

tests/all.T

@@ -25,4 +25,6 @@ test('createDirectory001',  normal, compile_and_run, [''])
 test('createDirectoryIfMissing001',  normal, compile_and_run, [''])
 
 # No sane way to tell whether the output is reasonable here...
-test('getHomeDirectory001',  ignore_output, compile_and_run, [''])
+test('getHomeDirectory001',  ignore_output, compile_and_run, [''])
+
+test('T8482',  normal, compile_and_run, [''])