Skip to content

Commit 8161f5f

Browse files
jasagredoMikolaj
jasagredo
authored and
Mikolaj
committed
Create temp files in temp directory
This change ensures all temporal files are created in the system temp directory which usually is in a short path. This helps with Windows not being capable of creating temp files in long directories, like the ones that result from Backpack. See how GetTempFileNameW specifies: > The string cannot be longer than `MAX_PATH–14` characters or `GetTempFileName` will fail. And actually there is a TODO in `Win32Utils.c` in GHC: https://gitlab.haskell.org/ghc/ghc/-/blob/3939a8bf93e27d8151aa1d92bf3ce10bbbc96a72/libraries/ghc-internal/cbits/Win32Utils.c#L259 Closes #10191.
1 parent 1e5bfa1 commit 8161f5f

File tree

17 files changed

+90
-87
lines changed

17 files changed

+90
-87
lines changed

‎.github/workflows/validate.yml

Lines changed: 11 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -124,6 +124,11 @@ jobs:
124124
rm -rf ~/.config/cabal
125125
rm -rf ~/.cache/cabal
126126
127+
- name: "WIN: Setup TMP environment variable"
128+
if: runner.os == 'Windows'
129+
run: |
130+
echo "TMP=${{ runner.temp }}" >> "$GITHUB_ENV"
131+
127132
- uses: actions/checkout@v4
128133

