From 60667c87b8a499a07e1ed0d578cf72dec9806cf7 Mon Sep 17 00:00:00 2001 From: Gintautas Miliauskas Date: Mon, 3 Nov 2014 19:49:04 +0100 Subject: [PATCH] renameFile now consistently reports an error if the destination is a directory, as specified by documentation. Previously the exceptions raised would be quite inconsistent. For example, given a file 'f' and a directory 'd', on Linux, the simple case worked: Prelude System.Directory> renameFile "f" "d" *** Exception: f: rename: inappropriate type (Is a directory) however: Prelude System.Directory> renameFile "f" "d/" *** Exception: f: rename: inappropriate type (Not a directory) Prelude System.Directory> renameFile "f" "." *** Exception: e: rename: resource busy (Device or resource busy) Prelude System.Directory> renameFile "f" "/tmp" *** Exception: e: rename: unsatisified constraints (Directory not empty) Windows was inconsistent with the documentation even in the general case: Prelude System.Directory> renameFile "f" "d" *** Exception: f: MoveFileEx "f" "d": permission denied (Access is denied.) The additional check should not incur noticeable cost as an extra stat to check for a directory is only performed in case of an IO exception. I am not sure if this is actually the right abstraction level to fix these inconsistencies. Perhaps they should be pushed down to libraries/Win32, but the thing is, the Win32 documentation does not try to specify which errors are raised in which settings, but System.Directory does, and the implementation goes against the documentation, which seems wrong. --- System/Directory.hs | 39 +++++++++++++++++++++++---------------- tests/T8482.hs | 16 ++++++++++++++++ tests/T8482.stdout | 3 +++ tests/all.T | 1 + 4 files changed, 43 insertions(+), 16 deletions(-) create mode 100644 tests/T8482.hs create mode 100644 tests/T8482.stdout diff --git a/System/Directory.hs b/System/Directory.hs index 203f4aac..14b89fff 100644 --- a/System/Directory.hs +++ b/System/Directory.hs @@ -638,24 +638,31 @@ Either path refers to an existing directory. renameFile :: FilePath -> FilePath -> IO () renameFile opath npath = do - -- XXX this test isn't performed atomically with the following rename -#ifdef mingw32_HOST_OS - -- ToDo: use Win32 API - withFileOrSymlinkStatus "renameFile" opath $ \st -> do - is_dir <- isDirectory st -#else - stat <- Posix.getSymbolicLinkStatus opath - let is_dir = Posix.isDirectory stat -#endif - if is_dir - then ioError (ioeSetErrorString - (mkIOError InappropriateType "renameFile" Nothing (Just opath)) - "is a directory") - else do + -- XXX the isDirectory tests are not performed atomically with the rename + checkNotDir opath + doRename `E.catch` renameExcHandler + where checkNotDir path = do + isdir <- pathIsDir path `E.catch` ((\ _ -> return False) :: IOException -> IO Bool) + when isdir $ dirIoError path + dirIoError path = ioError $ ioeSetErrorString (mkIOError InappropriateType "renameFile" Nothing (Just path)) "is a directory" + renameExcHandler :: IOException -> IO () + renameExcHandler exc = do + -- The underlying rename implementation throws odd exceptions + -- sometimes when the destination is a directory. For example, + -- Windows throws a permission error. In those cases check + -- if the cause is actually the destination being a directory + -- and throw InapprioriateType in that case. + checkNotDir npath + throw exc + doRename :: IO () + pathIsDir :: FilePath -> IO (Bool) #ifdef mingw32_HOST_OS - Win32.moveFileEx opath npath Win32.mOVEFILE_REPLACE_EXISTING + -- ToDo: use Win32 API + pathIsDir path = withFileOrSymlinkStatus "renameFile" path isDirectory + doRename = Win32.moveFileEx opath npath Win32.mOVEFILE_REPLACE_EXISTING #else - Posix.rename opath npath + pathIsDir path = Posix.isDirectory `fmap` Posix.getSymbolicLinkStatus path + doRename = Posix.rename opath npath #endif #endif /* __GLASGOW_HASKELL__ */ diff --git a/tests/T8482.hs b/tests/T8482.hs new file mode 100644 index 00000000..3bea8af9 --- /dev/null +++ b/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 diff --git a/tests/T8482.stdout b/tests/T8482.stdout new file mode 100644 index 00000000..277bc185 --- /dev/null +++ b/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) diff --git a/tests/all.T b/tests/all.T index 4efd6883..ac6c9098 100644 --- a/tests/all.T +++ b/tests/all.T @@ -27,3 +27,4 @@ test('createDirectoryIfMissing001', normal, compile_and_run, ['']) test('getHomeDirectory001', ignore_output, compile_and_run, ['']) test('T4113', when(platform('i386-apple-darwin'), expect_broken(7604)), compile_and_run, ['']) +test('T8482', normal, compile_and_run, [''])