Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
Packages
Cabal
Commits
7aefa455
Commit
7aefa455
authored
Aug 11, 2012
by
refold
Browse files
Move 'writeFileAtomic' from D.C.Utils to D.S.Utils.
parent
315af844
Changes
11
Hide whitespace changes
Inline
Side-by-side
Cabal/Cabal.cabal
View file @
7aefa455
...
...
@@ -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
...
...
Cabal/Distribution/PackageDescription/Parse.hs
View file @
7aefa455
...
...
@@ -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
$
...
...
Cabal/Distribution/Simple/Configure.hs
View file @
7aefa455
...
...
@@ -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
)
...
...
Cabal/Distribution/Simple/Hugs.hs
View file @
7aefa455
...
...
@@ -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
]
...
...
Cabal/Distribution/Simple/JHC.hs
View file @
7aefa455
...
...
@@ -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
)
Cabal/Distribution/Simple/Register.hs
View file @
7aefa455
...
...
@@ -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
)
...
...
Cabal/Distribution/Simple/Utils.hs
View file @
7aefa455
...
...
@@ -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
...
...
cabal-install/Distribution/Client/HttpUtils.hs
View file @
7aefa455
...
...
@@ -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.
...
...
cabal-install/Distribution/Client/Update.hs
View file @
7aefa455
...
...
@@ -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"
cabal-install/Distribution/Client/Utils.hs
View file @
7aefa455
...
...
@@ -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
)
cabal-install/Distribution/Client/World.hs
View file @
7aefa455
...
...
@@ -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."
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment