Fix lost asynchronous exception in asyncFetchPackages (fixes haskell#6322)

The concrete bug is that `try` catches asynchronous exceptions,
preventing `withAsync` from interrupting it when its `body`
action finishes prematurely.

This manifests during `cabal build` when hitting Ctrl-C during
download, e.g.:

1. Ctrl-C interrupts a curl process
2. This interrupt is converted into a UserInterrupt exception
   via the process package's delegate_ctlc functionality.
3. UserInterrupt bubbles up through `fetchPackage`, is caught by
   the `try` (fine) and writen to the result mvar.
   Meanwhile, `fetchPackage` continues its loop, starting to
   fetch the next package.
4. Some `rebuildTarget` is waiting for the interrupted download;
  `waitAsyncFetchPackage` rethrows UserInterrupt in that thread.
5. UserInterrupt bubbles up through `collectJob`, `execute`, the
   `body` action.
6. `withAsync`'s finalizer cancels the `fetchPackages` async.
7. The `fetchPackages` async receives the AsyncCancelled exception
   while fetching the next package (see 3. above). This interrupts
   the download action (it shouldn't matter whether we happen to
   be running curl again or not), and AsyncCancelled bubbles up
   through `fetchPackage`, is caught by the `try` (not fine!) and
   written to the mvar. But no-one is reading that mvar anymore
   because the build job already aborted (step 5), and that
   AsyncCancelled exception is lost.
8. `fetchPackages` keeps doing its thing, exiting eventually.

Note that this change affects both instances of `try` in this story:
`UserInterrupt` is also an asynchronous exception, so after the
change the `UserInterrupt` takes a different path from step 3. That
appears to be fine, though.

Author: robx

cabal-install/cabal-install.cabal

@@ -226,7 +226,8 @@ library
         text       >= 1.2.3    && < 1.3,
         parsec     >= 3.1.13.0 && < 3.2,
         regex-base  >= 0.94.0.0 && <0.95,
-        regex-posix >= 0.96.0.0 && <0.97
+        regex-posix >= 0.96.0.0 && <0.97,
+        safe-exceptions
 
     if flag(native-dns)
       if os(windows)

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

@@ -52,7 +52,7 @@ import Distribution.Client.Utils
          ( ProgressPhase(..), progressMessage )
 
 import qualified Data.Map as Map
-import Control.Exception
+import qualified Control.Exception.Safe as SafeExceptions
 import Control.Concurrent.Async
 import Control.Concurrent.MVar
 import System.Directory
@@ -247,8 +247,10 @@ asyncFetchPackages verbosity repoCtxt pkglocs body = do
         fetchPackages =
           for_ asyncDownloadVars $ \(pkgloc, var) -> do
             -- Suppress marking here, because 'withAsync' means
-            -- that we get nondeterministic interleaving
-            result <- try $ fetchPackage (verboseUnmarkOutput verbosity)
+            -- that we get nondeterministic interleaving.
+            -- It is essential that we don't catch async exceptions here,
+            -- specifically AsyncCancelled thrown at us from withAsync.
+            result <- SafeExceptions.try $ fetchPackage (verboseUnmarkOutput verbosity)
                                 repoCtxt pkgloc
             putMVar var result