Safely Wrapping Exception in Haskell

WrappedException.hs

{-# 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)