diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +## 0.1.0.0 + +* Initial releae diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 FP Complete + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,356 @@ +# safe-exceptions + +*Safe, consistent, and easy exception handling* + +__NOTE__: This library is early in its development, and there may be some +changes in the near future. See [possible future +changes](-exceptions#possible-future-changes). + +[![Build Status](https://travis-ci.org/fpco/safe-exceptions.svg?branch=master)](https://travis-ci.org/fpco/safe-exceptions) + +Runtime exceptions - as exposed in `base` by the `Control.Exception` +module - have long been an intimidating part of the Haskell +ecosystem. This package, and this README for the package, are intended +to overcome this. By providing an API that encourages best practices, +and explaining the corner cases clearly, the hope is to turn what was +previously something scary into an aspect of Haskell everyone feels +safe using. + +## Goals + +This package provides additional safety and simplicity versus +`Control.Exception` by having its functions recognize the difference between +synchronous and asynchronous exceptions. As described below, synchronous +exceptions are treated as _recoverable_, allowing you to catch and handle them +as well as clean up after them, whereas asynchronous exceptions can only be +cleaned up after. In particular, this library prevents you from making the +following mistakes: + +* Catching and swallowing an asynchronous exception +* Throwing an asynchronous exception synchronously +* Throwing a synchronous exception asynchronously +* Swallowing asynchronous exceptions via failing cleanup handlers + +## Quickstart + +This section is intended to give you the bare minimum information to +use this library (and Haskell runtime exceptions in general) +correctly. + +* Import the `Control.Exception.Safe` module. Do _not_ import + `Control.Exception` itself, which lacks the safety guarantees that + this library adds. Same applies to `Control.Monad.Catch`. +* If something can go wrong in your function, you can report this with + the `throw`. (For compatible naming, there are synonyms for this of + `throwIO` and `throwM`.) +* If you want to catch a specific type of exception, use `catch`, + `handle`, or `try`. +* If you want to recover from _anything_ that may go wrong in a + function, use `catchAny`, `handleAny`, or `tryAny`. +* If you want to launch separate threads and kill them externally, you + should use the + [async package](https://www.stackage.org/package/async). +* Unless you really know what you're doing, avoid the following functions: + * `catchAsync` + * `handleAsync` + * `tryAsync` + * `impureThrow` + * `throwTo` +* If you need to perform some allocation or cleanup of resources, use + one of the following functions (and _don't_ use the + `catch`/`handle`/`try` family of functions): + * `onException` + * `withException` + * `bracket` + * `bracket_` + * `finally` + * `bracketOnError` + * `bracketOnError_` + +Hopefully this will be able to get you up-and-running quickly. + +_Request to readers_: if there are specific workflows that you're +unsure of how to accomplish with this library, please ask so we can +develop a more full-fledged cookbook as a companion to this file. + +## Terminology + +We're going to define three different versions of exceptions. Note +that these definitions are based on _how the exception is thrown_, not +based on _what the exception itself is_: + +* **Synchronous** exceptions are generated by the current + thread. What's important about these is that we generally want to be + able to recover from them. For example, if you try to read from a + file, and the file doesn't exist, you may wish to use some default + value instead of having your program exit, or perhaps prompt the + user for a different file location. + +* **Asynchronous** exceptions are thrown by either a different user + thread, or by the runtime system itself. For example, in the + `async` package, `race` will kill the longer-running thread with + an asynchronous exception. Similarly, the `timeout` function will + kill an action which has run for too long. And the runtime system + will kill threads which appear to be deadlocked on `MVar`s or + `STM` actions. + + In contrast to synchronous exceptions, we almost never want to + recover from asynchronous exceptions. In fact, this is a common + mistake in Haskell code, and from what I've seen has been the + largest source of confusion and concern amongst users when it + comes to Haskell's runtime exception system. + +* **Impure** exceptions are hidden inside a pure value, and exposed + by forcing evaluation of that value. Examples are `error`, + `undefined`, and `impureThrow`. Additionally, incomplete pattern + matches can generate impure exceptions. Ultimately, when these + pure values are forced and the exception is exposed, it is thrown + as a synchronous exception. + + Since they are ultimately thrown as synchronous exceptions, when + it comes to handling them, we want to treat them in all ways like + synchronous exceptions. Based on the comments above, that means we + want to be able to recover from impure exceptions. + +## Why catch asynchronous exceptions? + +If we never want to be able to recover from asynchronous exceptions, +why do we want to be able to catch them at all? The answer is for +_resource cleanup_. For both sync and async exceptions, we would like +to be able to acquire resources - like file descriptors - and register +a cleanup function which is guaranteed to be run. This is exemplified +by functions like `bracket` and `withFile`. + +So to summarize: + +* All synchronous exceptions should be recoverable +* All asynchronous exceptions should not be recoverable +* In both cases, cleanup code needs to work reliably + +## Determining sync vs async + +Unfortunately, GHC's runtime system provides no way to determine if an +exception was thrown synchronously or asynchronously, but this +information is vitally important. There are two general approaches to +dealing with this: + +* Run an action in a separate thread, don't give that thread's ID to + anyone else, and assume that any exception that kills it is a + synchronous exception. This approach is covered in the School of + Haskell article + [catching all exceptions](https://www.schoolofhaskell.com/user/snoyberg/general-haskell/exceptions/catching-all-exceptions), + and is provided by the + [enclosed-exceptions](https://www.stackage.org/package/enclosed-exceptions) + package. + +* Make assumptions based on the type of an exception, assuming that + certain exception types are only thrown synchronously and certain + only asynchronously. + +Both of these approaches have downsides. For the downsides the +type-based approach, see the caveats section at the end. The problems +with the first are more interesting to us here: + +* It's much more expensive to fork a thread every time we want to deal + with exceptions +* It's not fully reliable: it's possible for the thread ID of the + forked thread to leak somewhere, or the runtime system to send it an + async exception +* While this works for actions living in `IO`, it gets trickier for + pure functions and monad transformer stacks. The latter issue is + solved via monad-control and the exceptions packages. The former + issue, however, means that it's impossible to provide a universal + interface for failure for pure and impure actions. This may seem + esoteric, and if so, don't worry about it too much. + +Therefore, this package takes the approach of trusting type +information to determine if an exception is asynchronous or +synchronous. The details are less interesting to a user, but the +basics are: we leverage the extensible extension system in GHC and +state that any extension type which is a child of `SomeAsyncException` +is an async exception. All other exception types are assumed to be +synchronous. + +## Handling of sync vs async exceptions + +Once we're able to distinguish between sync and async exceptions, and +we know our goals with sync vs async, how we handle things is pretty +straightforward: + +* If the user is trying to install a cleanup function (such as with + `bracket` or `finally`), we don't care if the exception is sync or + async: call the cleanup function and then rethrow the exception. +* If the user is trying to catch an exception and recover from it, + only catch sync exceptions and immediately rethrow async exceptions. + +With this explanation, it's useful to consider async exceptions as +"stronger" or more severe than sync exceptions, as the next section +will demonstrate. + +## Exceptions in cleanup code + +One annoying corner case is: what happens if, when running a cleanup function after an exception was thrown, the cleanup function _itself_ throws an exception. For this, we'll consider ``action `onException` cleanup``. There are four different possibilities: + +* `action` threw sync, `cleanup` threw sync +* `action` threw sync, `cleanup` threw async +* `action` threw async, `cleanup` threw sync +* `action` threw async, `cleanup` threw async + +Our guiding principle is: we cannot hide a more severe exception with +a less severe exception. For example, if `action` threw a sync +exception, and then `cleanup` threw an async exception, it would be a +mistake to rethrow the sync exception thrown by `action`, since it +would allow the user to recover when that is not desired. + +Therefore, this library will always throw an async exception if either +the action or cleanup thows an async exception. Other than that, the +behavior is currently undefined as to which of the two exceptions will +be thrown. The library reserves the right to throw away either of the +two thrown exceptions, or generate a new exception value completely. + +## Typeclasses + +The [exceptions package](https://www.stackage.org/package/exceptions) +provides an abstraction for throwing, catching, and cleaning up from +exceptions for many different monads. This library leverages those +type classes to generalize our functions. + +## Naming + +There are a few choices of naming that differ from the base libraries: + +* `throw` in this library is for synchronously throwing within a + monad, as opposed to in base where `throwIO` serves this purpose and + `throw` is for impure throwing. This library provides `impureThrow` + for the latter case, and also provides convenience synonyms + `throwIO` and `throwM` for `throw`. +* The `catch` function in this package will not catch async + exceptions. Please use `catchAsync` if you really want to catch + those, though it's usually better to use a function like `bracket` + or `withException` with ensure that the thrown exception is + rethrown. + +## Caveats + +Let's talk about the caveats to keep in mind when using this library. + +### Checked vs unchecked + +There is a big debate and difference of opinion regarding checked +versus unchecked exceptions. With checked exceptions, a function +states explicitly exactly what kinds of exceptions it can throw. With +unchecked exceptions, it simply says "I can throw some kind of +exception." Java is probably the most famous example of a checked +exception system, with many other languages (including C#, Python, and +Ruby) having unchecked exceptions. + +As usual, Haskell makes this interesting. Runtime exceptions are most +assuredly unchecked: all exceptions are converted to `SomeException` +via the `Exception` typeclass, and function signatures do not state +which specific exception types can be thrown (for more on this, see +next caveat). Instead, this information is relegated to documentation, +and unfortunately is often not even covered there. + +By contrast, approaches like `ExceptT` and `EitherT` are very explicit +in the type of exceptions that can be thrown. The cost of this is that +there is extra overhead necessary to work with functions that can +return different types of exceptions, usually by wrapping all possible +exceptions in a sum type. + +This library isn't meant to settle the debate on checked vs unchecked, +by rather to bring sanity to Haskell's runtime exception system. As +such, this library is decidedly in the unchecked exception camp, +purely by virtue of the fact that the underlying mechanism is as well. + +### Explicit vs implicit + +Another advantage of the `ExceptT`/`EitherT` approach is that you are +explicit in your function signature that a function may fail. However, +the reality of Haskell's standard libraries are that many, if not the +vast majority, of `IO` actions can throw some kind of exception. In +fact, once async exceptions are considered, _every_ `IO` action can +throw an exception. + +Once again, this library deals with the status quo of runtime +exceptions being ubiquitous, and gives the rule: you should consider +the `IO` type as meaning _both_ that a function modifies the outside +world, _and_ may throw an exception (and, based on the previous +caveat, may throw _any type_ of exception it feels like). + +There are attempts at alternative approaches here, such as +[unexceptionalio](https://www.stackage.org/package/unexceptionalio). Again, +this library isn't making a value statement on one approach versus +another, but rather trying to make today's runtime exceptions in +Haskell better. + +### Type-based differentiation + +As explained above, this library makes heavy usage of type information +to differentiate between sync and async exceptions. While the approach +used is fairly well respected in the Haskell ecosystem today, it's +certainly not universal, and definitely not enforced by the +`Control.Exception` module. In particular, `throwIO` will allow you to +synchronously throw an exception with an asynchronous type, and +`throwTo` will allow you to asynchronously throw an exception with a +synchronous type. + +The functions in this library prevent that from happening via +exception type wrappers, but if an underlying library does something +surprising, the functions here may not work correctly. Further, even +when using this library, you may be surprised by the fact that ``throw +Foo `catch` (\Foo -> ...)`` won't actually trigger the exception +handler if `Foo` looks like an asynchronous exception. + +The ideal solution is to make a stronger distinction in the core +libraries themselves between sync and async exceptions. + +### Deadlock detection exceptions + +Two exceptions types which are handled surprisingly are +`BlockedIndefinitelyOnMVar` and `BlockedIndefinitelyOnSTM`. Even +though these exceptions are thrown asynchronously by the runtime +system, for our purposes we treat them as synchronous. The reasons are +twofold: + +* There is a specific action taken in the local thread - blocking on a + variable which will never change - which causes the exception to be + raised. This makes their behavior very similar to synchronous + exceptions. In fact, one could argue that a function like `takeMVar` + is synchronously throwing `BlockedIndefinitelyOnMVar` +* By our standards of recoverable vs non-recoverable, these exceptions + certainly fall into the recoverable category. Unlike an intentional + kill signal from another thread or the user (via Ctrl-C), we would + like to be able to detect the we entered a deadlock condition and do + something intelligent in an application. + +## Possible future changes + +### Interruptible vs uninterruptible masking + +This discussion is now being tracked at: +https://github.com/fpco/safe-exceptions/issues/3 + +In `Control.Exception`, allocation functions and cleanup handlers in +combinators like `bracket` are masked using the (interruptible) `mask` +function, in contrast to `uninterruptibleMask`. There have been some debates +about the correctness of this in the past, notably [a libraries mailing list +discussion kicked off by Eyal +Lotem](https://mail.haskell.org/pipermail/libraries/2014-September/023675.html). +It seems that general consensus is: + +* `uninterruptibleMask` is a better choice +* But changing the core library like this would potentially break too many + programs + +In its current version, this library uses `mask` (interruptible) for allocation +functions and `uninterruptibleMask` cleanup handlers. This is a debatable +decision (and one worth debating!). An example of alternatives would be: + +* Use `uninterruptibleMask` for both allocation and cleanup pieces +* Match `Control.Exception`'s behavior +* Provide two versions of each function, or possibly two modules + +### Naming of the synchronous monadic throwing function + +We may decide to rename `throw` to something else at some point. Please see +https://github.com/fpco/safe-exceptions/issues/4 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/safe-exceptions.cabal b/safe-exceptions.cabal new file mode 100644 --- /dev/null +++ b/safe-exceptions.cabal @@ -0,0 +1,38 @@ +name: safe-exceptions +version: 0.1.0.0 +synopsis: Safe, consistent, and easy exception handling +description: Please see README.md +homepage: https://github.com/githubuser/safe-exceptions#readme +license: MIT +license-file: LICENSE +author: Michael Snoyman +maintainer: michael@fpcomplete.com +copyright: 2016 FP Complete +category: Control +build-type: Simple +extra-source-files: README.md ChangeLog.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Control.Exception.Safe + build-depends: base >= 4.7 && < 4.10 + , exceptions >= 0.8 && < 0.9 + , transformers >= 0.2 && < 0.6 + default-language: Haskell2010 + +test-suite safe-exceptions-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: Control.Exception.SafeSpec + build-depends: base + , hspec + , safe-exceptions + , void + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/fpco/safe-exceptions diff --git a/src/Control/Exception/Safe.hs b/src/Control/Exception/Safe.hs new file mode 100644 --- /dev/null +++ b/src/Control/Exception/Safe.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Please see the README.md file in the safe-exceptions repo for +-- information on how to use this module. Relevant links: +-- +-- * https://github.com/fpco/safe-exceptions#readme +-- +-- * https://www.stackage.org/package/safe-exceptions +module Control.Exception.Safe + ( -- * Throwing + throw + , throwIO + , throwM + , throwTo + , impureThrow + -- * Catching (with recovery) + , catch + , catchAny + , catchAsync + + , handle + , handleAny + , handleAsync + + , try + , tryAny + , tryAsync + + -- * Cleanup (no recovery) + , onException + , bracket + , bracket_ + , finally + , withException + , bracketOnError + , bracketOnError_ + + -- * Coercion to sync and async + , SyncExceptionWrapper (..) + , toSyncException + , AsyncExceptionWrapper (..) + , toAsyncException + + -- * Check exception type + , isSyncException + , isAsyncException + -- * Reexports + , C.MonadThrow + , C.MonadCatch + , C.MonadMask (..) + , C.mask_ + , C.uninterruptibleMask_ + , C.catchIOError + , C.handleIOError + -- FIXME , C.tryIOError + , C.Handler (..) + , Exception (..) + , SomeException (..) + , SomeAsyncException (..) + , E.IOException + ) where + +import Control.Concurrent (ThreadId) +import Control.Exception (Exception (..), SomeException (..), SomeAsyncException (..)) +import qualified Control.Exception as E +import qualified Control.Monad.Catch as C +import Control.Monad (liftM) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Typeable (Typeable, cast) + +-- | Synchronously throw the given exception +-- +-- @since 0.1.0.0 +throw :: (C.MonadThrow m, Exception e) => e -> m a +throw = C.throwM . toSyncException + +-- | Synonym for 'throw' +-- +-- @since 0.1.0.0 +throwIO :: (C.MonadThrow m, Exception e) => e -> m a +throwIO = throw + +-- | Synonym for 'throw' +-- +-- @since 0.1.0.0 +throwM :: (C.MonadThrow m, Exception e) => e -> m a +throwM = throw + +-- | Throw an asynchronous exception to another thread +-- +-- It's usually a better idea to use the async package, see +-- +-- +-- @since 0.1.0.0 +throwTo :: (Exception e, MonadIO m) => ThreadId -> e -> m () +throwTo tid = liftIO . E.throwTo tid . toAsyncException + +-- | Generate a pure value which, when forced, will synchronously +-- throw the given exception +-- +-- Generally it's better to avoid using this function and instead use 'throw', +-- see +-- +-- @since 0.1.0.0 +impureThrow :: Exception e => e -> a +impureThrow = E.throw + +-- | Flipped version of 'catch' +-- +-- @since 0.1.0.0 +catch :: (C.MonadCatch m, Exception e) => m a -> (e -> m a) -> m a +catch f g = f `C.catch` \e -> + if isSyncException e + then g e + -- intentionally rethrowing an async exception synchronously, + -- since we want to preserve async behavior + else C.throwM e + +-- | 'catch' specialized to catch all synchronous exception +-- +-- @since 0.1.0.0 +catchAny :: C.MonadCatch m => m a -> (SomeException -> m a) -> m a +catchAny = catch + +-- | 'catch' without async exception safety +-- +-- Generally it's better to avoid using this function since we do not want to +-- recover from async exceptions, see +-- +-- +-- @since 0.1.0.0 +catchAsync :: (C.MonadCatch m, Exception e) => m a -> (e -> m a) -> m a +catchAsync = C.catch + +-- | Flipped version of 'catch' +-- +-- @since 0.1.0.0 +handle :: (C.MonadCatch m, Exception e) => (e -> m a) -> m a -> m a +handle = flip catch + +-- | Flipped version of 'catchAny' +-- +-- @since 0.1.0.0 +handleAny :: C.MonadCatch m => (SomeException -> m a) -> m a -> m a +handleAny = flip catchAny + +-- | Flipped version of 'catchAsync' +-- +-- Generally it's better to avoid using this function since we do not want to +-- recover from async exceptions, see +-- +-- +-- @since 0.1.0.0 +handleAsync :: (C.MonadCatch m, Exception e) => (e -> m a) -> m a -> m a +handleAsync = C.handle + +-- | Same as upstream 'C.try', but will not catch asynchronous +-- exceptions +-- +-- @since 0.1.0.0 +try :: (C.MonadCatch m, E.Exception e) => m a -> m (Either e a) +try f = catch (liftM Right f) (return . Left) + +-- | 'try' specialized to catch all synchronous exceptions +-- +-- @since 0.1.0.0 +tryAny :: C.MonadCatch m => m a -> m (Either SomeException a) +tryAny = try + +-- | 'try' without async exception safety +-- +-- Generally it's better to avoid using this function since we do not want to +-- recover from async exceptions, see +-- +-- +-- @since 0.1.0.0 +tryAsync :: (C.MonadCatch m, E.Exception e) => m a -> m (Either e a) +tryAsync = C.try + +-- | Async safe version of 'E.onException' +-- +-- @since 0.1.0.0 +onException :: C.MonadMask m => m a -> m b -> m a +onException thing after = withException thing (\(_ :: SomeException) -> after) + +-- | Like 'onException', but provides the handler the thrown +-- exception. +-- +-- @since 0.1.0.0 +withException :: (C.MonadMask m, E.Exception e) => m a -> (e -> m b) -> m a +withException thing after = C.uninterruptibleMask $ \restore -> do + res1 <- C.try $ restore thing + case res1 of + Left e1 -> do + -- see explanation in bracket + _ :: Either SomeException b <- C.try $ after e1 + C.throwM e1 + Right x -> return x + +-- | Async safe version of 'E.bracket' +-- +-- @since 0.1.0.0 +bracket :: forall m a b c. C.MonadMask m + => m a -> (a -> m b) -> (a -> m c) -> m c +bracket before after thing = C.mask $ \restore -> do + x <- before + res1 <- C.try $ restore (thing x) + case res1 of + Left (e1 :: SomeException) -> do + -- explicitly ignore exceptions from after. We know that + -- no async exceptions were thrown there, so therefore + -- the stronger exception must come from thing + -- + -- https://github.com/fpco/safe-exceptions/issues/2 + _ :: Either SomeException b <- + C.try $ C.uninterruptibleMask_ $ after x + C.throwM e1 + Right y -> do + C.uninterruptibleMask_ $ after x + return y + +-- | Async safe version of 'E.bracket_' +-- +-- @since 0.1.0.0 +bracket_ :: C.MonadMask m => m a -> m b -> m c -> m c +bracket_ before after thing = bracket before (const after) (const thing) + +-- | Async safe version of 'E.finally' +-- +-- @since 0.1.0.0 +finally :: C.MonadMask m => m a -> m b -> m a +finally thing after = C.uninterruptibleMask $ \restore -> do + res1 <- C.try $ restore thing + case res1 of + Left (e1 :: SomeException) -> do + -- see bracket for explanation + _ :: Either SomeException b <- C.try after + C.throwM e1 + Right x -> do + after + return x + +-- | Async safe version of 'E.bracketOnError' +-- +-- @since 0.1.0.0 +bracketOnError :: forall m a b c. C.MonadMask m + => m a -> (a -> m b) -> (a -> m c) -> m c +bracketOnError before after thing = C.mask $ \restore -> do + x <- before + res1 <- C.try $ restore (thing x) + case res1 of + Left (e1 :: SomeException) -> do + -- ignore the exception, see bracket for explanation + _ :: Either SomeException b <- + C.try $ C.uninterruptibleMask_ $ after x + C.throwM e1 + Right y -> return y + +-- | Async safe version of 'E.bracketOnError_' +-- +-- @since 0.1.0.0 +bracketOnError_ :: C.MonadMask m => m a -> m b -> m c -> m c +bracketOnError_ before after thing = bracketOnError before (const after) (const thing) + +-- | Wrap up an asynchronous exception to be treated as a synchronous +-- exception +-- +-- This is intended to be created via 'toSyncException' +-- +-- @since 0.1.0.0 +data SyncExceptionWrapper = forall e. Exception e => SyncExceptionWrapper e + deriving Typeable +instance Show SyncExceptionWrapper where + show (SyncExceptionWrapper e) = show e +instance Exception SyncExceptionWrapper where +#if MIN_VERSION_base(4,8,0) + displayException (SyncExceptionWrapper e) = displayException e +#endif + +-- | Convert an exception into a synchronous exception +-- +-- For synchronous exceptions, this is the same as 'toException'. +-- For asynchronous exceptions, this will wrap up the exception with +-- 'SyncExceptionWrapper' +-- +-- @since 0.1.0.0 +toSyncException :: Exception e => e -> SomeException +toSyncException e = + case fromException se of + Just (SomeAsyncException _) -> toException (SyncExceptionWrapper e) + Nothing -> se + where + se = toException e + +-- | Wrap up a synchronous exception to be treated as an asynchronous +-- exception +-- +-- This is intended to be created via 'toAsyncException' +-- +-- @since 0.1.0.0 +data AsyncExceptionWrapper = forall e. Exception e => AsyncExceptionWrapper e + deriving Typeable +instance Show AsyncExceptionWrapper where + show (AsyncExceptionWrapper e) = show e +instance Exception AsyncExceptionWrapper where + toException = toException . SomeAsyncException + fromException se = do + SomeAsyncException e <- fromException se + cast e +#if MIN_VERSION_base(4,8,0) + displayException (AsyncExceptionWrapper e) = displayException e +#endif + +-- | Convert an exception into an asynchronous exception +-- +-- For asynchronous exceptions, this is the same as 'toException'. +-- For synchronous exceptions, this will wrap up the exception with +-- 'AsyncExceptionWrapper' +-- +-- @since 0.1.0.0 +toAsyncException :: Exception e => e -> SomeException +toAsyncException e = + case fromException se of + Just (SomeAsyncException _) -> se + Nothing -> toException (AsyncExceptionWrapper e) + where + se = toException e + +-- | Check if the given exception is synchronous +-- +-- @since 0.1.0.0 +isSyncException :: Exception e => e -> Bool +isSyncException e = + case fromException (toException e) of + Just (SomeAsyncException _) -> False + Nothing -> True + +-- | Check if the given exception is asynchronous +-- +-- @since 0.1.0.0 +isAsyncException :: Exception e => e -> Bool +isAsyncException = not . isSyncException +{-# INLINE isAsyncException #-} diff --git a/test/Control/Exception/SafeSpec.hs b/test/Control/Exception/SafeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Control/Exception/SafeSpec.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Control.Exception.SafeSpec (spec) where + +import Control.Concurrent (threadDelay, newEmptyMVar, forkIOWithUnmask, takeMVar, putMVar) +import Control.Exception (assert, ArithException (..), AsyncException (..), BlockedIndefinitelyOnMVar (..), BlockedIndefinitelyOnSTM (..)) +import qualified Control.Exception as E +import Control.Exception.Safe +import Control.Monad (forever) +import Data.Void (Void, absurd) +import System.IO.Unsafe (unsafePerformIO) +import System.Timeout (timeout) +import Test.Hspec + +-- | Ugly hack needed because the underlying type is not exported +timeoutException :: SomeException +timeoutException = + case unsafePerformIO $ mask $ \restore -> timeout 1 $ tryAsync $ restore $ forever $ threadDelay maxBound of + Nothing -> error "timeoutException returned Nothing" + Just (Left e) -> e + Just (Right e) -> absurd e + +asyncE :: IO a +asyncE = E.throwIO ThreadKilled + +syncE :: IO a +syncE = E.throwIO Overflow + +-- | Maps each exception to whether it is synchronous +exceptions :: [(SomeException, Bool)] +exceptions = + [ go Overflow True + , go ThreadKilled False + , go timeoutException False + , go BlockedIndefinitelyOnMVar True -- see the README, this is weird + , go BlockedIndefinitelyOnSTM True -- see the README, this is weird + ] + where + go e b = (toException e, b) + +withAll :: (SomeException -> Bool -> IO ()) -> Spec +withAll f = mapM_ (\(e, b) -> it (show e) (f e b)) exceptions + +spec :: Spec +spec = do + describe "isSyncException" $ withAll + $ \e sync -> isSyncException e `shouldBe` sync + describe "isAsncException" $ withAll + $ \e sync -> isAsyncException e `shouldBe` not sync + describe "toSyncException" $ withAll + $ \e _ -> isSyncException (toSyncException e) `shouldBe` True + describe "toAsyncException" $ withAll + $ \e _ -> isAsyncException (toAsyncException e) `shouldBe` True + + let shouldBeSync :: Either SomeException Void -> IO () + shouldBeSync (Left e) + | isSyncException e = return () + | otherwise = error $ "Unexpected async exception: " ++ show e + shouldBeSync (Right x) = absurd x + + shouldBeAsync :: Either SomeException Void -> IO () + shouldBeAsync (Left e) + | isAsyncException e = return () + | otherwise = error $ "Unexpected sync exception: " ++ show e + shouldBeAsync (Right x) = absurd x + + shouldThrowSync f = E.try f >>= shouldBeSync + shouldThrowAsync f = E.try f >>= shouldBeAsync + + describe "throw" $ withAll $ \e _ -> shouldThrowSync (throw e) + describe "throwTo" $ withAll $ \e _ -> do + var <- newEmptyMVar + tid <- E.uninterruptibleMask_ $ forkIOWithUnmask $ \restore -> do + res <- E.try $ restore $ forever $ threadDelay maxBound + putMVar var res + throwTo tid e + res <- takeMVar var + shouldBeAsync res + + describe "stays async" $ do + let withPairs f = do + it "sync/sync" $ shouldThrowSync $ f syncE syncE + + -- removing this case from consideration, since cleanup handlers + -- cannot receive async exceptions. See + -- https://github.com/fpco/safe-exceptions/issues/2 + -- + -- it "sync/async" $ shouldThrowAsync $ f syncE asyncE + + it "async/sync" $ shouldThrowAsync $ f asyncE syncE + it "async/async" $ shouldThrowAsync $ f asyncE asyncE + describe "onException" $ withPairs $ \e1 e2 -> e1 `onException` e2 + describe "withException" $ withPairs $ \e1 e2 -> e1 `withException` (\(_ :: SomeException) -> e2) + describe "bracket_" $ withPairs $ \e1 e2 -> bracket_ (return ()) e2 e1 + describe "finally" $ withPairs $ \e1 e2 -> e1 `finally` e2 + describe "bracketOnError_" $ withPairs $ \e1 e2 -> bracketOnError_ (return ()) e2 e1 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}