1{-# LANGUAGE CPP #-}
2#if __GLASGOW_HASKELL__ >= 704
3{-# LANGUAGE Safe #-}
4#endif
5
6-- This module backports `openTempFile` from GHC 8.10 to hsc2hs in order to get
7-- an atomic `openTempFile` implementation on Windows when using older GHC
8-- compilers.
9-- See also https://gitlab.haskell.org/ghc/ghc/issues/10731
10--
11-- When hsc2hs supports GHC 8.10 as minimum then this module can be removed.
12module Compat.TempFile (
13    openBinaryTempFile,
14    openTempFile
15  ) where
16
17#if !MIN_VERSION_base(4,14,0) && defined(mingw32_HOST_OS)
18#define NEEDS_TEMP_WORKAROUND 1
19#else
20#define NEEDS_TEMP_WORKAROUND 0
21#endif
22
23#if NEEDS_TEMP_WORKAROUND
24import Data.Bits
25import Foreign.C.Error
26import Foreign.C.String
27import Foreign.C.Types
28import Foreign.Ptr
29import Foreign.Marshal.Alloc
30import Foreign.Storable
31import GHC.IO.Encoding
32import GHC.IO.IOMode
33import qualified GHC.IO.FD as FD
34import qualified GHC.IO.Handle.FD as POSIX
35import System.Posix.Internals
36import System.Posix.Types
37#else
38import qualified System.IO as IOUtils
39#endif
40
41import GHC.IO.Handle
42
43-- | The function creates a temporary file in ReadWrite mode.
44-- The created file isn\'t deleted automatically, so you need to delete it manually.
45--
46-- The file is created with permissions such that only the current
47-- user can read\/write it.
48--
49-- With some exceptions (see below), the file will be created securely
50-- in the sense that an attacker should not be able to cause
51-- openTempFile to overwrite another file on the filesystem using your
52-- credentials, by putting symbolic links (on Unix) in the place where
53-- the temporary file is to be created.  On Unix the @O_CREAT@ and
54-- @O_EXCL@ flags are used to prevent this attack, but note that
55-- @O_EXCL@ is sometimes not supported on NFS filesystems, so if you
56-- rely on this behaviour it is best to use local filesystems only.
57--
58openTempFile :: FilePath   -- ^ Directory in which to create the file
59             -> String     -- ^ File name template. If the template is \"foo.ext\" then
60                           -- the created file will be \"fooXXX.ext\" where XXX is some
61                           -- random number. Note that this should not contain any path
62                           -- separator characters.
63             -> IO (FilePath, Handle)
64openTempFile tmp_dir template
65#if NEEDS_TEMP_WORKAROUND
66    = openTempFile' "openTempFile" tmp_dir template False 0o600
67#else
68    = IOUtils.openTempFile tmp_dir template
69#endif
70
71-- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments.
72openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)
73openBinaryTempFile tmp_dir template
74#if NEEDS_TEMP_WORKAROUND
75    = openTempFile' "openBinaryTempFile" tmp_dir template True 0o600
76#else
77    = IOUtils.openBinaryTempFile tmp_dir template
78#endif
79
80
81#if NEEDS_TEMP_WORKAROUND
82openTempFile' :: String -> FilePath -> String -> Bool -> CMode
83              -> IO (FilePath, Handle)
84openTempFile' loc tmp_dir template binary mode
85    | pathSeparator template
86    = error $ "openTempFile': Template string must not contain path separator characters: "++template
87    | otherwise = findTempName
88  where
89    -- We split off the last extension, so we can use .foo.ext files
90    -- for temporary files (hidden on Unix OSes). Unfortunately we're
91    -- below filepath in the hierarchy here.
92    (prefix, suffix) =
93       case break (== '.') $ reverse template of
94         -- First case: template contains no '.'s. Just re-reverse it.
95         (rev_suffix, "")       -> (reverse rev_suffix, "")
96         -- Second case: template contains at least one '.'. Strip the
97         -- dot from the prefix and prepend it to the suffix (if we don't
98         -- do this, the unique number will get added after the '.' and
99         -- thus be part of the extension, which is wrong.)
100         (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
101         -- Otherwise, something is wrong, because (break (== '.')) should
102         -- always return a pair with either the empty string or a string
103         -- beginning with '.' as the second component.
104         _                      -> error "bug in System.IO.openTempFile"
105    findTempName = do
106      let label = if null prefix then "ghc" else prefix
107      withCWString tmp_dir $ \c_tmp_dir ->
108        withCWString label $ \c_template ->
109          withCWString suffix $ \c_suffix ->
110            -- FIXME: revisit this when new I/O manager in place and use a UUID
111            --       based one when we are no longer MAX_PATH bound.
112            allocaBytes (sizeOf (undefined :: CWchar) * 260) $ \c_str -> do
113            res <- c_getTempFileNameErrorNo c_tmp_dir c_template c_suffix 0
114                                            c_str
115            if not res
116               then do errno <- getErrno
117                       ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
118               else do filename <- peekCWString c_str
119                       handleResults filename
120
121    handleResults filename = do
122      let oflags1 = rw_flags .|. o_EXCL
123          binary_flags
124              | binary    = o_BINARY
125              | otherwise = 0
126          oflags = oflags1 .|. binary_flags
127      fd <- withFilePath filename $ \ f -> c_open f oflags mode
128      case fd < 0 of
129        True -> do errno <- getErrno
130                   ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
131        False ->
132          do (fD,fd_type) <- FD.mkFD fd ReadWriteMode Nothing{-no stat-}
133                                     False{-is_socket-}
134                                     True{-is_nonblock-}
135
136             enc <- getLocaleEncoding
137             h <- POSIX.mkHandleFromFD fD fd_type filename ReadWriteMode
138                                 False{-set non-block-} (Just enc)
139
140             return (filename, h)
141
142foreign import ccall "__get_temp_file_name" c_getTempFileNameErrorNo
143  :: CWString -> CWString -> CWString -> CUInt -> Ptr CWchar -> IO Bool
144
145pathSeparator :: String -> Bool
146pathSeparator template = any (\x-> x == '/' || x == '\\') template
147
148output_flags = std_flags
149
150-- XXX Copied from GHC.Handle
151std_flags, output_flags, rw_flags :: CInt
152std_flags    = o_NONBLOCK   .|. o_NOCTTY
153rw_flags     = output_flags .|. o_RDWR
154#endif /* NEEDS_TEMP_WORKAROUND */
155