Commit 2e78aebe authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Rework withTempFile code and use System.IO.openTempFile where available

The System.IO.openTempFile is much better because it opens the temp files
securely. Howver it is only available in base-2 and only of GHC. In base-3
it is available for all implementations. So in practice that means it's only
for GHC and we have to use our compatability implementation for hugs and
nhc98. Not sure of the status for jhc.
parent 5beff690
......@@ -3,62 +3,42 @@
{-# OPTIONS_NHC98 -cpp #-}
{-# OPTIONS_JHC -fcpp #-}
-- #hide
module Distribution.Compat.TempFile (openTempFile, withTempFile) where
module Distribution.Compat.TempFile (openTempFile) where
import System.IO (openFile, Handle, IOMode(ReadWriteMode))
import System.Directory (doesFileExist, removeFile)
import Control.Exception (finally,try)
import System.FilePath ( (</>), (<.>) )
#if (__GLASGOW_HASKELL__ || __HUGS__)
#if __NHC__ || __HUGS__
import System.IO (openFile, Handle, IOMode(ReadWriteMode))
import System.Directory (doesFileExist)
import System.FilePath ((</>))
import System.Posix.Internals (c_getpid)
#else
import System.Posix.Types (CPid(..))
import System.IO (openTempFile)
#endif
-- ------------------------------------------------------------
-- * temporary files
-- ------------------------------------------------------------
-- TODO: this function *really really really* should be
-- eliminated and replaced with System.IO.openTempFile,
-- except that is currently GHC-only for no valid reason.
-- This is here for Haskell implementations that do not come with
-- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9.
-- TODO: Not sure about jhc
#if __NHC__ || __HUGS__
-- use a temporary filename that doesn't already exist.
-- NB. *not* secure (we don't atomically lock the tmp file we get)
openTempFile :: FilePath -> String -> IO (FilePath, Handle)
openTempFile tmp_dir template
= do x <- getProcessID
findTempName x
where
findTempName x
= do let filename = template ++ show x
path = tmp_dir </> filename
b <- doesFileExist path
if b then findTempName (x+1)
else do hnd <- openFile path ReadWriteMode
return (path, hnd)
#if !(__GLASGOW_HASKELL__ || __HUGS__)
foreign import ccall unsafe "getpid" c_getpid :: IO CPid
#endif
getProcessID :: IO Int
getProcessID = c_getpid >>= return . fromIntegral
-- use a temporary filename that doesn't already exist.
-- NB. *not* secure (we don't atomically lock the tmp file we get)
withTempFile :: FilePath -> String -> (FilePath -> IO a) -> IO a
withTempFile tmp_dir extn action
= do x <- getProcessID
findTempName x
where
(templateBase, templateExt) = splitExtension template
findTempName :: Int -> IO (FilePath, Handle)
findTempName x
= do let filename = ("tmp" ++ show x) <.> extn
path = tmp_dir </> filename
= do let path = tmp_dir </> (templateBase ++ show x) <.> templateExt
b <- doesFileExist path
if b then findTempName (x+1)
else action path `finally` try (removeFile path)
else do hnd <- openFile path ReadWriteMode
return (path, hnd)
getProcessID :: IO Int
getProcessID = fmap fromIntegral c_getpid
#endif
......@@ -84,7 +84,6 @@ import Data.List ( nub, isPrefixOf )
import System.Directory ( removeFile, renameFile,
getDirectoryContents, doesFileExist,
getTemporaryDirectory )
import Distribution.Compat.TempFile ( withTempFile )
import System.FilePath ( (</>), (<.>), takeExtension,
takeDirectory, replaceExtension, splitExtension )
import System.IO (openFile, IOMode(WriteMode), hClose, hPutStrLn)
......@@ -131,13 +130,15 @@ configure verbosity hcPath hcPkgPath conf = do
-- we need to find out if ld supports the -x flag
(ldProg, conf''') <- requireProgram verbosity ldProgram' AnyVersion conf''
tempDir <- getTemporaryDirectory
ldx <- withTempFile tempDir "c" $ \testcfile ->
withTempFile tempDir "o" $ \testofile -> do
writeFile testcfile "int foo() {}\n"
ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->
withTempFile tempDir ".o" $ \testofile testohnd -> do
hPutStrLn testchnd "int foo() {}"
hClose testchnd; hClose testohnd
rawSystemProgram verbosity ghcProg ["-c", testcfile,
"-o", testofile]
withTempFile tempDir "o" $ \testofile' ->
withTempFile tempDir ".o" $ \testofile' testohnd' ->
handle (\_ -> return False) $ do
hClose testohnd'
rawSystemProgramStdout verbosity ldProg
["-x", "-r", testofile, "-o", testofile']
return True
......
......@@ -84,14 +84,15 @@ module Distribution.Simple.Program (
) where
import qualified Data.Map as Map
import Distribution.Compat.TempFile (withTempFile)
import Distribution.Simple.Utils (die, debug, warn, rawSystemExit,
rawSystemStdout, rawSystemStdout')
rawSystemStdout, rawSystemStdout',
withTempFile)
import Distribution.Version (Version(..), readVersion, showVersion,
VersionRange(..), withinRange, showVersionRange)
import Distribution.Verbosity
import System.Directory (doesFileExist, removeFile, findExecutable)
import System.FilePath (dropExtension)
import System.IO (hClose)
import System.IO.Error (try)
import Control.Monad (join, foldM)
import Control.Exception as Exception (catch)
......@@ -570,8 +571,8 @@ hsc2hsProgram = (simpleProgram "hsc2hs") {
case maybeVersion of
Nothing -> return Nothing
Just version ->
withTempFile "dist" "hsc" $ \hsc -> do
writeFile hsc ""
withTempFile "dist" ".hsc" $ \hsc hnd -> do
hClose hnd
(str, _) <- rawSystemStdout' verbosity path [hsc, "--cflag=--version"]
try $ removeFile (dropExtension hsc ++ "_hsc_make.c")
case words str of
......
......@@ -70,6 +70,7 @@ module Distribution.Simple.Utils (
currentDir,
dotToSep,
findFile,
withTempFile,
defaultPackageDesc,
findPackageDesc,
defaultHookedPackageDesc,
......@@ -121,13 +122,9 @@ import System.Cmd (system)
import Control.Exception (evaluate)
import System.Process (runProcess, waitForProcess)
#endif
import System.IO (hClose)
import System.IO (Handle, hClose)
#if __GLASGOW_HASKELL__ >= 604
import Distribution.Compat.TempFile (openTempFile)
#else
import Distribution.Compat.TempFile (withTempFile)
#endif
import Distribution.Verbosity
#ifdef DEBUG
......@@ -445,7 +442,15 @@ copyDirectoryRecursiveVerbose verbosity srcDir destDir = do
fmap (filter (not . flip elem [".", ".."]))
. getDirectoryContents
-- | Use a temporary filename that doesn't already exist.
--
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)
-- | 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