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.

Distribution/Compat/TempFile.hs

@@ -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

Distribution/Simple/Utils.hs

@@ -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