From 2e78aebe3bb0a05a27e6d8464cca244e6c44187e Mon Sep 17 00:00:00 2001
From: Duncan Coutts <duncan@haskell.org>
Date: Wed, 23 Jan 2008 23:58:47 +0000
Subject: [PATCH] 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.
---
Distribution/Compat/TempFile.hs | 56 +++++++++++----------------------
Distribution/Simple/GHC.hs | 11 ++++---
Distribution/Simple/Program.hs | 9 +++---
Distribution/Simple/Utils.hs | 17 ++++++----
4 files changed, 40 insertions(+), 53 deletions(-)
diff --git a/Distribution/Compat/TempFile.hs b/Distribution/Compat/TempFile.hs
index fc123e7211..5c5bb0c7f6 100644
--- a/Distribution/Compat/TempFile.hs
+++ b/Distribution/Compat/TempFile.hs
@@ -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
diff --git a/Distribution/Simple/GHC.hs b/Distribution/Simple/GHC.hs
index 2657a2b812..8c6c21584b 100644
--- a/Distribution/Simple/GHC.hs
+++ b/Distribution/Simple/GHC.hs
@@ -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
diff --git a/Distribution/Simple/Program.hs b/Distribution/Simple/Program.hs
index 18d2addaba..ac7c77b6f8 100644
--- a/Distribution/Simple/Program.hs
+++ b/Distribution/Simple/Program.hs
@@ -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
diff --git a/Distribution/Simple/Utils.hs b/Distribution/Simple/Utils.hs
index 7b47055311..7fb5a2d700 100644
--- a/Distribution/Simple/Utils.hs
+++ b/Distribution/Simple/Utils.hs
@@ -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.
--
GitLab