Skip to content

Commit 9feae5d

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 c53a03a commit 9feae5d

File tree

17 files changed

+85
-83
lines changed

17 files changed

+85
-83
lines changed

‎.github/workflows/validate.yml‎

Lines changed: 17 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -111,6 +111,10 @@ jobs:
111111
rm -rf ~/.config/cabal
112112
rm -rf ~/.cache/cabal
113113
114+
- name: Setup TMP environment variable
115+
run: |
116+
echo "TMP=${{ runner.temp }}" >> "$GITHUB_ENV"
117+
114118
- uses: actions/checkout@v4
115119

116120
# See https://github.com/haskell/cabal/blob/master/CONTRIBUTING.md#hackage-revisions
@@ -363,16 +367,22 @@ jobs:
363367
# This one uses the cabal HEAD generated executable in the previous step
364368
# to build itself again, as sanity check
365369
dogfooding:
366-
name: Dogfooding ${{ matrix.os }} ghc-${{ matrix.ghc }}
367-
runs-on: ${{ matrix.os }}
370+
name: Dogfooding ${{ matrix.sys.os }} ghc-${{ matrix.ghc }}
371+
runs-on: ${{ matrix.sys.os }}
368372
needs: validate
369373
strategy:
370374
matrix:
371-
os: [ubuntu-latest, macos-13, windows-latest]
375+
sys:
376+
- { os: windows-latest, shell: "C:/msys64/usr/bin/bash.exe -e {0}" }
377+
- { os: ubuntu-latest, shell: bash }
378+
- { os: macos-13, shell: bash }
372379
# We only use one ghc version the used one for the next release (defined at top of the workflow)
373380
# We need to build an array dynamically to inject the appropiate env var in a previous job,
374381
# see https://docs.github.com/en/actions/learn-github-actions/expressions#fromjson
375382
ghc: ${{ fromJSON (needs.validate.outputs.GHC_FOR_RELEASE) }}
383+
defaults:
384+
run:
385+
shell: ${{ matrix.sys.shell }}
376386

377387
steps:
378388
- name: Work around XDG directories existence (haskell-actions/setup#62)
@@ -381,6 +391,10 @@ jobs:
381391
rm -rf ~/.config/cabal
382392
rm -rf ~/.cache/cabal
383393
394+
- name: Setup TMP environment variable
395+
run: |
396+
echo "TMP=${{ runner.temp }}" >> "$GITHUB_ENV"
397+
384398
- uses: actions/checkout@v4
385399

386400
- uses: haskell-actions/setup@v2

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

Lines changed: 11 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -100,11 +100,14 @@ 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+
( takeDrive
110+
, takeFileName
108111
, (<.>)
109112
)
110113
import System.IO
@@ -171,14 +174,17 @@ withFileContents name action =
171174
-- This case will give an IO exception but the atomic property is not affected.
172175
writeFileAtomic :: FilePath -> LBS.ByteString -> IO ()
173176
writeFileAtomic targetPath content = do
174-
let (targetDir, targetFile) = splitFileName targetPath
177+
let targetFile = takeFileName targetPath
178+
tmpDir <- getTemporaryDirectory
175179
Exception.bracketOnError
176-
(openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")
180+
(openBinaryTempFileWithDefaultPermissions tmpDir $ targetFile <.> "tmp")
177181
(\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
178182
( \(tmpPath, handle) -> do
179183
LBS.hPut handle content
180184
hClose handle
181-
renameFile tmpPath targetPath
185+
if takeDrive targetPath == takeDrive tmpDir
186+
then renameFile tmpPath targetPath
187+
else copyFile tmpPath targetPath >> removeFile tmpPath
182188
)
183189

184190
-- ------------------------------------------------------------

‎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)