diff --git a/.github/workflows/validate.yml b/.github/workflows/validate.yml index 947b47a5f12..d7bd8a77248 100644 --- a/.github/workflows/validate.yml +++ b/.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 diff --git a/Cabal-syntax/src/Distribution/Utils/Generic.hs b/Cabal-syntax/src/Distribution/Utils/Generic.hs index ace55a67aa3..cd37f914bfe 100644 --- a/Cabal-syntax/src/Distribution/Utils/Generic.hs +++ b/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 + ) ) -- ------------------------------------------------------------ diff --git a/Cabal-tests/tests/UnitTests/Distribution/Simple/Utils.hs b/Cabal-tests/tests/UnitTests/Distribution/Simple/Utils.hs index 2e544c8c52d..48e8aae9c1d 100644 --- a/Cabal-tests/tests/UnitTests/Distribution/Simple/Utils.hs +++ b/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])" diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs index 033f3c9de54..37004717f10 100644 --- a/Cabal/src/Distribution/Simple/Configure.hs +++ b/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 _ _ diff --git a/Cabal/src/Distribution/Simple/GHC/Internal.hs b/Cabal/src/Distribution/Simple/GHC/Internal.hs index 0686f30ba1b..6e27b41bc83 100644 --- a/Cabal/src/Distribution/Simple/GHC/Internal.hs +++ b/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' _ <- diff --git a/Cabal/src/Distribution/Simple/Haddock.hs b/Cabal/src/Distribution/Simple/Haddock.hs index ba025a85549..ec4e60ff685 100644 --- a/Cabal/src/Distribution/Simple/Haddock.hs +++ b/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 diff --git a/Cabal/src/Distribution/Simple/PreProcess.hs b/Cabal/src/Distribution/Simple/PreProcess.hs index 61dd8163733..e56627893c1 100644 --- a/Cabal/src/Distribution/Simple/PreProcess.hs +++ b/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 diff --git a/Cabal/src/Distribution/Simple/Program/Ar.hs b/Cabal/src/Distribution/Simple/Program/Ar.hs index 004b02cca1a..2e9b432385f 100644 --- a/Cabal/src/Distribution/Simple/Program/Ar.hs +++ b/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 diff --git a/Cabal/src/Distribution/Simple/Program/Ld.hs b/Cabal/src/Distribution/Simple/Program/Ld.hs index 5c2a33809ae..00ed5d182d7 100644 --- a/Cabal/src/Distribution/Simple/Program/Ld.hs +++ b/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 diff --git a/Cabal/src/Distribution/Simple/Program/ResponseFile.hs b/Cabal/src/Distribution/Simple/Program/ResponseFile.hs index ee8271545f1..dec6cb0ae50 100644 --- a/Cabal/src/Distribution/Simple/Program/ResponseFile.hs +++ b/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 = diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs index 3688f602759..d51601e5c27 100644 --- a/Cabal/src/Distribution/Simple/Utils.hs +++ b/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,20 +1753,17 @@ 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) $ @@ -1779,12 +1771,11 @@ withTempFileEx opts mbWorkDir tmpDir template action = 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 diff --git a/cabal-install/src/Distribution/Client/HttpUtils.hs b/cabal-install/src/Distribution/Client/HttpUtils.hs index 956241ab307..3cdadf9304c 100644 --- a/cabal-install/src/Distribution/Client/HttpUtils.hs +++ b/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 diff --git a/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.test.hs b/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.test.hs index e2c42fe43fd..1413f66dcdc 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes2/cabal-internal.test.hs +++ b/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" [] diff --git a/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-external.test.hs b/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-external.test.hs index a2431cdf389..a974254fc98 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-external.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-external.test.hs @@ -2,8 +2,6 @@ import Test.Cabal.Prelude main = cabalTest $ do skipUnlessGhcVersion ">= 8.1" - ghcVer <- isGhcVersion ">= 9.10" - skipIf "Windows + 9.10.1 (#10191)" (isWindows && ghcVer) withProjectFile "cabal.external.project" $ do cabal "v2-build" ["exe"] withPlan $ do diff --git a/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-internal.test.hs b/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-internal.test.hs index b0d3e21688f..81f3fcb0027 100644 --- a/cabal-testsuite/PackageTests/Backpack/Includes3/cabal-internal.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/Includes3/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" [] diff --git a/cabal-testsuite/PackageTests/Backpack/T6385/cabal.test.hs b/cabal-testsuite/PackageTests/Backpack/T6385/cabal.test.hs index d05327839da..5048e09d56b 100644 --- a/cabal-testsuite/PackageTests/Backpack/T6385/cabal.test.hs +++ b/cabal-testsuite/PackageTests/Backpack/T6385/cabal.test.hs @@ -1,6 +1,6 @@ import Test.Cabal.Prelude main = - cabalTest $ expectBrokenIfWindows 10191 $ withShorterPathForNewBuildStore $ do + cabalTest $ withShorterPathForNewBuildStore $ do skipUnlessGhcVersion ">= 8.1" withRepo "repo" $ do cabal "v2-build" ["T6385"] diff --git a/cabal-testsuite/PackageTests/HaddockKeepsTmps/cabal.test.hs b/cabal-testsuite/PackageTests/HaddockKeepsTmps/cabal.test.hs index a4db6795625..a8c12e74bc0 100644 --- a/cabal-testsuite/PackageTests/HaddockKeepsTmps/cabal.test.hs +++ b/cabal-testsuite/PackageTests/HaddockKeepsTmps/cabal.test.hs @@ -1,21 +1,23 @@ {-# LANGUAGE LambdaCase #-} import Test.Cabal.Prelude -import Data.List (sort) +import Data.List (sort, isPrefixOf) import Distribution.Verbosity import Distribution.Simple.Glob import Distribution.Simple.Glob.Internal import Distribution.Simple.Utils +import System.Directory -- Test that "cabal haddock" preserves temporary files -- We use haddock-keep-temp-file: True in the cabal.project. -main = cabalTest $ recordMode DoNotRecord $ withProjectFile "cabal.project" $ do - cabal "haddock" [] - - cwd <- fmap testCurrentDir getTestEnv - - -- Windows has multiple response files, and only the last one (alphabetically) is the important one. - (safeLast . sort . globMatches <$> liftIO (runDirFileGlob silent Nothing cwd (GlobDirRecursive [WildCard, Literal "txt"]))) >>= \case - Nothing -> error "Expecting a response file to exist" - Just m -> do - -- Assert the matched response file is not empty, and indeed a haddock rsp - assertFileDoesContain (cwd m) "--package-name" +main = + cabalTest $ recordMode DoNotRecord $ withProjectFile "cabal.project" $ do + pwd <- testTmpDir <$> getTestEnv + liftIO $ createDirectory (pwd "temp") + withEnv [(if isWindows then "TMP" else "TMPDIR", Just $ pwd "temp")] $ + cabal "haddock" [] + files <- liftIO $ listDirectory (pwd "temp") + case [ f | f <- files, takeExtension f == ".txt" ] of + [] -> error "Expecting a response file being mentioned in the outcome" + (m:_) -> + -- Assert the matched response file is not empty, and indeed a haddock rsp + assertFileDoesContain (pwd "temp" m) "--package-name"