diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ + +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/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/enclosed-exceptions.cabal b/enclosed-exceptions.cabal new file mode 100644 --- /dev/null +++ b/enclosed-exceptions.cabal @@ -0,0 +1,42 @@ +name: enclosed-exceptions +version: 1.0.0 +synopsis: Catching all exceptions from within an enclosed computation +description: Catching all exceptions raised within an enclosed computation, + while remaining responsive to (external) asynchronous exceptions. +homepage: https://github.com/jcristovao/enclosed-exceptions +license: MIT +license-file: LICENSE +author: Michael Snoyman, João Cristóvão +maintainer: jmacristovao@gmail.com, michael@snoyman.com +category: Control +build-type: Simple +cabal-version: >=1.8 + +library + exposed-modules: Control.Exception.Enclosed + hs-source-dirs: src + build-depends: base >= 4 && < 5 + , transformers + , lifted-base >= 0.2 + , monad-control + , async >= 2.0 + , deepseq + ghc-options: -Wall -fno-warn-orphans + +test-suite test + hs-source-dirs: src, test + main-is: main.hs + type: exitcode-stdio-1.0 + build-depends: base + , lifted-base >= 0.2 + , monad-control + , async >= 2.0 + , deepseq + , hspec >= 1.3 + , QuickCheck + , transformers + ghc-options: -Wall + +source-repository head + type: git + location: git://github.com/jcristovao/enclosed-exceptions.git diff --git a/src/Control/Exception/Enclosed.hs b/src/Control/Exception/Enclosed.hs new file mode 100644 --- /dev/null +++ b/src/Control/Exception/Enclosed.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The purpose of this module is to allow you to capture all exceptions +-- originating from within the enclosed computation, while still reacting +-- to asynchronous exceptions aimed at the calling thread. +-- +-- This way, you can be sure that the function that calls, for example, +-- @'catchAny'@, will still respond to @'ThreadKilled'@ or @'Timeout'@ +-- events raised by another thread (with @'throwTo'@), while capturing +-- all exceptions, synchronous or asynchronous, resulting from the +-- execution of the enclosed computation. +-- +-- One particular use case is to allow the safe execution of code from various +-- libraries (which you do not control), capturing any faults that might +-- occur, while remaining responsive to higher level events and control +-- actions. +-- +-- This library was originally developed by Michael Snoyman for the +-- 'ClassyPrelude' library, and was latter 'spun-off' into a separate +-- independent package. +-- +-- For a more detailed explanation of the motivation behind this functions, +-- see: +-- +-- +-- +-- and +-- +-- +-- +module Control.Exception.Enclosed + ( -- ** Exceptions + catchAny + , handleAny + , tryAny + , catchAnyDeep + , handleAnyDeep + , tryAnyDeep + , catchIO + , handleIO + , tryIO + -- ** Force types + -- | Helper functions for situations where type inferer gets confused. + , asIOException + , asSomeException + ) where + +import Prelude +import Control.Exception.Lifted +import Control.Monad (liftM) +import Control.Monad.Trans.Control (MonadBaseControl, liftBaseWith, restoreM) +import Control.Concurrent.Async (withAsync, waitCatch) +import Control.DeepSeq (NFData, ($!!)) + +-- | A version of 'catch' which is specialized for any exception. This +-- simplifies usage as no explicit type signatures are necessary. +-- +-- Note that since version 0.5.9, this function now has proper support for +-- asynchronous exceptions, by only catching exceptions generated by the +-- internal (enclosed) action. +-- +-- Since 0.5.6 +catchAny :: MonadBaseControl IO m => m a -> (SomeException -> m a) -> m a +catchAny action onE = tryAny action >>= either onE return + +-- | A version of 'handle' which is specialized for any exception. This +-- simplifies usage as no explicit type signatures are necessary. +-- +-- Note that since version 0.5.9, this function now has proper support for +-- asynchronous exceptions, by only catching exceptions generated by the +-- internal (enclosed) action. +-- +-- Since 0.5.6 +handleAny :: MonadBaseControl IO m => (SomeException -> m a) -> m a -> m a +handleAny = flip catchAny + +-- | A version of 'try' which is specialized for any exception. +-- This simplifies usage as no explicit type signatures are necessary. +-- +-- Note that since version 0.5.9, this function now has proper support for +-- asynchronous exceptions, by only catching exceptions generated by the +-- internal (enclosed) action. +-- +-- Since 0.5.6 +tryAny :: MonadBaseControl IO m => m a -> m (Either SomeException a) +tryAny m = + liftBaseWith (\runInIO -> withAsync (runInIO m) waitCatch) >>= + either (return . Left) (liftM Right . restoreM) + +-- | An extension to @catchAny@ which ensures that the return value is fully +-- evaluated. See @tryAnyDeep@. +-- +-- Since 0.5.9 +catchAnyDeep :: (NFData a, MonadBaseControl IO m) => m a -> (SomeException -> m a) -> m a +catchAnyDeep action onE = tryAnyDeep action >>= either onE return + +-- | @flip catchAnyDeep@ +-- +-- Since 0.5.6 +handleAnyDeep :: (NFData a, MonadBaseControl IO m) => (SomeException -> m a) -> m a -> m a +handleAnyDeep = flip catchAnyDeep + +-- | An extension to @tryAny@ which ensures that the return value is fully +-- evaluated. In other words, if you get a @Right@ response here, you can be +-- confident that using it will not result in another exception. +-- +-- Since 0.5.9 +tryAnyDeep :: (NFData a, MonadBaseControl IO m) + => m a + -> m (Either SomeException a) +tryAnyDeep m = tryAny $ do + x <- m + return $!! x + +-- | A version of 'catch' which is specialized for IO exceptions. This +-- simplifies usage as no explicit type signatures are necessary. +-- +-- Since 0.5.6 +catchIO :: MonadBaseControl IO m => m a -> (IOException -> m a) -> m a +catchIO = catch + +-- | A version of 'handle' which is specialized for IO exceptions. This +-- simplifies usage as no explicit type signatures are necessary. +-- +-- Since 0.5.6 +handleIO :: MonadBaseControl IO m => (IOException -> m a) -> m a -> m a +handleIO = handle + +-- | A version of 'try' which is specialized for IO exceptions. +-- This simplifies usage as no explicit type signatures are necessary. +-- +-- Since 0.5.6 +tryIO :: MonadBaseControl IO m => m a -> m (Either IOException a) +tryIO = try + +-- | +-- +-- Since 0.5.6 +asSomeException :: SomeException -> SomeException +asSomeException = id + +-- | +-- +-- Since 0.5.6 +asIOException :: IOException -> IOException +asIOException = id + diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PatternGuards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +import Test.Hspec +import Test.QuickCheck.Arbitrary () +import Control.Exception.Lifted hiding (throwTo) +import Data.IORef +import Data.Typeable +import Control.Monad.IO.Class +import Control.Concurrent (throwTo, threadDelay, forkIO) +import Control.Exception.Enclosed + +{-# ANN main ("HLint: ignore Redundant do"::String) #-} +main :: IO () +main = hspec $ do + describe "any exceptions" $ do + it "catchAny" $ do + failed <- newIORef 0 + tid <- forkIO $ do + catchAny + (threadDelay 20000) + (const $ writeIORef failed 1) + writeIORef failed 2 + threadDelay 10000 + throwTo tid DummyException + threadDelay 50000 + didFail <- readIORef failed + liftIO $ didFail `shouldBe` (0 :: Int) + it "tryAny" $ do + failed <- newIORef False + tid <- forkIO $ do + _ <- tryAny $ threadDelay 20000 + writeIORef failed True + threadDelay 10000 + throwTo tid DummyException + threadDelay 50000 + didFail <- readIORef failed + liftIO $ didFail `shouldBe` False + it "tryAnyDeep" $ do + eres <- tryAnyDeep $ return $ throw DummyException + case eres of + Left e + | Just DummyException <- fromException e -> return () + | otherwise -> error "Expected a DummyException" + Right () -> error "Expected an exception" :: IO () + +data DummyException = DummyException + deriving (Show, Typeable) +instance Exception DummyException + +