Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Detect asynchronous exceptions via their types #187 #202

Merged
merged 3 commits into from
Feb 14, 2018
+39 −2
Merged

Detect asynchronous exceptions via their types #187 #202

Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
61cd146
Detect asynchronous exceptions via their types #187
snoyberg Feb 13, 2018
fc49e14
Treat Timeout as an async exception too
snoyberg Feb 13, 2018
d35db7b
Remove exceptions not actually considered async
snoyberg Feb 13, 2018
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
41 changes: 39 additions & 2 deletions hackage-security/src/Hackage/Security/Util/Checked.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -9,6 +9,8 @@
{-# LANGUAGE IncoherentInstances #-}
#endif

{-# LANGUAGE DeriveDataTypeable#-}

-- | Checked exceptions
module Hackage.Security.Util.Checked (
Throws
Expand All @@ -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)
Expand All @@ -50,14 +53,48 @@ 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
| show e == "<<timeout>>" -> 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
Expand Down