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