Commit bdd0b719 authored by thomie's avatar thomie
Browse files

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.
parent 9aa0e4b2
......@@ -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
(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)
renameFile tmpPath targetPath
(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) =>
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment