Skip to content

Instantly share code, notes, and snippets.

@larskuhtz
Last active October 16, 2018 20:53
Show Gist options
  • Save larskuhtz/bc426fb901e5aba37449c7366886b789 to your computer and use it in GitHub Desktop.
Save larskuhtz/bc426fb901e5aba37449c7366886b789 to your computer and use it in GitHub Desktop.
Safely Wrapping Exception in Haskell
{-# LANGUAGE ScopedTypeVariables #-}
module WrappedException
( main
) where
import Control.Concurrent
import Control.Exception (SomeAsyncException(..))
import Control.Monad.Catch
import Data.IORef
import qualified UnliftIO.Exception as UIO
-- -------------------------------------------------------------------------- --
-- Buggy
newtype BuggyWrappedException e = BuggyWrappedException e
deriving (Show)
instance (Exception e) => Exception (BuggyWrappedException e)
buggyCatchAndRethrow :: MonadCatch m => m a -> m a
buggyCatchAndRethrow a = a `catch` \(e :: SomeException) ->
throwM $ BuggyWrappedException e
-- -------------------------------------------------------------------------- --
-- Fix by correctly wrapping
newtype WrappedException e = WrappedException e
deriving (Show)
instance (Exception e) => Exception (WrappedException e) where
toException e@(WrappedException inner) =
case fromException (toException inner) of
Just SomeAsyncException{} -> toException (SomeAsyncException e)
Nothing -> SomeException e
catchAndRethrow :: MonadCatch m => m a -> m a
catchAndRethrow a = a `catch` \(e :: SomeException) ->
throwM $ WrappedException e
-- -------------------------------------------------------------------------- --
-- Fix by only wrapping synchronous exceptions
newtype WrappedSynchronousException e = WrappedSynchronousException e
deriving (Show)
instance (Exception e) => Exception (WrappedSynchronousException e)
catchAndRethrowSynchronous :: MonadCatch m => m a -> m a
catchAndRethrowSynchronous a = a `catches`
[ Handler $ \(e :: SomeAsyncException) -> throwM e
, Handler $ \(e :: SomeException) -> throwM $ WrappedSynchronousException e
]
-- -------------------------------------------------------------------------- --
-- Tests
main :: IO ()
main = do
example
buggyExample
fixedExample
fixedExample2
runExample :: IO () -> IO ()
runExample action = do
ref <- newIORef True
-- catchAny is supposed to catch only synchronous exceptions
tid <- forkIO $ action `UIO.catchAny` \_ -> atomicWriteIORef ref False
yield
-- this raises a 'ThreadKilled' exception on the forked thread
killThread tid
yield
-- the result is False only of the asynchronous 'ThreadKilled' exception
-- got intercepted by `UI.catchAny`.
readIORef ref >>= print
example :: IO ()
example = runExample $ threadDelay 1000000
buggyExample :: IO ()
buggyExample = runExample $ buggyCatchAndRethrow (threadDelay 1000000)
fixedExample :: IO ()
fixedExample = runExample $ catchAndRethrow (threadDelay 1000000)
fixedExample2 :: IO ()
fixedExample2 = runExample $ catchAndRethrowSynchronous (threadDelay 1000000)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment