fix #2298: use MoveFileEx() on Windows

[haskell-directory.git] / System / Directory.hs

diff --git a/System/Directory.hs b/System/Directory.hs
index 5298322..5da67b6 100644 (file)
--- a/System/Directory.hs
+++ b/System/Directory.hs
@@ -77,7 +77,7 @@ import System.FilePath
 import System.IO
 import System.IO.Error hiding ( catch, try )
 import Control.Monad           ( when, unless )
-import Control.Exception
+import Control.Exception.Base
 
 #ifdef __NHC__
 import Directory
@@ -100,6 +100,12 @@ import System.Time             ( ClockTime(..) )
 
 import GHC.IOBase      ( IOException(..), IOErrorType(..), ioException )
 
+#ifdef mingw32_HOST_OS
+import qualified System.Win32
+#else
+import qualified System.Posix
+#endif
+
 {- $intro
 A directory contains a series of entries, each of which is a named
 reference to a file system object (file, directory etc.).  Some
@@ -465,16 +471,18 @@ Either path refers to an existing non-directory object.
 
 renameDirectory :: FilePath -> FilePath -> IO ()
 renameDirectory opath npath =
+   -- XXX this test isn't performed atomically with the following rename
    withFileStatus "renameDirectory" opath $ \st -> do
    is_dir <- isDirectory st
    if (not is_dir)
        then ioException (IOError Nothing InappropriateType "renameDirectory"
                            ("not a directory") (Just opath))
        else do
-
-   withCString opath $ \s1 ->
-     withCString npath $ \s2 ->
-        throwErrnoIfMinus1Retry_ "renameDirectory" (c_rename s1 s2)
+#ifdef mingw32_HOST_OS
+   System.Win32.moveFileEx opath npath System.Win32.mOVEFILE_REPLACE_EXISTING
+#else
+   System.Posix.rename s1 s2
+#endif
 
 {- |@'renameFile' old new@ changes the name of an existing file system
 object from /old/ to /new/.  If the /new/ object already
@@ -522,16 +530,18 @@ Either path refers to an existing directory.
 
 renameFile :: FilePath -> FilePath -> IO ()
 renameFile opath npath =
+   -- XXX this test isn't performed atomically with the following rename
    withFileOrSymlinkStatus "renameFile" opath $ \st -> do
    is_dir <- isDirectory st
    if is_dir
        then ioException (IOError Nothing InappropriateType "renameFile"
                           "is a directory" (Just opath))
        else do
-
-    withCString opath $ \s1 ->
-      withCString npath $ \s2 ->
-         throwErrnoIfMinus1Retry_ "renameFile" (c_rename s1 s2)
+#ifdef mingw32_HOST_OS
+   System.Win32.moveFileEx opath npath System.Win32.mOVEFILE_REPLACE_EXISTING
+#else
+   System.Posix.rename s1 s2
+#endif
 
 #endif /* __GLASGOW_HASKELL__ */
 
@@ -545,8 +555,8 @@ copyFile :: FilePath -> FilePath -> IO ()
 #ifdef __NHC__
 copyFile fromFPath toFPath =
     do readFile fromFPath >>= writeFile toFPath
-       try (copyPermissions fromFPath toFPath)
-       return ()
+       Prelude.catch (copyPermissions fromFPath toFPath)
+                     (\_ -> return ())
 #else
 copyFile fromFPath toFPath =
     copy `Prelude.catch` (\exc -> throw $ ioeSetLocation exc "copyFile")
@@ -554,11 +564,12 @@ copyFile fromFPath toFPath =
                  bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) ->
                  do allocaBytes bufferSize $ copyContents hFrom hTmp
                     hClose hTmp
-                    ignoreExceptions $ copyPermissions fromFPath tmpFPath
+                    ignoreIOExceptions $ copyPermissions fromFPath tmpFPath
                     renameFile tmpFPath toFPath
           openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp"
-          cleanTmp (tmpFPath, hTmp) = do ignoreExceptions $ hClose hTmp
-                                         ignoreExceptions $ removeFile tmpFPath
+          cleanTmp (tmpFPath, hTmp)
+              = do ignoreIOExceptions $ hClose hTmp
+                   ignoreIOExceptions $ removeFile tmpFPath
           bufferSize = 1024
 
           copyContents hFrom hTo buffer = do
@@ -566,6 +577,10 @@ copyFile fromFPath toFPath =
                   when (count > 0) $ do
                           hPutBuf hTo buffer count
                           copyContents hFrom hTo buffer
+
+          ignoreIOExceptions io = io `catch` ioExceptionIgnorer
+          ioExceptionIgnorer :: IOException -> IO ()
+          ioExceptionIgnorer _ = return ()
 #endif
 
 -- | Given path referring to a file or directory, returns a
@@ -806,20 +821,18 @@ exists and is a directory, and 'False' otherwise.
 -}
 
 doesDirectoryExist :: FilePath -> IO Bool
-doesDirectoryExist name = 
- catchAny
+doesDirectoryExist name =
    (withFileStatus "doesDirectoryExist" name $ \st -> isDirectory st)
-   (\ _ -> return False)
+   `catch` ((\ _ -> return False) :: IOException -> IO Bool)
 
 {- |The operation 'doesFileExist' returns 'True'
 if the argument file exists and is not a directory, and 'False' otherwise.
 -}
 
 doesFileExist :: FilePath -> IO Bool
-doesFileExist name = do 
- catchAny
+doesFileExist name =
    (withFileStatus "doesFileExist" name $ \st -> do b <- isDirectory st; return (not b))
-   (\ _ -> return False)
+   `catch` ((\ _ -> return False) :: IOException -> IO Bool)
 
 {- |The 'getModificationTime' operation returns the
 clock time at which the file or directory was last modified.
@@ -1035,7 +1048,7 @@ getTemporaryDirectory = do
     `Prelude.catch` \e -> if isDoesNotExistError e then return "/tmp"
                           else throw e
 #else
-    `catch` (\ex -> return "/tmp")
+    `Prelude.catch` (\ex -> return "/tmp")
 #endif
 #endif