copyFile: try removing the target file before opening it for writing

diff --git a/System/Directory.hs b/System/Directory.hs
index bdd7f3c..5e87c21 100644 (file)
--- a/System/Directory.hs
+++ b/System/Directory.hs
@@ -510,14 +510,23 @@ If the /new/ file already exists, it is atomically replaced by the /old/ file.
 Neither path may refer to an existing directory.
 -}
 copyFile :: FilePath -> FilePath -> IO ()
-copyFile fromFPath toFPath =
+copyFile fromFPath toFPath = do
+       -- We try removing the target file before opening it for
+       -- writing.  In the event that the target file is locked or in
+       -- use, this allows us to replace it safely.  However, it
+       -- leaves a race condition: someone else might create the file
+       -- after we delete it, but there isn't much we can do about
+       -- that.
 #if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))
-       do readFile fromFPath >>= writeFile toFPath
-          try (copyPermissions fromFPath toFPath)
-          return ()
+       contents <- readFile fromFPath
+       try (removeFile toFPath)
+       writeFile toFPath contents
+       try (copyPermissions fromFPath toFPath)
+       return ()
 #else
-       (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
-        bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo ->
+       (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom -> do
+        try (removeFile toFPath)
+        bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo -> do
         allocaBytes bufferSize $ \buffer -> do
                copyContents hFrom hTo buffer
                try (copyPermissions fromFPath toFPath)