From 61cd14609e5d7067e14469df31aafebfffda879c Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Tue, 13 Feb 2018 16:22:52 +0200
Subject: [PATCH] Detect asynchronous exceptions via their types #187

This commit uses the same async-exception detection mechanism as is used
by the safe-exceptions package, via checking if the given exception is
cast to a SomeAsyncException. (On older GHCs without SomeAsyncException,
it contains a hard-coded list of async exception types.) It then ensures
that:

* Throwing via throwChecked always generates a synchronous exception
* Catching via catchChecked (et al) never catches an asynchronous
  exception

Unfortunately, I don't currently have a reliable test case to ensure
that this fixes the problems described in #187. Hopefully with this
patch available we can begin testing cabal-install and Stack against the
change and see if it resolves the issues.
---
 .../src/Hackage/Security/Util/Checked.hs      | 43 ++++++++++++++++++-
 1 file changed, 41 insertions(+), 2 deletions(-)

diff --git a/hackage-security/src/Hackage/Security/Util/Checked.hs b/hackage-security/src/Hackage/Security/Util/Checked.hs
index 62392b9d..6ce9d3db 100644
--- a/hackage-security/src/Hackage/Security/Util/Checked.hs
+++ b/hackage-security/src/Hackage/Security/Util/Checked.hs
@@ -9,6 +9,8 @@
 {-# LANGUAGE IncoherentInstances #-}
 #endif
 
+{-# LANGUAGE DeriveDataTypeable#-}
+
 -- | Checked exceptions
 module Hackage.Security.Util.Checked (
     Throws
@@ -25,6 +27,7 @@ module Hackage.Security.Util.Checked (
 
 import Control.Exception (Exception, IOException)
 import qualified Control.Exception as Base
+import Data.Typeable (Typeable)
 
 #if __GLASGOW_HASKELL__ >= 708
 import GHC.Prim (coerce)
@@ -50,14 +53,50 @@ unthrow _ x = unWrap (coerceWrap (Wrap x :: Wrap e a))
   Base exceptions
 -------------------------------------------------------------------------------}
 
+-- | Determine if an exception is asynchronous, based on its type.
+isAsync :: Exception e => e -> Bool
+#if MIN_VERSION_base(4, 7, 0)
+isAsync e =
+  case Base.fromException $ Base.toException e of
+    Just Base.SomeAsyncException{} -> True
+    Nothing -> False
+#else
+-- Earlier versions of GHC had no SomeAsyncException. We have to
+-- instead make up a list of async exceptions.
+isAsync e =
+  let se = Base.toException e
+   in case () of
+        ()
+          | Just (_ :: Base.AsyncException) <- Base.fromException se -> True
+          | Just (_ :: Base.Deadlock) <- Base.fromException se -> True
+          | Just (_ :: Base.BlockedIndefinitelyOnSTM) <- Base.fromException se -> True
+          | Just (_ :: Base.BlockedIndefinitelyOnMVar) <- Base.fromException se -> True
+          | otherwise -> False
+#endif
+
+-- | 'Base.catch', but immediately rethrows asynchronous exceptions
+-- (as determined by 'isAsync').
+catchSync :: Exception e => IO a -> (e -> IO a) -> IO a
+catchSync act onErr = act `Base.catch` \e ->
+  if isAsync e
+    then Base.throwIO e
+    else onErr e
+
+-- | Wraps up an async exception as a synchronous exception.
+newtype SyncException = SyncException Base.SomeException
+  deriving (Show, Typeable)
+instance Exception SyncException
+
 -- | Throw a checked exception
 throwChecked :: (Exception e, Throws e) => e -> IO a
-throwChecked = Base.throwIO
+throwChecked e
+  | isAsync e = Base.throwIO $ SyncException $ Base.toException e
+  | otherwise = Base.throwIO e
 
 -- | Catch a checked exception
 catchChecked :: forall a e. Exception e
              => (Throws e => IO a) -> (e -> IO a) -> IO a
-catchChecked act = Base.catch (unthrow (Proxy :: Proxy e) act)
+catchChecked act = catchSync (unthrow (Proxy :: Proxy e) act)
 
 -- | 'catchChecked' with the arguments reversed
 handleChecked :: Exception e => (e -> IO a) -> (Throws e => IO a) -> IO a