[commit: ghc] master: bin-package-db: copy paste writeFileAtomic from Cabal (bdd0b71)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/bdd0b719ea5f116b160bc37a09804d3eff14ecae/ghc

>---------------------------------------------------------------

commit bdd0b719ea5f116b160bc37a09804d3eff14ecae
Author: Thomas Miedema <thomasmiedema at gmail.com>
Date:   Sat Jun 13 16:53:28 2015 +0200

    bin-package-db: copy paste writeFileAtomic from Cabal
    
    renameFile on Windows calls `Win32.mOVEFILE_REPLACE_EXISTING`
    nowadays, which doesn't fail when the targetPath already exists.


>---------------------------------------------------------------

bdd0b719ea5f116b160bc37a09804d3eff14ecae
 libraries/bin-package-db/GHC/PackageDb.hs | 31 ++++++++-----------------------
 1 file changed, 8 insertions(+), 23 deletions(-)

diff --git a/libraries/bin-package-db/GHC/PackageDb.hs b/libraries/bin-package-db/GHC/PackageDb.hs
index 870abd4..672b7eb 100644
--- a/libraries/bin-package-db/GHC/PackageDb.hs
+++ b/libraries/bin-package-db/GHC/PackageDb.hs
@@ -283,32 +283,17 @@ decodeFromFile file decoder =
               `ioeSetErrorString` msg
         loc = "GHC.PackageDb.readPackageDb"
 
+-- Copied from Cabal's Distribution.Simple.Utils.
 writeFileAtomic :: FilePath -> BS.Lazy.ByteString -> IO ()
 writeFileAtomic targetPath content = do
-  let (targetDir, targetName) = splitFileName targetPath
+  let (targetDir, targetFile) = splitFileName targetPath
   Exception.bracketOnError
-    (openBinaryTempFileWithDefaultPermissions targetDir $ targetName <.> "tmp")
-    (\(tmpPath, hnd) -> hClose hnd >> removeFile tmpPath)
-    (\(tmpPath, hnd) -> do
-        BS.Lazy.hPut hnd content
-        hClose hnd
-#if mingw32_HOST_OS || mingw32_TARGET_OS
-        renameFile tmpPath targetPath
-          -- If the targetPath exists then renameFile will fail
-          `catch` \err -> do
-            exists <- doesFileExist targetPath
-            if exists
-              then do removeFile targetPath
-                      -- Big fat hairy race condition
-                      renameFile tmpPath targetPath
-                      -- If the removeFile succeeds and the renameFile fails
-                      -- then we've lost the atomic property.
-              else throwIO (err :: IOException)
-#else
-        renameFile tmpPath targetPath
-#endif
-        )
-
+    (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")
+    (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
+    (\(tmpPath, handle) -> do
+        BS.Lazy.hPut handle content
+        hClose handle
+        renameFile tmpPath targetPath)
 
 instance (BinaryStringRep a, BinaryStringRep b, BinaryStringRep c,
           BinaryStringRep d, BinaryStringRep e) =>