enclosed-exceptions-1.0.3/src/0000755000000000000000000000000012732442753014454 5ustar0000000000000000enclosed-exceptions-1.0.3/src/Control/0000755000000000000000000000000012732442753016074 5ustar0000000000000000enclosed-exceptions-1.0.3/src/Control/Exception/0000755000000000000000000000000013321157214020020 5ustar0000000000000000enclosed-exceptions-1.0.3/test/0000755000000000000000000000000013321311533014626 5ustar0000000000000000enclosed-exceptions-1.0.3/src/Control/Exception/Enclosed.hs0000644000000000000000000001636313321157214022121 0ustar0000000000000000{-# 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 , catchDeep , catchAnyDeep , handleAnyDeep , tryDeep , tryAnyDeep , catchIO , handleIO , tryIO -- ** Force types -- | Helper functions for situations where type inferer gets confused. , asIOException , asSomeException ) where import Prelude import Control.Concurrent (forkIOWithUnmask) import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar) import Control.Exception import Control.Monad (liftM) import Control.Monad.Base (liftBase) import Control.Monad.Trans.Control (MonadBaseControl, liftBaseWith, restoreM) import Control.DeepSeq (NFData, ($!!)) import qualified Control.Exception.Lifted -- | 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 -> tryAnyIO (runInIO m)) >>= either (return . Left) (liftM Right . restoreM) where tryAnyIO :: IO a -> IO (Either SomeException a) tryAnyIO action = do result <- newEmptyMVar bracket (forkIOWithUnmask (\restore -> try (restore action) >>= putMVar result)) (\t -> throwTo t ThreadKilled) (\_ -> retryCount 10 (readMVar result)) -- If the action supplied by the user ends up blocking on an MVar -- or STM action, all threads currently blocked on such an action will -- receive an exception. In general, this is a good thing from the GHC -- RTS, but it is counter-productive for our purposes, where we know that -- when the user action receives such an exception, our code above will -- unblock and our main thread will not deadlock. -- -- Workaround: we retry the readMVar action if we received a -- BlockedIndefinitelyOnMVar. To remain on the safe side and avoid -- deadlock, we cap this at an arbitrary number (10) above so that, if -- there's a bug in this function, the runtime system can still recover. -- -- For previous discussion of this topic, see: -- https://github.com/simonmar/async/pull/15 retryCount :: Int -> IO a -> IO a retryCount cnt0 action = loop cnt0 where loop 0 = action loop cnt = action `Control.Exception.catch` \BlockedIndefinitelyOnMVar -> loop (cnt - 1) -- | An extension to @catch@ which ensures that the return value is fully -- evaluated. See @tryAny@. -- -- Since 1.0.1 catchDeep :: (Exception e, NFData a, MonadBaseControl IO m) => m a -> (e -> m a) -> m a catchDeep action onE = tryDeep action >>= either onE return -- | 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 @try@ 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 1.0.1 tryDeep :: (Exception e, NFData a, MonadBaseControl IO m) => m a -> m (Either e a) tryDeep m = Control.Exception.Lifted.try $ do x <- m liftBase $ evaluate $!! x -- | 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 liftBase $ evaluate $!! 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 = Control.Exception.Lifted.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 = Control.Exception.Lifted.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 = Control.Exception.Lifted.try -- | -- -- Since 0.5.6 asSomeException :: SomeException -> SomeException asSomeException = id -- | -- -- Since 0.5.6 asIOException :: IOException -> IOException asIOException = id enclosed-exceptions-1.0.3/test/main.hs0000644000000000000000000002172113321311533016111 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} import Test.Hspec import Test.QuickCheck.Arbitrary () import Control.Exception.Lifted hiding (throwTo) import Prelude hiding (catch) import Data.IORef import Data.Typeable import Control.Concurrent (threadDelay) import Control.Concurrent.Async (async, cancelWith, waitCatch) import Control.Concurrent.MVar import Control.Concurrent.STM import Control.Exception.Enclosed import Control.Monad (forever) {-# ANN main ("HLint: ignore Redundant do"::String) #-} main :: IO () main = hspec $ do context "Unhandled.Exception" $ do -- const :: Catcher describe "const" $ do it "doesn't catch exceptions thrown from the inside" $ do const `catcherCatchesInside` False it "doesn't catch exceptions thrown from the outside" $ do const `catcherCatchesOutside` False it "doesn't catch exceptions lazily thrown in its pure result" $ do const `catcherCatchesDeep` False -- fmap Right :: Trier describe "fmap Right" $ do it "doesn't catch exceptions thrown from the inside" $ do fmap Right `trierCatchesInside` False it "doesn't catch exceptions thrown from the outside" $ do fmap Right `trierCatchesOutside` False it "doesn't catch exceptions lazily thrown in its pure result" $ do fmap Right `trierCatchesDeep` False context "Control.Exception" $ do describe "catch" $ do it "catches exceptions thrown from the inside" $ do catch `catcherCatchesInside` True it "catches exceptions thrown from the outside" $ do catch `catcherCatchesOutside` True it "doesn't catch exceptions lazily thrown in its pure result" $ do catch `catcherCatchesDeep` False describe "try" $ do it "catches exceptions thrown from the inside" $ do try `trierCatchesInside` True it "catches exceptions thrown from the outside" $ do try `trierCatchesOutside` True it "doesn't catch exceptions lazily thrown in its pure result" $ do try `trierCatchesDeep` False context "Control.Exception.Enclosed" $ do describe "catchAny" $ do it "catches exceptions thrown from the inside" $ do catchAny `catcherCatchesInside` True it "doesn't catch exceptions thrown from the outside" $ do catchAny `catcherCatchesOutside` False it "doesn't catch exceptions lazily thrown in its pure result" $ do catchAny `catcherCatchesDeep` False describe "catchDeep" $ do it "catches exceptions thrown from the inside" $ do catchDeep `catcherCatchesInside` True it "catches exceptions thrown from the outside" $ do catchDeep `catcherCatchesOutside` True it "catches exceptions lazily thrown in its pure result" $ do catchDeep `catcherCatchesDeep` True describe "tryAny" $ do it "catches exceptions thrown from the inside" $ do tryAny `trierCatchesInside` True it "doesn't catch exceptions thrown from the outside" $ do tryAny `trierCatchesOutside` False it "doesn't catch exceptions lazily thrown in its pure result" $ do tryAny `trierCatchesDeep` False #if !MIN_VERSION_async(2, 2, 0) let shouldBeShow :: Show a => a -> a -> IO () shouldBeShow x y = show x `shouldBe` show y it "isn't fooled by BlockedIndefinitelyOnMVar" $ do res <- tryAny $ do var <- newEmptyMVar takeMVar (var :: MVar ()) res `shouldBeShow` Left (toException BlockedIndefinitelyOnMVar) it "isn't fooled by BlockedIndefinitelyOnTVar" $ do res <- tryAny $ do var <- atomically newEmptyTMVar atomically $ takeTMVar (var :: TMVar ()) res `shouldBeShow` Left (toException BlockedIndefinitelyOnSTM) #endif describe "tryDeep" $ do it "catches exceptions thrown from the inside" $ do tryDeep `trierCatchesInside` True it "catches exceptions thrown from the outside" $ do tryDeep `trierCatchesOutside` True it "catches exceptions lazily thrown in its pure result" $ do tryDeep `trierCatchesDeep` True describe "tryAnyDeep" $ do it "catches exceptions thrown from the inside" $ do tryAnyDeep `trierCatchesInside` True it "doesn't catch exceptions thrown from the outside" $ do tryAnyDeep `trierCatchesOutside` False it "catches exceptions lazily thrown in its pure result" $ do tryAnyDeep `trierCatchesDeep` True type Catcher = IO () -> (SomeException -> IO ()) -> IO () type Trier = IO () -> IO (Either SomeException ()) -- Dummy exception types used just for testing. data DummyException = DummyException deriving (Show, Typeable) instance Exception DummyException -- A handler that fails the test if it catches the wrong type of exception. catchAssert :: forall e. Exception e => e -> IO () -> SomeException -> IO () catchAssert _ act se = case fromException se of Just (_ :: e) -> act Nothing -> expectationFailure "Caught an unexpected exception" -- Block a thread blockIndefinitely :: IO () blockIndefinitely = forever $ threadDelay maxBound -- Test whether a catcher will catch exceptions thrown from the inside. catcherCatchesInside :: Catcher -> Bool -> IO () catcherCatchesInside fCatch asExpected = do caughtRef <- newIORef False thread <- async $ do fCatch (throwIO DummyException) (catchAssert DummyException $ writeIORef caughtRef True) -- No known catchers will catch an exception without also handling it. readIORef caughtRef `shouldReturn` True _ <- waitCatch thread readIORef caughtRef `shouldReturn` asExpected -- Test whether a catcher will catch exceptions thrown from the outside. catcherCatchesOutside :: Catcher -> Bool -> IO () catcherCatchesOutside fCatch asExpected = do caughtRef <- newIORef False baton <- newEmptyMVar thread <- async $ do fCatch (do putMVar baton () -- DummyException can happen from here on blockIndefinitely) (catchAssert DummyException $ writeIORef caughtRef True) -- No known catchers will catch an exception without also handling it. readIORef caughtRef `shouldReturn` True takeMVar baton cancelWith thread DummyException _ <- waitCatch thread readIORef caughtRef `shouldReturn` asExpected -- Test whether a catcher will catch exceptions lazily thrown in a pure result. -- This is done by `return (throw DummyException)`, which will not -- raise the exception until the return value is forced. catcherCatchesDeep :: Catcher -> Bool -> IO () catcherCatchesDeep fCatch asExpected = do caughtRef <- newIORef False thread <- async $ do fCatch (return (throw DummyException)) (catchAssert DummyException $ writeIORef caughtRef True) _ <- waitCatch thread readIORef caughtRef `shouldReturn` asExpected -- Test whether a trier will catch exceptions thrown from the inside. trierCatchesInside :: Trier -> Bool -> IO () trierCatchesInside fTry asExpected = do caughtRef <- newIORef False thread <- async $ do _ <- fTry (throwIO DummyException) writeIORef caughtRef True _ <- waitCatch thread readIORef caughtRef `shouldReturn` asExpected -- Test whether a trier will catch exceptions thrown from the outside. trierCatchesOutside :: Trier -> Bool -> IO () trierCatchesOutside fTry asExpected = do caughtRef <- newIORef False baton <- newEmptyMVar thread <- async $ do _ <- fTry $ do putMVar baton () -- DummyException can happen from here on blockIndefinitely writeIORef caughtRef True takeMVar baton cancelWith thread DummyException _ <- waitCatch thread readIORef caughtRef `shouldReturn` asExpected -- Test whether a trier will catch exceptions lazily thrown in a pure result. -- This is done by `return (throw DummyException)`, which will not -- raise the exception until the return value is forced. trierCatchesDeep :: Trier -> Bool -> IO () trierCatchesDeep fTry asExpected = do eres <- fTry $ return $ throw DummyException let caughtDummyException = case eres of Left e | Just DummyException <- fromException e -> True | otherwise -> error "Caught an unexpected exception" Right _ -> False caughtDummyException `shouldBe` asExpected enclosed-exceptions-1.0.3/LICENSE0000644000000000000000000000207512732442753014676 0ustar0000000000000000Copyright (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. enclosed-exceptions-1.0.3/Setup.hs0000644000000000000000000000005612732442753015322 0ustar0000000000000000import Distribution.Simple main = defaultMain enclosed-exceptions-1.0.3/enclosed-exceptions.cabal0000644000000000000000000000356713321311533020621 0ustar0000000000000000name: enclosed-exceptions version: 1.0.3 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. For more information on the technique, please see: 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 extra-source-files: README.md ChangeLog.md library exposed-modules: Control.Exception.Enclosed hs-source-dirs: src build-depends: base >= 4.6 && < 5 , transformers , lifted-base >= 0.2 , monad-control , deepseq , transformers-base 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 , stm , transformers , transformers-base ghc-options: -Wall source-repository head type: git location: git://github.com/jcristovao/enclosed-exceptions.git enclosed-exceptions-1.0.3/README.md0000644000000000000000000000244312732442753015147 0ustar0000000000000000enclosed-exceptions =================== 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](http://www.snoyman.com/) for the [ClassyPrelude](http://hackage.haskell.org/package/classy-prelude) library, and was latter spun-off into a separate independent package. For a more detailed explanation of the motivation behind this functions, see: [Catching all exceptions](https://www.fpcomplete.com/user/snoyberg/general-haskell/exceptions/catching-all-exceptions) and [the discussion in haskell-cafe](https://groups.google.com/forum/#!topic/haskell-cafe/e9H2I-3uVJE) enclosed-exceptions-1.0.3/ChangeLog.md0000644000000000000000000000053513321311533016023 0ustar0000000000000000# ChangeLog for enclosed-exceptions ## 1.0.3 * Skip some tests on GHC 8.4 [#12](https://github.com/jcristovao/enclosed-exceptions/issues/12) ## 1.0.2.1 * Support for GHC 7.4 and earlier ## 1.0.2 * Use MVar in tryAny, drop async dependency [#9](https://github.com/jcristovao/enclosed-exceptions/pull/9) ## 1.0.1 * Added tryDeep and catchDeep