Cabal/src/Distribution/Compat/Internal/TempFile.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# OPTIONS_HADDOCK hide #-}
   3
   4 module Distribution.Compat.Internal.TempFile
   5   ( openTempFile
   6   , openBinaryTempFile
   7   , openNewBinaryFile
   8   , createTempDirectory
   9   ) where
  10
  11 import Distribution.Compat.Exception
  12
  13 import System.FilePath ((</>))
  14
  15 import System.IO (Handle, openBinaryTempFile, openTempFile)
  16 #if defined(__IO_MANAGER_WINIO__)
  17 import System.IO              (openBinaryTempFileWithDefaultPermissions)
  18 #else
  19 import Control.Exception      (onException)
  20 import Data.Bits              ((.|.))
  21 import Foreign.C              (CInt, eEXIST, getErrno, errnoToIOError)
  22 import GHC.IO.Handle.FD       (fdToHandle)
  23 import System.Posix.Internals (c_open, c_close, o_EXCL, o_BINARY, withFilePath,
  24                                o_CREAT, o_RDWR, o_NONBLOCK, o_NOCTTY)
  25 #endif
  26
  27 import System.IO.Error (isAlreadyExistsError)
  28 import System.Posix.Internals (c_getpid)
  29
  30 #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)
  31 import System.Directory       ( createDirectory )
  32 #else
  33 import qualified System.Posix
  34 #endif
  35
  36 -- ------------------------------------------------------------
  37
  38 -- * temporary files
  39
  40 -- ------------------------------------------------------------
  41
  42 -- This is here for Haskell implementations that do not come with
  43 -- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9.
  44 -- TODO: This file should probably be removed.
  45
  46 -- This is a copy/paste of the openBinaryTempFile definition, but
  47 -- it uses 666 rather than 600 for the permissions. Newer versions
  48 -- of base have a new function with this behavior which we use on
  49 -- Windows when the new IO manager is used.
  50 openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)
  51 openNewBinaryFile dir template = do
  52
  53 -- This method can't be used under WINIO. Also the current implementation has
  54 -- thread safety issues depending on which GHC is used.  On newer GHC's let's
  55 -- use the built in one.
  56 #if defined(__IO_MANAGER_WINIO__)
  57   openBinaryTempFileWithDefaultPermissions dir template
  58 #else
  59   pid <- c_getpid
  60   findTempName pid
  61   where
  62     -- We split off the last extension, so we can use .foo.ext files
  63     -- for temporary files (hidden on Unix OSes). Unfortunately we're
  64     -- below file path in the hierarchy here.
  65     (prefix,suffix) =
  66        case break (== '.') $ reverse template of
  67          -- First case: template contains no '.'s. Just re-reverse it.
  68          (rev_suffix, "")       -> (reverse rev_suffix, "")
  69          -- Second case: template contains at least one '.'. Strip the
  70          -- dot from the prefix and prepend it to the suffix (if we don't
  71          -- do this, the unique number will get added after the '.' and
  72          -- thus be part of the extension, which is wrong.)
  73          (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
  74          -- Otherwise, something is wrong, because (break (== '.')) should
  75          -- always return a pair with either the empty string or a string
  76          -- beginning with '.' as the second component.
  77          _                      -> error "bug in System.IO.openTempFile"
  78
  79     oflags = rw_flags .|. o_EXCL .|. o_BINARY
  80
  81     findTempName x = do
  82       fd <- withFilePath filepath $ \ f ->
  83               c_open f oflags 0o666
  84       if fd < 0
  85        then do
  86          errno <- getErrno
  87          if errno == eEXIST
  88            then findTempName (x+1)
  89            else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
  90        else do
  91          -- TODO: We want to tell fdToHandle what the file path is,
  92          -- as any exceptions etc will only be able to report the
  93          -- FD currently
  94          h <- fdToHandle fd `onException` c_close fd
  95          return (filepath, h)
  96       where
  97         filename        = prefix ++ show x ++ suffix
  98         filepath        = dir `combine` filename
  99
 100         -- FIXME: bits copied from System.FilePath
 101         combine a b
 102                   | null b = a
 103                   | null a = b
 104                   | last a == pathSeparator = a ++ b
 105                   | otherwise = a ++ [pathSeparator] ++ b
 106
 107 -- FIXME: Copied from GHC.Handle
 108 std_flags, output_flags, rw_flags :: CInt
 109 std_flags    = o_NONBLOCK   .|. o_NOCTTY
 110 output_flags = std_flags    .|. o_CREAT
 111 rw_flags     = output_flags .|. o_RDWR
 112
 113 -- FIXME: Should use System.FilePath library
 114 pathSeparator :: Char
 115 #ifdef mingw32_HOST_OS
 116 pathSeparator = '\\'
 117 #else
 118 pathSeparator = '/'
 119 #endif
 120 -- /* __IO_MANAGER_WINIO__ */
 121 #endif
 122
 123 createTempDirectory :: FilePath -> String -> IO FilePath
 124 createTempDirectory dir template = do
 125   pid <- c_getpid
 126   findTempName pid
 127   where
 128     findTempName x = do
 129       let relpath = template ++ "-" ++ show x
 130           dirpath = dir </> relpath
 131       r <- tryIO $ mkPrivateDir dirpath
 132       case r of
 133         Right _ -> return relpath
 134         Left e
 135           | isAlreadyExistsError e -> findTempName (x + 1)
 136           | otherwise -> ioError e
 137
 138 mkPrivateDir :: String -> IO ()
 139 #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)
 140 mkPrivateDir s = createDirectory s
 141 #else
 142 mkPrivateDir s = System.Posix.createDirectory s 0o700
 143 #endif