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