{-# OPTIONS -cpp #-}
-- OPTIONS required for ghc-6.4.x compat, and must appear first
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -cpp #-}
{-# OPTIONS_NHC98 -cpp #-}
{-# OPTIONS_JHC -fcpp #-}
-- #hide
module Distribution.Compat.TempFile (openTempFile, openBinaryTempFile,
                                     openNewBinaryFile) where

#if __NHC__ || __HUGS__
import System.IO              (openFile, openBinaryFile,
                               Handle, IOMode(ReadWriteMode))
import System.Directory       (doesFileExist)
import System.FilePath        ((</>), (<.>), splitExtension)
#if __NHC__
import System.Posix.Types (CPid(..))
foreign import ccall unsafe "getpid" c_getpid :: IO CPid
#else
import System.Posix.Internals (c_getpid)
#endif
#else
import System.IO
import Data.Bits
import System.Posix.Internals
import Foreign.C
import GHC.Handle
import Distribution.Compat.Exception
#endif

-- ------------------------------------------------------------
-- * temporary files
-- ------------------------------------------------------------

-- 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
    (templateBase, templateExt) = splitExtension template
    findTempName :: Int -> IO (FilePath, Handle)
    findTempName x
      = do let path = tmp_dir </> (templateBase ++ show x) <.> templateExt
           b  <- doesFileExist path
           if b then findTempName (x+1)
                else do hnd <- openFile path ReadWriteMode
                        return (path, hnd)

openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)
openBinaryTempFile tmp_dir template
  = do x <- getProcessID
       findTempName x
  where
    (templateBase, templateExt) = splitExtension template
    findTempName :: Int -> IO (FilePath, Handle)
    findTempName x
      = do let path = tmp_dir </> (templateBase ++ show x) <.> templateExt
           b  <- doesFileExist path
           if b then findTempName (x+1)
                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 <-
#if __GLASGOW_HASKELL__ >= 609
              fdToHandle fd
#elif __GLASGOW_HASKELL__ <= 606 && defined(mingw32_HOST_OS)
              -- fdToHandle is borked on Windows with ghc-6.6.x
              openFd (fromIntegral fd) Nothing False filepath
                                       ReadWriteMode True
#else
              fdToHandle (fromIntegral fd)
#endif
              `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