    {-# LANGUAGE CPP #-}
    {-# OPTIONS_HADDOCK hide #-}
    module Distribution.Compat.Internal.TempFile (
      openTempFile,
      openBinaryTempFile,
      openNewBinaryFile,
      createTempDirectory,
      ) where

    import Distribution.Compat.Exception

    import System.FilePath        ((</>))

    import System.IO              (Handle, openTempFile, openBinaryTempFile)
    #if defined(__IO_MANAGER_WINIO__)
    import System.IO              (openBinaryTempFileWithDefaultPermissions)
    #else
    import Control.Exception      (onException)
    import Data.Bits              ((.|.))
    import Foreign.C              (CInt, eEXIST, getErrno, errnoToIOError)
    import GHC.IO.Handle.FD       (fdToHandle)
    import System.Posix.Internals (c_open, c_close, o_EXCL, o_BINARY, withFilePath,
                                   o_CREAT, o_RDWR, o_NONBLOCK, o_NOCTTY)
    #endif

    import System.Posix.Internals (c_getpid)
    import System.IO.Error        (isAlreadyExistsError)

    #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)
    import System.Directory       ( createDirectory )
    #else
    import qualified System.Posix
    #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: This file should probably be removed.

    -- This is a copy/paste of the openBinaryTempFile definition, but
    -- it uses 666 rather than 600 for the permissions. Newer versions
    -- of base have a new function with this behavior which we use on
    -- Windows when the new IO manager is used.
    openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)
    openNewBinaryFile :: FilePath -> FilePath -> IO (FilePath, Handle)
    openNewBinaryFile FilePath
    dir FilePath
    template = do
      -- This method can't be used under WINIO. Also the current implementation has
      -- thread safety issues depending on which GHC is used.  On newer GHC's let's
      -- use the built in one.
    #if defined(__IO_MANAGER_WINIO__)
      openBinaryTempFileWithDefaultPermissions dir template
    #else
      CPid
    pid <- IO CPid
    c_getpid
      CPid -> IO (FilePath, Handle)
    forall {t}. (Num t, Show t) => t -> IO (FilePath, Handle)
    findTempName CPid
    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 file path in the hierarchy here.
        (FilePath
    prefix,FilePath
    suffix) =
           case (Char -> Bool) -> FilePath -> (FilePath, FilePath)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    break (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '.') (FilePath -> (FilePath, FilePath))
    -> FilePath -> (FilePath, FilePath)
    forall a b. (a -> b) -> a -> b
    $ FilePath -> FilePath
    forall a. [a] -> [a]
    reverse FilePath
    template of
             -- First case: template contains no '.'s. Just re-reverse it.
             (FilePath
    rev_suffix, FilePath
    "")       -> (FilePath -> FilePath
    forall a. [a] -> [a]
    reverse FilePath
    rev_suffix, FilePath
    "")
             -- 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.)
             (FilePath
    rev_suffix, Char
    '.':FilePath
    rest) -> (FilePath -> FilePath
    forall a. [a] -> [a]
    reverse FilePath
    rest, Char
    '.'Char -> FilePath -> FilePath
    forall a. a -> [a] -> [a]
    :FilePath -> FilePath
    forall a. [a] -> [a]
    reverse FilePath
    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.
             (FilePath, FilePath)
    _                      -> FilePath -> (FilePath, FilePath)
    forall a. HasCallStack => FilePath -> a
    error FilePath
    "bug in System.IO.openTempFile"

        oflags :: CInt
    oflags = CInt
    rw_flags CInt -> CInt -> CInt
    forall a. Bits a => a -> a -> a
    .|. CInt
    o_EXCL CInt -> CInt -> CInt
    forall a. Bits a => a -> a -> a
    .|. CInt
    o_BINARY

        findTempName :: t -> IO (FilePath, Handle)
    findTempName t
    x = do
          CInt
    fd <- FilePath -> (CString -> IO CInt) -> IO CInt
    forall a. FilePath -> (CString -> IO a) -> IO a
    withFilePath FilePath
    filepath ((CString -> IO CInt) -> IO CInt)
    -> (CString -> IO CInt) -> IO CInt
    forall a b. (a -> b) -> a -> b
    $ \ CString
    f ->
                  CString -> CInt -> FileMode -> IO CInt
    c_open CString
    f CInt
    oflags FileMode
    0o666
          if CInt
    fd CInt -> CInt -> Bool
    forall a. Ord a => a -> a -> Bool
    < CInt
    0
           then do
             Errno
    errno <- IO Errno
    getErrno
             if Errno
    errno Errno -> Errno -> Bool
    forall a. Eq a => a -> a -> Bool
    == Errno
    eEXIST
               then t -> IO (FilePath, Handle)
    findTempName (t
    xt -> t -> t
    forall a. Num a => a -> a -> a
    +t
    1)
               else IOError -> IO (FilePath, Handle)
    forall a. IOError -> IO a
    ioError (FilePath -> Errno -> Maybe Handle -> Maybe FilePath -> IOError
    errnoToIOError FilePath
    "openNewBinaryFile" Errno
    errno Maybe Handle
    forall a. Maybe a
    Nothing (FilePath -> Maybe FilePath
    forall a. a -> Maybe a
    Just FilePath
    dir))
           else do
             -- TODO: We want to tell fdToHandle what the file path is,
             -- as any exceptions etc will only be able to report the
             -- FD currently
             Handle
    h <- CInt -> IO Handle
    fdToHandle CInt
    fd IO Handle -> IO CInt -> IO Handle
    forall a b. IO a -> IO b -> IO a
    `onException` CInt -> IO CInt
    c_close CInt
    fd
             (FilePath, Handle) -> IO (FilePath, Handle)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (FilePath
    filepath, Handle
    h)
          where
            filename :: FilePath
    filename        = FilePath
    prefix FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ t -> FilePath
    forall a. Show a => a -> FilePath
    show t
    x FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    suffix
            filepath :: FilePath
    filepath        = FilePath
    dir FilePath -> FilePath -> FilePath
    `combine` FilePath
    filename

            -- FIXME: bits copied from System.FilePath
            combine :: FilePath -> FilePath -> FilePath
    combine FilePath
    a FilePath
    b
                      | FilePath -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null FilePath
    b = FilePath
    a
                      | FilePath -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null FilePath
    a = FilePath
    b
                      | FilePath -> Char
    forall a. [a] -> a
    last FilePath
    a Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    pathSeparator = FilePath
    a FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    b
                      | Bool
    otherwise = FilePath
    a FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ [Char
    pathSeparator] FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    b

    -- FIXME: Copied from GHC.Handle
    std_flags, output_flags, rw_flags :: CInt
    std_flags :: CInt
    std_flags    = CInt
    o_NONBLOCK   CInt -> CInt -> CInt
    forall a. Bits a => a -> a -> a
    .|. CInt
    o_NOCTTY
    output_flags :: CInt
    output_flags = CInt
    std_flags    CInt -> CInt -> CInt
    forall a. Bits a => a -> a -> a
    .|. CInt
    o_CREAT
    rw_flags :: CInt
    rw_flags     = CInt
    output_flags CInt -> CInt -> CInt
    forall a. Bits a => a -> a -> a
    .|. CInt
    o_RDWR

    -- FIXME: Should use System.FilePath library
    pathSeparator :: Char
    #ifdef mingw32_HOST_OS
    pathSeparator = '\\'
    #else
    pathSeparator :: Char
    pathSeparator = Char
    '/'
    #endif
    -- /* __IO_MANAGER_WINIO__ */
    #endif

    createTempDirectory :: FilePath -> String -> IO FilePath
    createTempDirectory :: FilePath -> FilePath -> IO FilePath
    createTempDirectory FilePath
    dir FilePath
    template = do
      CPid
    pid <- IO CPid
    c_getpid
      CPid -> IO FilePath
    forall {t}. (Num t, Show t) => t -> IO FilePath
    findTempName CPid
    pid
      where
        findTempName :: t -> IO FilePath
    findTempName t
    x = do
          let dirpath :: FilePath
    dirpath = FilePath
    dir FilePath -> FilePath -> FilePath
    </> FilePath
    template FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ FilePath
    "-" FilePath -> FilePath -> FilePath
    forall a. [a] -> [a] -> [a]
    ++ t -> FilePath
    forall a. Show a => a -> FilePath
    show t
    x
          Either IOError ()
    r <- IO () -> IO (Either IOError ())
    forall a. IO a -> IO (Either IOError a)
    tryIO (IO () -> IO (Either IOError ()))
    -> IO () -> IO (Either IOError ())
    forall a b. (a -> b) -> a -> b
    $ FilePath -> IO ()
    mkPrivateDir FilePath
    dirpath
          case Either IOError ()
    r of
            Right ()
    _ -> FilePath -> IO FilePath
    forall (m :: * -> *) a. Monad m => a -> m a
    return FilePath
    dirpath
            Left  IOError
    e | IOError -> Bool
    isAlreadyExistsError IOError
    e -> t -> IO FilePath
    findTempName (t
    xt -> t -> t
    forall a. Num a => a -> a -> a
    +t
    1)
                    | Bool
    otherwise              -> IOError -> IO FilePath
    forall a. IOError -> IO a
    ioError IOError
    e

    mkPrivateDir :: String -> IO ()
    #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)
    mkPrivateDir s = createDirectory s
    #else
    mkPrivateDir :: FilePath -> IO ()
    mkPrivateDir FilePath
    s = FilePath -> FileMode -> IO ()
    System.Posix.createDirectory FilePath
    s FileMode
    0o700
    #endif