Commit 1a496ed1 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Implement openNewBinaryFile in a Compat module

This is like openBinaryTempFile except it doesn't mark the permissions
with 600. This means datafailes get the right permissions when they are
installed.

This should really be in the base package.
parent d0758346
......@@ -5,7 +5,8 @@
{-# OPTIONS_NHC98 -cpp #-}
{-# OPTIONS_JHC -fcpp #-}
-- #hide
module Distribution.Compat.TempFile (openTempFile, openBinaryTempFile) where
module Distribution.Compat.TempFile (openTempFile, openBinaryTempFile,
openNewBinaryFile) where
#if __NHC__ || __HUGS__
import System.IO (openFile, openBinaryFile,
......@@ -19,7 +20,12 @@ foreign import ccall unsafe "getpid" c_getpid :: IO CPid
import System.Posix.Internals (c_getpid)
#endif
#else
import System.IO (openTempFile, openBinaryTempFile)
import System.IO
import Data.Bits
import System.Posix.Internals
import Foreign.C
import GHC.Handle
import Distribution.Compat.Exception
#endif
-- ------------------------------------------------------------
......@@ -61,6 +67,76 @@ openBinaryTempFile tmp_dir template
else do hnd <- openBinaryFile path ReadWriteMode
return (path, hnd)
openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)
openNewBinaryFile = openBinaryTempFile
getProcessID :: IO Int
getProcessID = fmap fromIntegral c_getpid
#else
-- This is a copy/paste of the openBinaryTempFile definition, but
-- if uses 666 rather than 600 for the permissions. The base library
-- needs to be changed to make this better.
openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)
openNewBinaryFile dir template = do
pid <- c_getpid
findTempName pid
where
-- We split off the last extension, so we can use .foo.ext files
-- for temporary files (hidden on Unix OSes). Unfortunately we're
-- below filepath in the hierarchy here.
(prefix,suffix) =
case break (== '.') $ reverse template of
-- First case: template contains no '.'s. Just re-reverse it.
(rev_suffix, "") -> (reverse rev_suffix, "")
-- Second case: template contains at least one '.'. Strip the
-- dot from the prefix and prepend it to the suffix (if we don't
-- do this, the unique number will get added after the '.' and
-- thus be part of the extension, which is wrong.)
(rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
-- Otherwise, something is wrong, because (break (== '.')) should
-- always return a pair with either the empty string or a string
-- beginning with '.' as the second component.
_ -> error "bug in System.IO.openTempFile"
oflags = rw_flags .|. o_EXCL .|. o_BINARY
findTempName x = do
fd <- withCString filepath $ \ f ->
c_open f oflags 0o666
if fd < 0
then do
errno <- getErrno
if errno == eEXIST
then findTempName (x+1)
else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
else do
-- XXX We want to tell fdToHandle what the filepath is,
-- as any exceptions etc will only be able to report the
-- fd currently
h <- fdToHandle fd `onException` c_close fd
return (filepath, h)
where
filename = prefix ++ show x ++ suffix
filepath = dir `combine` filename
-- XXX bits copied from System.FilePath, since that's not available here
combine a b
| null b = a
| null a = b
| last a == pathSeparator = a ++ b
| otherwise = a ++ [pathSeparator] ++ b
-- XXX Should use filepath library
pathSeparator :: Char
#ifdef mingw32_HOST_OS
pathSeparator = '\\'
#else
pathSeparator = '/'
#endif
-- XXX Copied from GHC.Handle
std_flags, output_flags, rw_flags :: CInt
std_flags = o_NONBLOCK .|. o_NOCTTY
output_flags = std_flags .|. o_CREAT
rw_flags = output_flags .|. o_RDWR
#endif
......@@ -165,7 +165,8 @@ import System.Cmd (system)
import System.Directory (getTemporaryDirectory)
#endif
import Distribution.Compat.TempFile (openTempFile, openBinaryTempFile)
import Distribution.Compat.TempFile (openTempFile,
openNewBinaryFile)
import Distribution.Compat.Exception (catchIO, onException)
#if mingw32_HOST_OS || mingw32_TARGET_OS
import Distribution.Compat.Exception (throwIOIO)
......@@ -609,7 +610,7 @@ withFileContents name action =
--
writeFileAtomic :: FilePath -> String -> IO ()
writeFileAtomic targetFile content = do
(tmpFile, tmpHandle) <- openBinaryTempFile targetDir template
(tmpFile, tmpHandle) <- openNewBinaryFile targetDir template
do hPutStr tmpHandle content
hClose tmpHandle
#if mingw32_HOST_OS || mingw32_TARGET_OS
......
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