Commit 7aefa455 authored by refold's avatar refold
Browse files

Move 'writeFileAtomic' from D.C.Utils to D.S.Utils.

parent 315af844
......@@ -37,6 +37,8 @@ Flag base4
Flag base3
Description: Choose the new smaller, split-up base package.
Flag bytestring-in-base
Library
build-depends: base >= 2 && < 5,
filepath >= 1 && < 1.4
......@@ -49,6 +51,10 @@ Library
containers >= 0.1 && < 0.6,
array >= 0.1 && < 0.5,
pretty >= 1 && < 1.2
if flag(bytestring-in-base)
Build-Depends: base >= 2.0 && < 2.2
else
Build-Depends: base < 2.0 || >= 3.0, bytestring >= 0.9
if !os(windows)
Build-Depends: unix >= 2.0 && < 2.7
......
......@@ -74,6 +74,7 @@ import Data.Monoid ( Monoid(..) )
import Data.List (nub, unfoldr, partition, (\\))
import Control.Monad (liftM, foldM, when, unless)
import System.Directory (doesFileExist)
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
import Distribution.Text
( Text(disp, parse), display, simpleParse )
......@@ -1168,7 +1169,8 @@ ppCustomField :: (String,String) -> Doc
ppCustomField (name,val) = text name <> colon <+> showFreeText val
writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO ()
writeHookedBuildInfo fpath = writeFileAtomic fpath . showHookedBuildInfo
writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack
. showHookedBuildInfo
showHookedBuildInfo :: HookedBuildInfo -> String
showHookedBuildInfo (mb_lib_bi, ex_bis) = render $
......
......@@ -151,6 +151,8 @@ import Text.PrettyPrint
( comma, punctuate, render, nest, sep )
import Distribution.Compat.Exception ( catchExit, catchIO )
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
tryGetConfigStateFile :: (Read a) => FilePath -> IO (Either String a)
tryGetConfigStateFile filename = do
exists <- doesFileExist filename
......@@ -214,7 +216,7 @@ writePersistBuildConfig :: FilePath -> LocalBuildInfo -> IO ()
writePersistBuildConfig distPref lbi = do
createDirectoryIfMissing False distPref
writeFileAtomic (localBuildInfoFile distPref)
(showHeader pkgid ++ '\n' : show lbi)
(BS.Char8.pack $ showHeader pkgid ++ '\n' : show lbi)
where
pkgid = packageId (localPkgDescr lbi)
......
......@@ -119,6 +119,8 @@ import System.Exit
( ExitCode(ExitSuccess) )
import Distribution.Compat.Exception
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
-- -----------------------------------------------------------------------------
-- Configuring
......@@ -597,7 +599,7 @@ install verbosity lbi libDir installProgDir binDir targetProgDir buildPref (prog
let args = hugsOptions ++ [targetName, "\"$@\""]
in unlines ["#! /bin/sh",
unwords ("runhugs" : args)]
writeFileAtomic exeFile script
writeFileAtomic exeFile (BS.Char8.pack script)
setFileExecutable exeFile
hugsInstallSuffixes :: [String]
......
......@@ -89,6 +89,8 @@ import Data.List ( nub )
import Data.Char ( isSpace )
import Data.Maybe ( fromMaybe )
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
-- -----------------------------------------------------------------------------
-- Configuring
......@@ -161,7 +163,7 @@ buildLib verbosity pkg_descr lbi lib clbi = do
let pkgid = display (packageId pkg_descr)
pfile = buildDir lbi </> "jhc-pkg.conf"
hlfile= buildDir lbi </> (pkgid ++ ".hl")
writeFileAtomic pfile $ jhcPkgConf pkg_descr
writeFileAtomic pfile . BS.Char8.pack $ jhcPkgConf pkg_descr
rawSystemProgram verbosity jhcProg $
["--build-hl="++pfile, "-o", hlfile] ++
args ++ map display (libModules lib)
......@@ -218,4 +220,3 @@ installExe verb dest build_dir (progprefix,progsuffix) _ exe = do
out = (progprefix ++ exe_name ++ progsuffix) </> exeExtension
createDirectoryIfMissingVerbose verb True dest
installExecutableFile verb (build_dir </> src) (dest </> out)
......@@ -113,7 +113,7 @@ import Data.Maybe
( isJust, fromMaybe, maybeToList )
import Data.List
( partition, nub )
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
-- -----------------------------------------------------------------------------
-- Registration
......@@ -377,7 +377,7 @@ unregister pkg lbi regFlags = do
packageDb pkgid
in if genScript
then writeFileAtomic unregScriptFileName
(invocationAsSystemScript buildOS invocation)
(BS.Char8.pack $ invocationAsSystemScript buildOS invocation)
else runProgramInvocation verbosity invocation
Hugs -> do
_ <- tryIO $ removeDirectoryRecursive (libdir installDirs)
......
......@@ -147,6 +147,8 @@ import Data.Char as Char
( toLower, chr, ord )
import Data.Bits
( Bits((.|.), (.&.), shiftL, shiftR) )
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
import System.Directory
( getDirectoryContents, doesDirectoryExist, doesFileExist, removeFile
......@@ -163,7 +165,8 @@ import System.FilePath
import System.Directory
( createDirectory, renameFile, removeDirectoryRecursive )
import System.IO
( Handle, openFile, openBinaryFile, IOMode(ReadMode), hSetBinaryMode
( Handle, openFile, openBinaryFile, openBinaryTempFile
, IOMode(ReadMode), hSetBinaryMode
, hGetContents, stderr, stdout, hPutStr, hFlush, hClose )
import System.IO.Error as IO.Error
( isDoesNotExistError, isAlreadyExistsError
......@@ -200,9 +203,9 @@ import Distribution.Compat.CopyFile
( copyFile, copyOrdinaryFile, copyExecutableFile
, setFileOrdinary, setFileExecutable, setDirOrdinary )
import Distribution.Compat.TempFile
( openTempFile, openNewBinaryFile, createTempDirectory )
( openTempFile, createTempDirectory )
import Distribution.Compat.Exception
( IOException, throwIOIO, tryIO, catchIO, catchExit, onException )
( IOException, throwIOIO, tryIO, catchIO, catchExit )
import Distribution.Verbosity
#ifdef VERSION_base
......@@ -918,21 +921,16 @@ withFileContents name action =
-- 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
(tmpFile, tmpHandle) <- openNewBinaryFile targetDir template
do hPutStr tmpHandle content
hClose tmpHandle
renameFile tmpFile targetFile
`onException` do hClose tmpHandle
removeFile tmpFile
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
writeFileAtomic :: FilePath -> BS.ByteString -> IO ()
writeFileAtomic targetPath content = do
let (targetDir, targetFile) = splitFileName targetPath
Exception.bracketOnError
(openBinaryTempFile targetDir $ targetFile <.> "tmp")
(\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
(\(tmpPath, handle) -> do
BS.hPut handle content
hClose handle
renameFile tmpPath targetPath)
-- | Write a file but only if it would have new content. If we would be writing
-- the same as the existing content then leave the file as is so that we do not
......@@ -944,9 +942,10 @@ rewriteFile path newContent =
existingContent <- readFile path
_ <- evaluate (length existingContent)
unless (existingContent == newContent) $
writeFileAtomic path newContent
writeFileAtomic path (BS.Char8.pack newContent)
where
mightNotExist e | isDoesNotExistError e = writeFileAtomic path newContent
mightNotExist e | isDoesNotExistError e = writeFileAtomic path
(BS.Char8.pack newContent)
| otherwise = ioError e
-- | The path name that represents the current directory.
......@@ -1112,7 +1111,7 @@ withUTF8FileContents name action =
-- Uses 'writeFileAtomic', so provides the same guarantees.
--
writeUTF8File :: FilePath -> String -> IO ()
writeUTF8File path = writeFileAtomic path . toUTF8
writeUTF8File path = writeFileAtomic path . BS.Char8.pack . toUTF8
-- | Fix different systems silly line ending conventions
normaliseLineEndings :: String -> String
......
......@@ -190,7 +190,7 @@ downloadURI verbosity uri path = do
Left err -> die $ "Failed to download " ++ show uri ++ " : " ++ show err
Right body -> do
info verbosity ("Downloaded to " ++ path)
writeFileAtomic path (ByteString.unpack body)
writeFileAtomic path body
--FIXME: check the content-length header matches the body length.
--TODO: stream the download into the file rather than buffering the whole
-- thing in memory.
......
......@@ -21,8 +21,6 @@ import Distribution.Client.FetchUtils
import qualified Distribution.Client.PackageIndex as PackageIndex
import Distribution.Client.IndexUtils
( getSourcePackages, updateRepoIndexCache )
import Distribution.Client.Utils
( writeFileAtomic )
import qualified Paths_cabal_install
( version )
......@@ -31,7 +29,7 @@ import Distribution.Package
import Distribution.Version
( anyVersion, withinRange )
import Distribution.Simple.Utils
( warn, notice )
( writeFileAtomic, warn, notice )
import Distribution.Verbosity
( Verbosity )
......@@ -80,4 +78,3 @@ checkForSelfUpgrade verbosity repos = do
notice verbosity $
"Note: there is a new version of cabal-install available.\n"
++ "To upgrade, run: cabal install cabal-install"
......@@ -2,8 +2,7 @@
module Distribution.Client.Utils ( MergeResult(..)
, mergeBy, duplicates, duplicatesBy
, moreRecentFile, inDir, numberOfProcessors
, writeFileAtomic )
, moreRecentFile, inDir, numberOfProcessors )
where
import Data.List
......@@ -11,14 +10,10 @@ import Data.List
import Foreign.C.Types ( CInt(..) )
import System.Directory
( doesFileExist, getModificationTime
, getCurrentDirectory, setCurrentDirectory
, renameFile, removeFile )
import System.FilePath ( splitFileName, (<.>) )
import System.IO ( openBinaryTempFile, hClose )
, getCurrentDirectory, setCurrentDirectory )
import System.IO.Unsafe ( unsafePerformIO )
import qualified Control.Exception as Exception
( bracketOnError, finally )
import qualified Data.ByteString.Lazy as BS
( finally )
-- | Generic merging utility. For sorted input lists this is a full outer join.
--
......@@ -77,22 +72,3 @@ foreign import ccall "getNumberOfProcessors" c_getNumberOfProcessors :: IO CInt
-- program, so unsafePerformIO is safe here.
numberOfProcessors :: Int
numberOfProcessors = fromEnum $ unsafePerformIO c_getNumberOfProcessors
-- | Writes a file atomically.
--
-- The file is either written sucessfully or an IO exception is raised and
-- the original file is left unchanged.
--
-- 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 -> BS.ByteString -> IO ()
writeFileAtomic targetPath content = do
let (targetDir, targetFile) = splitFileName targetPath
Exception.bracketOnError
(openBinaryTempFile targetDir $ targetFile <.> "tmp")
(\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
(\(tmpPath, handle) -> do
BS.hPut handle content
hClose handle
renameFile tmpPath targetPath)
......@@ -102,7 +102,7 @@ modifyWorld f verbosity world pkgs =
all (`elem` pkgsNewWorld) pkgsOldWorld)
then do
info verbosity "Updating world file..."
writeFileAtomic world $ unlines
writeFileAtomic world . B.pack $ unlines
[ (display pkg) | pkg <- pkgsNewWorld]
else
info verbosity "World file is already up to date."
......
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