diff options
| author | Thomas Miedema <thomasmiedema@gmail.com> | 2015-06-13 16:53:28 +0200 |
|---|---|---|
| committer | Thomas Miedema <thomasmiedema@gmail.com> | 2015-07-02 10:27:12 +0200 |
| commit | bdd0b719ea5f116b160bc37a09804d3eff14ecae (patch) | |
| tree | d8fa11ba5f549d058ef84ae45afe2377cdb1869d /libraries | |
| parent | 9aa0e4b23d074af44363236fb0f120f07c6e0067 (diff) | |
| download | haskell-bdd0b719ea5f116b160bc37a09804d3eff14ecae.tar.gz | |
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.
Diffstat (limited to 'libraries')
| -rw-r--r-- | libraries/bin-package-db/GHC/PackageDb.hs | 31 |
1 files changed, 8 insertions, 23 deletions
diff --git a/libraries/bin-package-db/GHC/PackageDb.hs b/libraries/bin-package-db/GHC/PackageDb.hs index 870abd45ec..672b7ebbe3 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) => |