Add writeFileAtomic to and use it everywhere in place of ordinary writeFile

It uses the renaming trick to make the write atomic.
Not yet tested on Windows.

Distribution/PackageDescription/Parse.hs

@@ -75,7 +75,8 @@ import Distribution.Version (Dependency, showVersion, parseVersion,
 import Distribution.Verbosity (Verbosity)
 import Distribution.Compiler  (CompilerFlavor(..))
 import Distribution.PackageDescription.Configuration (parseCondition, freeVars)
-import Distribution.Simple.Utils (die, dieWithLocation, warn, intercalate)
+import Distribution.Simple.Utils
+         ( die, dieWithLocation, warn, intercalate, writeFileAtomic )
 
 
 -- -----------------------------------------------------------------------------
@@ -708,7 +709,7 @@ parseHookedBuildInfo inp = do
 -- Pretty printing
 
 writePackageDescription :: FilePath -> PackageDescription -> IO ()
-writePackageDescription fpath pkg = writeFile fpath (showPackageDescription pkg)
+writePackageDescription fpath pkg = writeFileAtomic fpath (showPackageDescription pkg)
 
 showPackageDescription :: PackageDescription -> String
 showPackageDescription pkg = render $
@@ -728,7 +729,7 @@ ppCustomField :: (String,String) -> Doc
 ppCustomField (name,val) = text name <> colon <+> showFreeText val
 
 writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO ()
-writeHookedBuildInfo fpath pbi = writeFile fpath (showHookedBuildInfo pbi)
+writeHookedBuildInfo fpath pbi = writeFileAtomic fpath (showHookedBuildInfo pbi)
 
 showHookedBuildInfo :: HookedBuildInfo -> String
 showHookedBuildInfo (mb_lib_bi, ex_bi) = render $

Distribution/Simple/Build.hs

@@ -60,7 +60,8 @@ import Distribution.Simple.LocalBuildInfo
 import Distribution.Simple.BuildPaths ( autogenModuleName )
 import Distribution.Simple.Configure
 				( localBuildInfoFile )
-import Distribution.Simple.Utils( createDirectoryIfMissingVerbose, die, setupMessage )
+import Distribution.Simple.Utils
+        ( createDirectoryIfMissingVerbose, die, setupMessage, writeFileAtomic )
 import Distribution.System
 
 import System.FilePath          ( (</>), pathSeparator )
@@ -216,7 +217,7 @@ buildPathsModule pkg_descr lbi =
    	            then getModificationTime paths_filepath
    	            else return btime
 	 if btime >= ptime
-	   then writeFile paths_filepath (header++body)
+	   then writeFileAtomic paths_filepath (header++body)
 	   else return ()
  where
 	InstallDirs {

Distribution/Simple/Configure.hs

@@ -94,7 +94,7 @@ import Distribution.Simple.BuildPaths
     ( distPref )
 import Distribution.Simple.Utils
     ( die, warn, info, setupMessage, createDirectoryIfMissingVerbose
-    , intercalate, comparing )
+    , intercalate, comparing, writeFileAtomic )
 import Distribution.Simple.Register
     ( removeInstalledConfig )
 import Distribution.System
@@ -171,7 +171,7 @@ maybeGetPersistBuildConfig = do
 writePersistBuildConfig :: LocalBuildInfo -> IO ()
 writePersistBuildConfig lbi = do
   createDirectoryIfMissing False distPref
-  writeFile localBuildInfoFile (show lbi)
+  writeFileAtomic localBuildInfoFile (show lbi)
 
 -- |Check that localBuildInfoFile is up-to-date with respect to the
 -- .cabal file.

Distribution/Simple/Hugs.hs

@@ -60,9 +60,10 @@ import Distribution.Simple.LocalBuildInfo
 import Distribution.Simple.BuildPaths
                                 ( autogenModuleName, autogenModulesDir,
                                   dllExtension )
-import Distribution.Simple.Utils( createDirectoryIfMissingVerbose, dotToSep,
-				  findFileWithExtension, die, info, notice,
-				  smartCopySources, findFile )
+import Distribution.Simple.Utils
+         ( createDirectoryIfMissingVerbose, writeFileAtomic
+				 , findFile, dotToSep, findFileWithExtension, smartCopySources
+         , die, info, notice )
 import Language.Haskell.Extension
 				( Extension(..) )
 import System.FilePath        	( (</>), takeExtension, (<.>),
@@ -382,7 +383,7 @@ install verbosity libDir installProgDir binDir targetProgDir buildPref (progpref
                              let args = hugsOptions ++ [targetName, "\"$@\""]
                              in unlines ["#! /bin/sh",
                                          unwords ("runhugs" : args)]
-        writeFile exeFile script
+        writeFileAtomic exeFile script
         perms <- getPermissions exeFile
         setPermissions exeFile perms { executable = True, readable = True }
 

Distribution/Simple/JHC.hs

@@ -69,8 +69,9 @@ import Distribution.Simple.Program     ( ConfiguredProgram(..), jhcProgram,
 import Distribution.Version	( VersionRange(AnyVersion) )
 import Distribution.Package  	( PackageIdentifier(..), showPackageId,
                                   parsePackageId, Package(..) )
-import Distribution.Simple.Utils( createDirectoryIfMissingVerbose,
-                                  copyFileVerbose, die, info, intercalate )
+import Distribution.Simple.Utils
+        ( createDirectoryIfMissingVerbose, copyFileVerbose, writeFileAtomic
+        , die, info, intercalate )
 import System.FilePath          ( (</>) )
 import Distribution.Verbosity
 import Distribution.Compat.ReadP
@@ -139,7 +140,7 @@ build pkg_descr lbi verbosity = do
       let pkgid = showPackageId (packageId pkg_descr)
           pfile = buildDir lbi </> "jhc-pkg.conf"
           hlfile= buildDir lbi </> (pkgid ++ ".hl")
-      writeFile pfile $ jhcPkgConf pkg_descr
+      writeFileAtomic pfile $ jhcPkgConf pkg_descr
       rawSystemProgram verbosity jhcProg ["--build-hl="++pfile, "-o", hlfile]
   withExe pkg_descr $ \exe -> do
       info verbosity ("Building executable "++exeName exe)

Distribution/Simple/PreProcess.hs

@@ -63,7 +63,7 @@ import Distribution.Package (showPackageId, Package(..))
 import Distribution.Simple.Compiler (CompilerFlavor(..), Compiler(..), compilerVersion)
 import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))
 import Distribution.Simple.Utils
-         ( createDirectoryIfMissingVerbose, die, setupMessage
+         ( createDirectoryIfMissingVerbose, writeFileAtomic, die, setupMessage
          , findFileWithExtension, findFileWithExtension', dotToSep )
 import Distribution.Simple.Program (Program(..), ConfiguredProgram(..),
                              lookupProgram, programPath,
@@ -270,7 +270,7 @@ ppUnlit =
     platformIndependent = True,
     runPreProcessor = mkSimplePreProcessor $ \inFile outFile _verbosity -> do
       contents <- readFile inFile
-      either (writeFile outFile) die (unlit inFile contents)
+      either (writeFileAtomic outFile) die (unlit inFile contents)
   }
 
 ppCpp :: BuildInfo -> LocalBuildInfo -> PreProcessor

Distribution/Simple/Register.hs

@@ -68,8 +68,9 @@ import Distribution.InstalledPackageInfo
 	(InstalledPackageInfo, showInstalledPackageInfo, 
 	 emptyInstalledPackageInfo)
 import qualified Distribution.InstalledPackageInfo as IPI
-import Distribution.Simple.Utils (createDirectoryIfMissingVerbose,
-                                  copyFileVerbose, die, info, setupMessage)
+import Distribution.Simple.Utils
+         ( createDirectoryIfMissingVerbose, copyFileVerbose, writeFileAtomic
+         , die, info, setupMessage )
 import Distribution.System
 
 import System.FilePath ((</>), (<.>), isAbsolute)
@@ -172,7 +173,7 @@ writeInstalledConfig pkg_descr lbi inplace instConfOverride = do
   let instConfDefault | inplace   = inplacePkgConfigFile
                       | otherwise = installedPkgConfigFile
       instConf = fromMaybe instConfDefault instConfOverride
-  writeFile instConf (pkg_config ++ "\n")
+  writeFileAtomic instConf (pkg_config ++ "\n")
 
 -- |Create a string suitable for writing out to the package config file
 showInstalledConfig :: PackageDescription -> LocalBuildInfo -> Bool
@@ -310,8 +311,8 @@ rawSystemEmit :: ConfiguredProgram  -- ^Program to run
 rawSystemEmit prog scriptName extraArgs
  = case os of
        Windows _ ->
-           writeFile scriptName ("@" ++ path ++ concatMap (' ':) args)
-       _ -> do writeFile scriptName ("#!/bin/sh\n\n"
+           writeFileAtomic scriptName ("@" ++ path ++ concatMap (' ':) args)
+       _ -> do writeFileAtomic scriptName ("#!/bin/sh\n\n"
                                   ++ (path ++ concatMap (' ':) args)
                                   ++ "\n")
                p <- getPermissions scriptName
@@ -328,8 +329,8 @@ rawSystemPipe :: ConfiguredProgram
 rawSystemPipe prog scriptName pipeFrom extraArgs
  = case os of
        Windows _ ->
-           writeFile scriptName ("@" ++ path ++ concatMap (' ':) args)
-       _ -> do writeFile scriptName ("#!/bin/sh\n\n"
+           writeFileAtomic scriptName ("@" ++ path ++ concatMap (' ':) args)
+       _ -> do writeFileAtomic scriptName ("#!/bin/sh\n\n"
                                   ++ "echo '" ++ escapeForShell pipeFrom
                                   ++ "' | "
                                   ++ (path ++ concatMap (' ':) args)

Distribution/Simple/SetupWrapper.hs

@@ -99,7 +99,7 @@ setupWrapper args mdir = inDir mdir $ do
 	then mainAction args -- current version is OK, so no need
 			     -- to compile a special Setup.hs.
 	else do createDirectoryIfMissingVerbose verbosity True setupDir
-	        writeFile setupHs mainText
+	        writeFileAtomic setupHs mainText
 		trySetupScript setupHs $ error "panic! shouldn't happen"
     Nothing ->
       trySetupScript "Setup.hs"  $

Distribution/Simple/SrcDist.hs

@@ -59,10 +59,10 @@ import Distribution.PackageDescription
 import Distribution.PackageDescription.Check
 import Distribution.Package (showPackageId, PackageIdentifier(pkgVersion), Package(..))
 import Distribution.Version (Version(versionBranch), VersionRange(AnyVersion))
-import Distribution.Simple.Utils (createDirectoryIfMissingVerbose,
-                                  die, warn, notice, setupMessage, defaultPackageDesc,
-                                  findFile, findFileWithExtension,
-                                  dotToSep, copyFiles, copyFileVerbose)
+import Distribution.Simple.Utils
+        ( createDirectoryIfMissingVerbose, writeFileAtomic, copyFiles
+        , copyFileVerbose, findFile, findFileWithExtension, dotToSep
+        , die, warn, notice, setupMessage, defaultPackageDesc )
 import Distribution.Simple.Setup (SDistFlags(..), fromFlag)
 import Distribution.Simple.PreProcess (PPSuffixHandler, ppSuffixes, preprocessSources)
 import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
@@ -168,7 +168,7 @@ prepareTree pkg_descr verbosity mb_lbi snapshot tmpDir pps date = do
   lhsExists <- doesFileExist "Setup.lhs"
   if hsExists then copyFileTo verbosity targetDir "Setup.hs"
     else if lhsExists then copyFileTo verbosity targetDir "Setup.lhs"
-    else writeFile (targetDir </> "Setup.hs") $ unlines [
+    else writeFileAtomic (targetDir </> "Setup.hs") $ unlines [
                 "import Distribution.Simple",
                 "main = defaultMainWithHooks defaultUserHooks"]
   -- the description file itself
@@ -178,7 +178,7 @@ prepareTree pkg_descr verbosity mb_lbi snapshot tmpDir pps date = do
   -- but that would lose comments and formatting.
   if snapshot then do
       contents <- readFile descFile
-      writeFile targetDescFile $
+      writeFileAtomic targetDescFile $
           unlines $ map (appendVersion date) $ lines $ contents
     else copyFileVerbose verbosity descFile targetDescFile
   return targetDir

Distribution/Simple/Utils.hs

@@ -77,6 +77,7 @@ module Distribution.Simple.Utils (
         findFileWithExtension,
         findFileWithExtension',
         withTempFile,
+        writeFileAtomic,
 
         -- * .cabal and .buildinfo files
         defaultPackageDesc,
@@ -110,15 +111,15 @@ import System.Cmd
 import System.Exit
     ( exitWith, ExitCode(..) )
 import System.FilePath
-    ( takeDirectory, takeExtension, (</>), (<.>), pathSeparator )
+    ( takeDirectory, splitFileName, takeExtension, (</>), (<.>), pathSeparator )
 import System.Directory
-    ( copyFile, createDirectoryIfMissing )
+    ( copyFile, createDirectoryIfMissing, renameFile )
 import System.IO
-    ( hPutStrLn, stderr, hFlush, stdout )
-import System.IO.Error
+    ( hPutStrLn, hPutStr, hClose  , stderr, hFlush, stdout )
+import System.IO.Error as IO.Error
     ( try )
-import Control.Exception
-    ( bracket )
+import qualified Control.Exception as Exception
+    ( bracket, bracketOnError, catch )
 
 import Distribution.Package
     (PackageIdentifier(..), showPackageId)
@@ -134,7 +135,7 @@ import System.IO (hGetContents)
 import System.Cmd (system)
 import System.Directory (getTemporaryDirectory)
 #endif
-import System.IO (Handle, hClose)
+import System.IO (Handle)
 
 import Distribution.Compat.TempFile (openTempFile)
 import Distribution.Verbosity
@@ -210,7 +211,7 @@ chattyTry :: String  -- ^ a description of the action we were attempting
           -> IO ()   -- ^ the action itself
           -> IO ()
 chattyTry desc action =
-  catch action $ \exception ->
+  Exception.catch action $ \exception ->
     putStrLn $ "Error while " ++ desc ++ ": " ++ show exception
 
 -- -----------------------------------------------------------------------------
@@ -272,8 +273,9 @@ rawSystemStdout' verbosity path args = do
   printRawCommandAndArgs verbosity path args
 
 #ifdef __GLASGOW_HASKELL__
-  bracket (runInteractiveProcess path args Nothing Nothing)
-          (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)
+  Exception.bracket
+     (runInteractiveProcess path args Nothing Nothing)
+     (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)
     $ \(_,outh,errh,pid) -> do
 
       -- fork off a thread to pull on (and discard) the stderr
@@ -468,9 +470,65 @@ withTempFile :: FilePath -- ^ Temp dir to create the file in
              -> String   -- ^ File name template. See 'openTempFile'.
              -> (FilePath -> Handle -> IO a) -> IO a
 withTempFile tmpDir template action =
-  bracket (openTempFile tmpDir template)
-          (\(name, handle) -> hClose handle >> removeFile name)
-          (uncurry action)
+  Exception.bracket
+    (openTempFile tmpDir template)
+    (\(name, handle) -> hClose handle >> removeFile name)
+    (uncurry action)
+
+-- | Writes a file atomically.
+--
+-- The file is either written sucessfully or an IO exception is raised and
+-- the original file is left unchanged.
+--
+-- * Warning: On Windows this operation is very nearly but not quite atomic.
+--   See below.
+--
+-- On Posix it works by writing a temporary file and atomically renaming over
+-- the top any pre-existing target file with the temporary one.
+--
+-- On Windows it is not possible to rename over an existing file so the target
+-- file has to be deleted before the temporary file is renamed to the target.
+-- Therefore there is a race condition between the existing file being removed
+-- and the temporary file being renamed. Another thread could write to the
+-- target or change the permission on the target directory between the deleting
+-- and renaming steps. An exception would be raised but the target file would
+-- either no longer exist or have the content as written by the other thread.
+--
+-- On windows it is not possible to delete a file that is open by a process.
+-- This case will give an IO exception but the atomic property is not affected.
+--
+writeFileAtomic :: FilePath -> String -> IO ()
+writeFileAtomic targetFile content = do
+  Exception.bracketOnError
+    (openTempFile targetDir template)
+    (\(tmpFile, tmpHandle) -> IO.Error.try (hClose tmpHandle)
+                           >> IO.Error.try (removeFile tmpFile))
+    $ \(tmpFile, tmpHandle) -> do
+      hPutStr tmpHandle content
+      hClose tmpHandle
+#if mingw32_HOST_OS || mingw32_TARGET_OS
+      renameFile tmpFile targetFile
+        -- If the targetFile exists then renameFile will fail
+        `Exception.catch` \err -> do
+          exists <- fileExists targetFile
+          if exists
+            then do deleteFile targetFile
+                    -- Big fat hairy race condition
+                    renameFile tmpFile targetFile
+                    -- If the deleteFile succeeds and the renameFile fails
+                    -- then we've lost the 
+            else ioError err
+#else
+      renameFile tmpFile targetFile
+#endif
+  where
+    template = targetName <.> "tmp"
+    targetDir | null targetDir_ = currentDir
+              | otherwise       = targetDir_
+    --TODO: remove this when takeDirectory/splitFileName is fixed
+    --      to always return a valid dir
+    (targetDir_,targetName) = splitFileName targetFile
+
 
 -- | The path name that represents the current directory.
 -- In Unix, it's @\".\"@, but this is system-specific.