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.

.github/workflows/validate.yml

@@ -124,6 +124,11 @@ jobs:
           rm -rf ~/.config/cabal
           rm -rf ~/.cache/cabal
 
+      - name: "WIN: Setup TMP environment variable"
+        if: runner.os == 'Windows'
+        run: |
+           echo "TMP=${{ runner.temp }}" >> "$GITHUB_ENV"
+
       - uses: actions/checkout@v4
 
       # See https://github.com/haskell/cabal/blob/master/CONTRIBUTING.md#hackage-revisions
@@ -399,6 +404,9 @@ jobs:
         # We need to build an array dynamically to inject the appropiate env var in a previous job,
         # see https://docs.github.com/en/actions/learn-github-actions/expressions#fromjson
         ghc: ${{ fromJSON (needs.validate.outputs.GHC_FOR_RELEASE) }}
+    defaults:
+      run:
+        shell: ${{ matrix.sys.shell }}
 
     defaults:
       run:
@@ -416,12 +424,17 @@ jobs:
           esac
           echo "CABAL_ARCH=$arch" >> "$GITHUB_ENV"
 
-      - name: Work around XDG directories existence (haskell-actions/setup#62)
+      - name: "MAC: Work around XDG directories existence (haskell-actions/setup#62)"
         if: runner.os == 'macOS'
         run: |
           rm -rf ~/.config/cabal
           rm -rf ~/.cache/cabal
 
+      - name: "WIN: Setup TMP environment variable"
+        if: runner.os == 'Windows'
+        run: |
+           echo "TMP=${{ runner.temp }}" >> "$GITHUB_ENV"
+
       - uses: actions/checkout@v4
 
       - uses: haskell-actions/setup@v2

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

@@ -100,11 +100,13 @@ import qualified Data.Set as Set
 
 import qualified Control.Exception as Exception
 import System.Directory
-  ( removeFile
+  ( copyFile
+  , getTemporaryDirectory
+  , removeFile
   , renameFile
   )
 import System.FilePath
-  ( splitFileName
+  ( takeFileName
   , (<.>)
   )
 import System.IO
@@ -167,18 +169,38 @@ withFileContents name action =
 -- The file is either written successfully or an IO exception is raised and
 -- the original file is left unchanged.
 --
--- On windows it is not possible to delete a file that is open by a process.
--- This case will give an IO exception but the atomic property is not affected.
+-- On Unix:
+--
+-- - If the temp directory (@$TMPDIR@) is in a filesystem different than the
+--   destination path, the renaming will be emulated via 'copyFile' then
+--   'deleteFile'.
+--
+-- On Windows:
+--
+-- - This operation is not guaranteed to be atomic, see 'renameFile'.
+--
+-- - It is not possible to delete a file that is open by a process. This case
+--   will give an IO exception but the atomic property is not affected.
+--
+-- - If the temp directory (@TMP@/@TEMP@/..., see haddocks on
+--   'getTemporaryDirectory') is in a different drive than the destination path,
+--   the write will be emulated via 'copyFile', then 'deleteFile'.
 writeFileAtomic :: FilePath -> LBS.ByteString -> IO ()
 writeFileAtomic targetPath content = do
-  let (targetDir, targetFile) = splitFileName targetPath
+  let targetFile = takeFileName targetPath
+  tmpDir <- getTemporaryDirectory
   Exception.bracketOnError
-    (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")
+    (openBinaryTempFileWithDefaultPermissions tmpDir $ targetFile <.> "tmp")
     (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
     ( \(tmpPath, handle) -> do
         LBS.hPut handle content
         hClose handle
-        renameFile tmpPath targetPath
+        Exception.catch
+          (renameFile tmpPath targetPath)
+          ( \(_ :: Exception.SomeException) -> do
+              copyFile tmpPath targetPath
+              removeFile tmpPath
+          )
     )
 
 -- ------------------------------------------------------------

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

@@ -23,16 +23,14 @@ import Test.Tasty.HUnit
 withTempFileTest :: Assertion
 withTempFileTest = do
   fileName <- newIORef ""
-  tempDir  <- getTemporaryDirectory
-  withTempFile tempDir ".foo" $ \fileName' _handle -> do
+  withTempFile ".foo" $ \fileName' _handle -> do
     writeIORef fileName fileName'
   fileExists <- readIORef fileName >>= doesFileExist
   assertBool "Temporary file not deleted by 'withTempFile'!" (not fileExists)
 
 withTempFileRemovedTest :: Assertion
 withTempFileRemovedTest = do
-  tempDir <- getTemporaryDirectory
-  withTempFile tempDir ".foo" $ \fileName handle -> do
+  withTempFile ".foo" $ \fileName handle -> do
     hClose handle
     removeFile fileName
 
@@ -58,9 +56,8 @@ rawSystemStdInOutTextDecodingTest ghcPath
     -- so skip the test if it's not.
     | show localeEncoding /= "UTF-8" = return ()
     | otherwise = do
-  tempDir  <- getTemporaryDirectory
-  res <- withTempFile tempDir ".hs" $ \filenameHs handleHs -> do
-    withTempFile tempDir ".exe" $ \filenameExe handleExe -> do
+  res <- withTempFile ".hs" $ \filenameHs handleHs -> do
+    withTempFile ".exe" $ \filenameExe handleExe -> do
       -- Small program printing not utf8
       hPutStrLn handleHs "import Data.ByteString"
       hPutStrLn handleHs "main = Data.ByteString.putStr (Data.ByteString.pack [32, 32, 255])"

Cabal/src/Distribution/Simple/Configure.hs

@@ -154,7 +154,6 @@ import System.Directory
   ( canonicalizePath
   , createDirectoryIfMissing
   , doesFileExist
-  , getTemporaryDirectory
   , removeFile
   )
 import System.FilePath
@@ -2674,10 +2673,9 @@ checkForeignDeps pkg lbi verbosity =
 
     builds :: String -> [ProgArg] -> IO Bool
     builds program args =
-      do
-        tempDir <- makeSymbolicPath <$> getTemporaryDirectory
-        withTempFileCwd mbWorkDir tempDir ".c" $ \cName cHnd ->
-          withTempFileCwd mbWorkDir tempDir "" $ \oNname oHnd -> do
+      withTempFileCwd ".c" $ \cName cHnd ->
+        withTempFileCwd "" $ \oNname oHnd ->
+          do
             hPutStrLn cHnd program
             hClose cHnd
             hClose oHnd
@@ -2689,8 +2687,8 @@ checkForeignDeps pkg lbi verbosity =
                 (withPrograms lbi)
                 (getSymbolicPath cName : "-o" : getSymbolicPath oNname : args)
             return True
-        `catchIO` (\_ -> return False)
-        `catchExit` (\_ -> return False)
+            `catchIO` (\_ -> return False)
+            `catchExit` (\_ -> return False)
 
     explainErrors Nothing [] = return () -- should be impossible!
     explainErrors _ _

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

@@ -85,7 +85,7 @@ import Distribution.Utils.Path
 import Distribution.Verbosity
 import Distribution.Version (Version)
 import Language.Haskell.Extension
-import System.Directory (getDirectoryContents, getTemporaryDirectory)
+import System.Directory (getDirectoryContents)
 import System.Environment (getEnv)
 import System.FilePath
   ( takeDirectory
@@ -221,9 +221,8 @@ configureToolchain _implInfo ghcProg ghcInfo =
     -- we need to find out if ld supports the -x flag
     configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
     configureLd' verbosity ldProg = do
-      tempDir <- getTemporaryDirectory
-      ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->
-        withTempFile tempDir ".o" $ \testofile testohnd -> do
+      ldx <- withTempFile ".c" $ \testcfile testchnd ->
+        withTempFile ".o" $ \testofile testohnd -> do
           hPutStrLn testchnd "int foo() { return 0; }"
           hClose testchnd
           hClose testohnd
@@ -236,7 +235,7 @@ configureToolchain _implInfo ghcProg ghcInfo =
             , "-o"
             , testofile
             ]
-          withTempFile tempDir ".o" $ \testofile' testohnd' ->
+          withTempFile ".o" $ \testofile' testohnd' ->
             do
               hClose testohnd'
               _ <-

Cabal/src/Distribution/Simple/Haddock.hs

@@ -1133,8 +1133,6 @@ renderArgs verbosity mbWorkDir tmpFileOpts version comp platform args k = do
                 withResponseFile
                   verbosity
                   tmpFileOpts
-                  mbWorkDir
-                  outputDir
                   "haddock-response.txt"
                   (if haddockSupportsUTF8 then Just utf8 else Nothing)
                   renderedArgs
@@ -1144,7 +1142,7 @@ renderArgs verbosity mbWorkDir tmpFileOpts version comp platform args k = do
     (Flag pfile, _) ->
       withPrologueArgs ["--prologue=" ++ pfile]
     (_, Flag prologueText) ->
-      withTempFileEx tmpFileOpts mbWorkDir outputDir "haddock-prologue.txt" $
+      withTempFileEx tmpFileOpts "haddock-prologue.txt" $
         \prologueFileName h -> do
           when haddockSupportsUTF8 (hSetEncoding h utf8)
           hPutStrLn h prologueText

Cabal/src/Distribution/Simple/PreProcess.hs

@@ -511,8 +511,6 @@ ppHsc2hs bi lbi clbi =
             withResponseFile
               verbosity
               defaultTempFileOptions
-              mbWorkDir
-              (makeSymbolicPath $ takeDirectory outFile)
               "hsc2hs-response.txt"
               Nothing
               pureArgs

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

@@ -154,7 +154,7 @@ createArLibArchive verbosity lbi targetPath files = do
                 (initial, middle, final)
                 (map getSymbolicPath files)
           ]
-      else withResponseFile verbosity defaultTempFileOptions mbWorkDir tmpDir "ar.rsp" Nothing (map getSymbolicPath files) $
+      else withResponseFile verbosity defaultTempFileOptions "ar.rsp" Nothing (map getSymbolicPath files) $
         \path -> runProgramInvocation verbosity $ invokeWithResponseFile path
 
     unless

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

@@ -83,8 +83,6 @@ combineObjectFiles verbosity lbi ldProg target files = do
     middle = ld middleArgs
     final = ld finalArgs
 
-    targetDir = takeDirectorySymbolicPath target
-
     invokeWithResponseFile :: FilePath -> ProgramInvocation
     invokeWithResponseFile atFile =
       ld $ simpleArgs ++ ['@' : atFile]
@@ -106,7 +104,7 @@ combineObjectFiles verbosity lbi ldProg target files = do
 
   if oldVersionManualOverride || responseArgumentsNotSupported
     then run $ multiStageProgramInvocation simple (initial, middle, final) (map getSymbolicPath files)
-    else withResponseFile verbosity defaultTempFileOptions mbWorkDir targetDir "ld.rsp" Nothing (map getSymbolicPath files) $
+    else withResponseFile verbosity defaultTempFileOptions "ld.rsp" Nothing (map getSymbolicPath files) $
       \path -> runProgramInvocation verbosity $ invokeWithResponseFile path
   where
     tmpfile = target <.> "tmp" -- perhaps should use a proper temp file

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

@@ -27,10 +27,6 @@ import Distribution.Verbosity
 withResponseFile
   :: Verbosity
   -> TempFileOptions
-  -> Maybe (SymbolicPath CWD (Dir Pkg))
-  -- ^ Working directory
-  -> SymbolicPath Pkg (Dir Response)
-  -- ^ Directory to create response file in.
   -> String
   -- ^ Template for response file name.
   -> Maybe TextEncoding
@@ -39,8 +35,8 @@ withResponseFile
   -- ^ Arguments to put into response file.
   -> (FilePath -> IO a)
   -> IO a
-withResponseFile verbosity tmpFileOpts mbWorkDir responseDir fileNameTemplate encoding arguments f =
-  withTempFileEx tmpFileOpts mbWorkDir responseDir fileNameTemplate $ \responsePath hf -> do
+withResponseFile verbosity tmpFileOpts fileNameTemplate encoding arguments f =
+  withTempFileEx tmpFileOpts fileNameTemplate $ \responsePath hf -> do
     let responseFileName = getSymbolicPath responsePath
     traverse_ (hSetEncoding hf) encoding
     let responseContents =

Cabal/src/Distribution/Simple/Utils.hs

@@ -250,6 +250,7 @@ import System.Directory
   , getDirectoryContents
   , getModificationTime
   , getPermissions
+  , getTemporaryDirectory
   , removeDirectoryRecursive
   , removeFile
   )
@@ -1733,23 +1734,17 @@ defaultTempFileOptions = TempFileOptions{optKeepTempFiles = False}
 
 -- | Use a temporary filename that doesn't already exist
 withTempFile
-  :: FilePath
-  -- ^ Temp dir to create the file in
-  -> String
+  :: String
   -- ^ File name template. See 'openTempFile'.
   -> (FilePath -> Handle -> IO a)
   -> IO a
-withTempFile tmpDir template f = withFrozenCallStack $
-  withTempFileCwd Nothing (makeSymbolicPath tmpDir) template $
+withTempFile template f = withFrozenCallStack $
+  withTempFileCwd template $
     \fp h -> f (getSymbolicPath fp) h
 
 -- | Use a temporary filename that doesn't already exist.
 withTempFileCwd
-  :: Maybe (SymbolicPath CWD (Dir Pkg))
-  -- ^ Working directory
-  -> SymbolicPath Pkg (Dir tmpDir)
-  -- ^ Temp dir to create the file in
-  -> String
+  :: String
   -- ^ File name template. See 'openTempFile'.
   -> (SymbolicPath Pkg File -> Handle -> IO a)
   -> IO a
@@ -1758,33 +1753,29 @@ withTempFileCwd = withFrozenCallStack $ withTempFileEx defaultTempFileOptions
 -- | A version of 'withTempFile' that additionally takes a 'TempFileOptions'
 -- argument.
 withTempFileEx
-  :: forall a tmpDir
+  :: forall a
    . TempFileOptions
-  -> Maybe (SymbolicPath CWD (Dir Pkg))
-  -- ^ Working directory
-  -> SymbolicPath Pkg (Dir tmpDir)
-  -- ^ Temp dir to create the file in
   -> String
   -- ^ File name template. See 'openTempFile'.
   -> (SymbolicPath Pkg File -> Handle -> IO a)
   -> IO a
-withTempFileEx opts mbWorkDir tmpDir template action =
+withTempFileEx opts template action = do
+  tmp <- getTemporaryDirectory
   withFrozenCallStack $
     Exception.bracket
-      (openTempFile (i tmpDir) template)
+      (openTempFile tmp template)
       ( \(name, handle) -> do
           hClose handle
           unless (optKeepTempFiles opts) $
             handleDoesNotExist () $
               removeFile $
                 name
       )
-      (withLexicalCallStack (\(fn, h) -> action (mkRelToPkg fn) h))
+      (withLexicalCallStack (\(fn, h) -> action (mkRelToPkg tmp fn) h))
   where
-    i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path
-    mkRelToPkg :: FilePath -> SymbolicPath Pkg File
-    mkRelToPkg fp =
-      tmpDir </> makeRelativePathEx (takeFileName fp)
+    mkRelToPkg :: FilePath -> FilePath -> SymbolicPath Pkg File
+    mkRelToPkg tmp fp =
+      makeSymbolicPath tmp </> makeRelativePathEx (takeFileName fp)
 
 -- 'openTempFile' returns a path of the form @i tmpDir </> fn@, but we
 -- want 'withTempFileEx' to return @tmpDir </> fn@. So we split off

cabal-install/src/Distribution/Client/HttpUtils.hs

@@ -467,7 +467,6 @@ curlTransport prog =
   where
     gethttp verbosity uri etag destPath reqHeaders = do
       withTempFile
-        (takeDirectory destPath)
         "curl-headers.txt"
         $ \tmpFile tmpHandle -> do
           hClose tmpHandle
@@ -675,10 +674,9 @@ wgetTransport prog =
 
     posthttpfile verbosity uri path auth =
       withTempFile
-        (takeDirectory path)
         (takeFileName path)
         $ \tmpFile tmpHandle ->
-          withTempFile (takeDirectory path) "response" $
+          withTempFile "response" $
             \responseFile responseHandle -> do
               hClose responseHandle
               (body, boundary) <- generateMultipartBody path
@@ -702,7 +700,7 @@ wgetTransport prog =
                 evaluate $ force (code, resp)
 
     puthttpfile verbosity uri path auth headers =
-      withTempFile (takeDirectory path) "response" $
+      withTempFile "response" $
         \responseFile responseHandle -> do
           hClose responseHandle
           let args =
@@ -824,7 +822,6 @@ powershellTransport prog =
 
     posthttpfile verbosity uri path auth =
       withTempFile
-        (takeDirectory path)
         (takeFileName path)
         $ \tmpFile tmpHandle -> do
           (body, boundary) <- generateMultipartBody path

cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.test.hs

@@ -2,7 +2,7 @@ import Test.Cabal.Prelude
 
 main = cabalTest $ do
     skipUnlessGhcVersion ">= 8.1"
-    expectBrokenIfWindowsCI 10191 $ withProjectFile "cabal.internal.project" $ do
+    withProjectFile "cabal.internal.project" $ do
         cabal "v2-build" ["exe"]
         withPlan $ do
             r <- runPlanExe' "I" "exe" []