Commit d658a1fa authored by Duncan Coutts's avatar Duncan Coutts
Browse files

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.
parent f027e990
......@@ -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 $
......
......@@ -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 {
......
......@@ -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.
......
......@@ -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 }
......
......@@ -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)
......
......@@ -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
......
......@@ -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)
......
......@@ -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" $
......
......@@ -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
......
......@@ -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.
......
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