129134
# See https://github.com/haskell/cabal/blob/master/CONTRIBUTING.md#hackage-revisions
@@ -396,7 +401,6 @@ jobs:
396401
# We need to build an array dynamically to inject the appropiate env var in a previous job,
397402
# see https://docs.github.com/en/actions/learn-github-actions/expressions#fromjson
398403
ghc: ${{ fromJSON (needs.validate.outputs.GHC_FOR_RELEASE) }}
399-
400404
defaults:
401405
run:
402406
shell: ${{ matrix.sys.shell }}
@@ -413,12 +417,17 @@ jobs:
413417
esac
414418
echo "CABAL_ARCH=$arch" >> "$GITHUB_ENV"
415419
416-
- name: Work around XDG directories existence (haskell-actions/setup#62)
420+
- name: "MAC: Work around XDG directories existence (haskell-actions/setup#62)"
417421
if: runner.os == 'macOS'
418422
run: |
419423
rm -rf ~/.config/cabal
420424
rm -rf ~/.cache/cabal
421425
426+
- name: "WIN: Setup TMP environment variable"
427+
if: runner.os == 'Windows'
428+
run: |
429+
echo "TMP=${{ runner.temp }}" >> "$GITHUB_ENV"
430+
422431
- uses: actions/checkout@v4
423432

424433
- uses: haskell-actions/setup@v2

‎Cabal-syntax/src/Distribution/Utils/Generic.hs

Lines changed: 29 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -100,11 +100,13 @@ import qualified Data.Set as Set
100100

101101
import qualified Control.Exception as Exception
102102
import System.Directory
103-
( removeFile
103+
( copyFile
104+
, getTemporaryDirectory
105+
, removeFile
104106
, renameFile
105107
)
106108
import System.FilePath
107-
( splitFileName
109+
( takeFileName
108110
, (<.>)
109111
)
110112
import System.IO
@@ -167,18 +169,38 @@ withFileContents name action =
167169
-- The file is either written successfully or an IO exception is raised and
168170
-- the original file is left unchanged.
169171
--
170-
-- On windows it is not possible to delete a file that is open by a process.
171-
-- This case will give an IO exception but the atomic property is not affected.
172+
-- On Unix:
173+
--
174+
-- - If the temp directory (@$TMPDIR@) is in a filesystem different than the
175+
-- destination path, the renaming will be emulated via 'copyFile' then
176+
-- 'deleteFile'.
177+
--
178+
-- On Windows:
179+
--
180+
-- - This operation is not guaranteed to be atomic, see 'renameFile'.
181+
--
182+
-- - It is not possible to delete a file that is open by a process. This case
183+
-- will give an IO exception but the atomic property is not affected.
184+
--
185+
-- - If the temp directory (@TMP@/@TEMP@/..., see haddocks on
186+
-- 'getTemporaryDirectory') is in a different drive than the destination path,
187+
-- the write will be emulated via 'copyFile', then 'deleteFile'.
172188
writeFileAtomic :: FilePath -> LBS.ByteString -> IO ()
173189
writeFileAtomic targetPath content = do
174-
let (targetDir, targetFile) = splitFileName targetPath
190+
let targetFile = takeFileName targetPath
191+
tmpDir <- getTemporaryDirectory
175192
Exception.bracketOnError
176-
(openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")
193+
(openBinaryTempFileWithDefaultPermissions tmpDir $ targetFile <.> "tmp")
177194
(\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
178195
( \(tmpPath, handle) -> do
179196
LBS.hPut handle content
180197
hClose handle
181-
renameFile tmpPath targetPath
198+
Exception.catch
199+
(renameFile tmpPath targetPath)
200+
( \(_ :: Exception.SomeException) -> do
201+
copyFile tmpPath targetPath
202+
removeFile tmpPath
203+
)
182204
)
183205

184206
-- ------------------------------------------------------------

‎Cabal-tests/tests/UnitTests/Distribution/Simple/Utils.hs

Lines changed: 4 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -23,16 +23,14 @@ import Test.Tasty.HUnit
2323
withTempFileTest :: Assertion
2424
withTempFileTest = do
2525
fileName <- newIORef ""
26-
tempDir <- getTemporaryDirectory
27-
withTempFile tempDir ".foo" $ \fileName' _handle -> do
26+
withTempFile ".foo" $ \fileName' _handle -> do
2827
writeIORef fileName fileName'
2928
fileExists <- readIORef fileName >>= doesFileExist
3029
assertBool "Temporary file not deleted by 'withTempFile'!" (not fileExists)
3130

3231
withTempFileRemovedTest :: Assertion
3332
withTempFileRemovedTest = do
34-
tempDir <- getTemporaryDirectory
35-
withTempFile tempDir ".foo" $ \fileName handle -> do
33+
withTempFile ".foo" $ \fileName handle -> do
3634
hClose handle
3735
removeFile fileName
3836

@@ -58,9 +56,8 @@ rawSystemStdInOutTextDecodingTest ghcPath
5856
-- so skip the test if it's not.
5957
| show localeEncoding /= "UTF-8" = return ()
6058
| otherwise = do
61-
tempDir <- getTemporaryDirectory
62-
res <- withTempFile tempDir ".hs" $ \filenameHs handleHs -> do
63-
withTempFile tempDir ".exe" $ \filenameExe handleExe -> do
59+
res <- withTempFile ".hs" $ \filenameHs handleHs -> do
60+
withTempFile ".exe" $ \filenameExe handleExe -> do
6461
-- Small program printing not utf8
6562
hPutStrLn handleHs "import Data.ByteString"
6663
hPutStrLn handleHs "main = Data.ByteString.putStr (Data.ByteString.pack [32, 32, 255])"

‎Cabal/src/Distribution/Simple/Configure.hs

Lines changed: 5 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -156,7 +156,6 @@ import System.Directory
156156
( canonicalizePath
157157
, createDirectoryIfMissing
158158
, doesFileExist
159-
, getTemporaryDirectory
160159
, removeFile
161160
)
162161
import System.FilePath
@@ -2693,10 +2692,9 @@ checkForeignDeps pkg lbi verbosity =
26932692

26942693
builds :: String -> [ProgArg] -> IO Bool
26952694
builds program args =
2696-
do
2697-
tempDir <- makeSymbolicPath <$> getTemporaryDirectory
2698-
withTempFileCwd mbWorkDir tempDir ".c" $ \cName cHnd ->
2699-
withTempFileCwd mbWorkDir tempDir "" $ \oNname oHnd -> do
2695+
withTempFileCwd ".c" $ \cName cHnd ->
2696+
withTempFileCwd "" $ \oNname oHnd ->
2697+
do
27002698
hPutStrLn cHnd program
27012699
hClose cHnd
27022700
hClose oHnd
@@ -2708,8 +2706,8 @@ checkForeignDeps pkg lbi verbosity =
27082706
(withPrograms lbi)
27092707
(getSymbolicPath cName : "-o" : getSymbolicPath oNname : args)
27102708
return True
2711-
`catchIO` (\_ -> return False)
2712-
`catchExit` (\_ -> return False)
2709+
`catchIO` (\_ -> return False)
2710+
`catchExit` (\_ -> return False)
27132711

27142712
explainErrors Nothing [] = return () -- should be impossible!
27152713
explainErrors _ _

‎Cabal/src/Distribution/Simple/GHC/Internal.hs

Lines changed: 4 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -85,7 +85,7 @@ import Distribution.Utils.Path
8585
import Distribution.Verbosity
8686
import Distribution.Version (Version)
8787
import Language.Haskell.Extension
88-
import System.Directory (getDirectoryContents, getTemporaryDirectory)
88+
import System.Directory (getDirectoryContents)
8989
import System.Environment (getEnv)
9090
import System.FilePath
9191
( takeDirectory
@@ -221,9 +221,8 @@ configureToolchain _implInfo ghcProg ghcInfo =
221221
-- we need to find out if ld supports the -x flag
222222
configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
223223
configureLd' verbosity ldProg = do
224-
tempDir <- getTemporaryDirectory
225-
ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->
226-
withTempFile tempDir ".o" $ \testofile testohnd -> do
224+
ldx <- withTempFile ".c" $ \testcfile testchnd ->
225+
withTempFile ".o" $ \testofile testohnd -> do
227226
hPutStrLn testchnd "int foo() { return 0; }"
228227
hClose testchnd
229228
hClose testohnd
@@ -236,7 +235,7 @@ configureToolchain _implInfo ghcProg ghcInfo =
236235
, "-o"
237236
, testofile
238237
]
239-
withTempFile tempDir ".o" $ \testofile' testohnd' ->
238+
withTempFile ".o" $ \testofile' testohnd' ->
240239
do
241240
hClose testohnd'
242241
_ <-

‎Cabal/src/Distribution/Simple/Haddock.hs

Lines changed: 1 addition & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1133,8 +1133,6 @@ renderArgs verbosity mbWorkDir tmpFileOpts version comp platform args k = do
11331133
withResponseFile
11341134
verbosity
11351135
tmpFileOpts
1136-
mbWorkDir
1137-
outputDir
11381136
"haddock-response.txt"
11391137
(if haddockSupportsUTF8 then Just utf8 else Nothing)
11401138
renderedArgs
@@ -1144,7 +1142,7 @@ renderArgs verbosity mbWorkDir tmpFileOpts version comp platform args k = do
11441142
(Flag pfile, _) ->
11451143
withPrologueArgs ["--prologue=" ++ pfile]
11461144
(_, Flag prologueText) ->
1147-
withTempFileEx tmpFileOpts mbWorkDir outputDir "haddock-prologue.txt" $
1145+
withTempFileEx tmpFileOpts "haddock-prologue.txt" $
11481146
\prologueFileName h -> do
11491147
when haddockSupportsUTF8 (hSetEncoding h utf8)
11501148
hPutStrLn h prologueText

‎Cabal/src/Distribution/Simple/PreProcess.hs

Lines changed: 0 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -511,8 +511,6 @@ ppHsc2hs bi lbi clbi =
511511
withResponseFile
512512
verbosity
513513
defaultTempFileOptions
514-
mbWorkDir
515-
(makeSymbolicPath $ takeDirectory outFile)
516514
"hsc2hs-response.txt"
517515
Nothing
518516
pureArgs

‎Cabal/src/Distribution/Simple/Program/Ar.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -154,7 +154,7 @@ createArLibArchive verbosity lbi targetPath files = do
154154
(initial, middle, final)
155155
(map getSymbolicPath files)
156156
]
157-
else withResponseFile verbosity defaultTempFileOptions mbWorkDir tmpDir "ar.rsp" Nothing (map getSymbolicPath files) $
157+
else withResponseFile verbosity defaultTempFileOptions "ar.rsp" Nothing (map getSymbolicPath files) $
158158
\path -> runProgramInvocation verbosity $ invokeWithResponseFile path
159159

160160
unless

‎Cabal/src/Distribution/Simple/Program/Ld.hs

Lines changed: 1 addition & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -83,8 +83,6 @@ combineObjectFiles verbosity lbi ldProg target files = do
8383
middle = ld middleArgs
8484
final = ld finalArgs
8585

86-
targetDir = takeDirectorySymbolicPath target
87-
8886
invokeWithResponseFile :: FilePath -> ProgramInvocation
8987
invokeWithResponseFile atFile =
9088
ld $ simpleArgs ++ ['@' : atFile]
@@ -106,7 +104,7 @@ combineObjectFiles verbosity lbi ldProg target files = do
106104

107105
if oldVersionManualOverride || responseArgumentsNotSupported
108106
then run $ multiStageProgramInvocation simple (initial, middle, final) (map getSymbolicPath files)
109-
else withResponseFile verbosity defaultTempFileOptions mbWorkDir targetDir "ld.rsp" Nothing (map getSymbolicPath files) $
107+
else withResponseFile verbosity defaultTempFileOptions "ld.rsp" Nothing (map getSymbolicPath files) $
110108
\path -> runProgramInvocation verbosity $ invokeWithResponseFile path
111109
where
112110
tmpfile = target <.> "tmp" -- perhaps should use a proper temp file

‎Cabal/src/Distribution/Simple/Program/ResponseFile.hs

Lines changed: 2 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -27,10 +27,6 @@ import Distribution.Verbosity
2727
withResponseFile
2828
:: Verbosity
2929
-> TempFileOptions
30-
-> Maybe (SymbolicPath CWD (Dir Pkg))
31-
-- ^ Working directory
32-
-> SymbolicPath Pkg (Dir Response)
33-
-- ^ Directory to create response file in.
3430
-> String
3531
-- ^ Template for response file name.
3632
-> Maybe TextEncoding
@@ -39,8 +35,8 @@ withResponseFile
3935
-- ^ Arguments to put into response file.
4036
-> (FilePath -> IO a)
4137
-> IO a
42-
withResponseFile verbosity tmpFileOpts mbWorkDir responseDir fileNameTemplate encoding arguments f =
43-
withTempFileEx tmpFileOpts mbWorkDir responseDir fileNameTemplate $ \responsePath hf -> do
38+
withResponseFile verbosity tmpFileOpts fileNameTemplate encoding arguments f =
39+
withTempFileEx tmpFileOpts fileNameTemplate $ \responsePath hf -> do
4440
let responseFileName = getSymbolicPath responsePath
4541
traverse_ (hSetEncoding hf) encoding
4642
let responseContents =

0 commit comments

Comments
 (0)