bin-package-db: copy paste writeFileAtomic from Cabal
authorThomas Miedema <thomasmiedema@gmail.com>
Sat, 13 Jun 2015 14:53:28 +0000 (16:53 +0200)
committerThomas Miedema <thomasmiedema@gmail.com>
Thu, 2 Jul 2015 08:27:12 +0000 (10:27 +0200)
renameFile on Windows calls `Win32.mOVEFILE_REPLACE_EXISTING`
nowadays, which doesn't fail when the targetPath already exists.

libraries/bin-package-db/GHC/PackageDb.hs

index 870abd4..672b7eb 100644 (file)
@@ -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) =>