From 4a0b05a38731aabc120645b828d59e67a246cda0 Mon Sep 17 00:00:00 2001
From: Robert Vollmert <rob@vllmrt.net>
Date: Sat, 29 Jan 2022 00:18:04 +0100
Subject: [PATCH] Use async-safe bracket for withTempFileName

If `withTempFileName` receives an asynchronous exception (e.g.
a canceled async), the bracket cleanup handler will attempt to
remove the temporary file. This can fail with an IO exception.

Regular bracket then throws that IO exception, swallowing the
asynchronous exception. To calling code, this appears no different
from an IO exception thrown from the body, and it won't be able
to tell that it should be exiting promptly.

This manifests concretely during temporary file clean-up of
`asyncFetchPackages` on Windows (seen during unit testing in CI),
where temporary file removal fails (on GHC 8.4), which leads
to `concurrently` failing to cancel the outstanding download
because it's handled like a regular download failure.
---
 cabal-install/src/Distribution/Client/Utils.hs | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/cabal-install/src/Distribution/Client/Utils.hs b/cabal-install/src/Distribution/Client/Utils.hs
index e4296bf09e..849bdd8814 100644
--- a/cabal-install/src/Distribution/Client/Utils.hs
+++ b/cabal-install/src/Distribution/Client/Utils.hs
@@ -49,7 +49,9 @@ import Data.List
          ( groupBy )
 import Foreign.C.Types ( CInt(..) )
 import qualified Control.Exception as Exception
-         ( finally, bracket )
+         ( finally )
+import qualified Control.Exception.Safe as Safe
+         ( bracket )
 import System.Directory
          ( canonicalizePath, doesFileExist, findExecutable, getCurrentDirectory
          , removeFile, setCurrentDirectory, getDirectoryContents, doesDirectoryExist )
@@ -118,7 +120,7 @@ withTempFileName :: FilePath
                  -> String
                  -> (FilePath -> IO a) -> IO a
 withTempFileName tmpDir template action =
-  Exception.bracket
+  Safe.bracket
     (openTempFile tmpDir template)
     (\(name, _) -> removeExistingFile name)
     (\(name, h) -> hClose h >> action name)
-- 
GitLab