From ba466e497e68a9dff370e282a49d418e0bdf00a7 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Tue, 24 Sep 2024 17:20:53 +0200 Subject: [PATCH] ww --- .../src/Distribution/Utils/Generic.hs | 12 ++++++---- .../UnitTests/Distribution/Simple/Utils.hs | 11 ++++----- Cabal/src/Distribution/Simple/Configure.hs | 7 ++---- Cabal/src/Distribution/Simple/GHC/Internal.hs | 9 ++++---- Cabal/src/Distribution/Simple/Haddock.hs | 4 +--- Cabal/src/Distribution/Simple/PreProcess.hs | 2 -- Cabal/src/Distribution/Simple/Program/Ar.hs | 2 +- Cabal/src/Distribution/Simple/Program/Ld.hs | 4 +--- .../Simple/Program/ResponseFile.hs | 8 ++----- Cabal/src/Distribution/Simple/Utils.hs | 23 +++++-------------- .../src/Distribution/Client/HttpUtils.hs | 7 ++---- 11 files changed, 31 insertions(+), 58 deletions(-) diff --git a/Cabal-syntax/src/Distribution/Utils/Generic.hs b/Cabal-syntax/src/Distribution/Utils/Generic.hs index f8380f36137..516665ac166 100644 --- a/Cabal-syntax/src/Distribution/Utils/Generic.hs +++ b/Cabal-syntax/src/Distribution/Utils/Generic.hs @@ -100,12 +100,14 @@ import qualified Data.Set as Set import qualified Control.Exception as Exception import System.Directory - ( getTemporaryDirectory + ( copyFile + , getTemporaryDirectory , removeFile , renameFile ) import System.FilePath - ( splitFileName + ( takeFileName + , takeDrive , (<.>) ) import System.IO @@ -172,7 +174,7 @@ withFileContents name action = -- This case will give an IO exception but the atomic property is not affected. writeFileAtomic :: FilePath -> LBS.ByteString -> IO () writeFileAtomic targetPath content = do - let (_, targetFile) = splitFileName targetPath + let targetFile = takeFileName targetPath tmpDir <- getTemporaryDirectory Exception.bracketOnError (openBinaryTempFileWithDefaultPermissions tmpDir $ targetFile <.> "tmp") @@ -180,7 +182,9 @@ writeFileAtomic targetPath content = do ( \(tmpPath, handle) -> do LBS.hPut handle content hClose handle - renameFile tmpPath targetPath + if takeDrive targetPath == takeDrive tmpDir + then renameFile tmpPath targetPath + else 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..242444a7ec1 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,8 @@ 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 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 372098d0a8a..d51601e5c27 100644 --- a/Cabal/src/Distribution/Simple/Utils.hs +++ b/Cabal/src/Distribution/Simple/Utils.hs @@ -1734,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 @@ -1759,17 +1753,13 @@ 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 = do +withTempFileEx opts template action = do tmp <- getTemporaryDirectory withFrozenCallStack $ Exception.bracket @@ -1783,7 +1773,6 @@ withTempFileEx opts _mbWorkDir _tmpDir template action = do ) (withLexicalCallStack (\(fn, h) -> action (mkRelToPkg tmp fn) h)) where - -- i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path mkRelToPkg :: FilePath -> FilePath -> SymbolicPath Pkg File mkRelToPkg tmp fp = makeSymbolicPath tmp makeRelativePathEx (takeFileName fp) 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