Skip to content

Commit 91076d4

Browse files
jasagredojasagredo
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 d215dc3 commit 91076d4

File tree

17 files changed

+93
-86
lines changed

17 files changed

+93
-86
lines changed

‎.github/workflows/validate.yml

Lines changed: 14 additions & 1 deletion
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
@@ -399,6 +404,9 @@ jobs:
399404
# We need to build an array dynamically to inject the appropiate env var in a previous job,
400405
# see https://docs.github.com/en/actions/learn-github-actions/expressions#fromjson
401406
ghc: ${{ fromJSON (needs.validate.outputs.GHC_FOR_RELEASE) }}
407+
defaults:
408+
run:
409+
shell: ${{ matrix.sys.shell }}
402410

403411
defaults:
404412
run:
@@ -416,12 +424,17 @@ jobs:
416424
esac
417425
echo "CABAL_ARCH=$arch" >> "$GITHUB_ENV"
418426
419-
- name: Work around XDG directories existence (haskell-actions/setup#62)
427+
- name: "MAC: Work around XDG directories existence (haskell-actions/setup#62)"
420428
if: runner.os == 'macOS'
421429
run: |
422430
rm -rf ~/.config/cabal
423431
rm -rf ~/.cache/cabal
424432
433+
- name: "WIN: Setup TMP environment variable"
434+
if: runner.os == 'Windows'
435+
run: |
436+
echo "TMP=${{ runner.temp }}" >> "$GITHUB_ENV"
437+
425438
- uses: actions/checkout@v4
426439

427440
- 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
@@ -154,7 +154,6 @@ import System.Directory
154154
( canonicalizePath
155155
, createDirectoryIfMissing
156156
, doesFileExist
157-
, getTemporaryDirectory
158157
, removeFile
159158
)
160159
import System.FilePath
@@ -2674,10 +2673,9 @@ checkForeignDeps pkg lbi verbosity =
26742673

26752674
builds :: String -> [ProgArg] -> IO Bool
26762675
builds program args =
2677-
do
2678-
tempDir <- makeSymbolicPath <$> getTemporaryDirectory
2679-
withTempFileCwd mbWorkDir tempDir ".c" $ \cName cHnd ->
2680-
withTempFileCwd mbWorkDir tempDir "" $ \oNname oHnd -> do
2676+
withTempFileCwd ".c" $ \cName cHnd ->
2677+
withTempFileCwd "" $ \oNname oHnd ->
2678+
do
26812679
hPutStrLn cHnd program
26822680
hClose cHnd
26832681
hClose oHnd
@@ -2689,8 +2687,8 @@ checkForeignDeps pkg lbi verbosity =
26892687
(withPrograms lbi)
26902688
(getSymbolicPath cName : "-o" : getSymbolicPath oNname : args)
26912689
return True
2692-
`catchIO` (\_ -> return False)
2693-
`catchExit` (\_ -> return False)
2690+
`catchIO` (\_ -> return False)
2691+
`catchExit` (\_ -> return False)
26942692

26952693
explainErrors Nothing [] = return () -- should be impossible!
26962694
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)