{-# 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
openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)
openNewBinaryFile :: FilePath -> FilePath -> IO (FilePath, Handle)
openNewBinaryFile FilePath
dir FilePath
template = do
  
  
  
#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
    
    
    
    (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
         
         (FilePath
rev_suffix, FilePath
"")       -> (FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
rev_suffix, FilePath
"")
         
         
         
         
         (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)
         
         
         
         (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
         
         
         
         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 a. a -> IO a
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
        
        combine :: FilePath -> FilePath -> FilePath
combine FilePath
a FilePath
b
                  | FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
b = FilePath
a
                  | FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
a = FilePath
b
                  | FilePath -> Char
forall a. HasCallStack => [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
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
pathSeparator :: Char
#ifdef mingw32_HOST_OS
pathSeparator = '\\'
#else
pathSeparator :: Char
pathSeparator = Char
'/'
#endif
#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 a. a -> IO a
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