Safer re-throw semantics for fork (and tests)

Ignoring ThreadKilled was a good idea, but we should not throw async'ly anything that is not a member of SomeAsyncException. It will not play well with code that likes to catch all sync exception types. Wrap all sync exceptions in an async wrapper before throwing async'ly (since all async exceptions are PseudoException, this will continue to prevent fromIO from catching it as well). The only special case is ExitCode. This is still somewhat dangerous (some over-eager exception-catching mechanisms will catch this when thrown to the parent async'ly, and likely do the wrong thing) but the trade-off seems worth it since when you have an ExitCode you really want it to reach the top and exit the process with that code, not crash the process with an async exception wrapper.
singpolyma · May 20, 2018 · 7c5c6b7 · 7c5c6b7
1 parent bddede0
commit 7c5c6b7
Show file tree

Hide file tree

Showing 2 changed files with 81 additions and 9 deletions.
diff --git a/UnexceptionalIO.hs b/UnexceptionalIO.hs
@@ -30,9  30,10 @@ module UnexceptionalIO (
 	ExternalError(..),
 	-- * Pseudo exception helpers
 	bracket,
-#if MIN_VERSION_base(4,6,0)
 #if MIN_VERSION_base(4,7,0)
 	forkFinally,
-	fork
 	fork,
 	ChildThreadError(..)
 #endif
 #endif
 ) where
@@ -232,8  233,9 @@ fromIO' :: (Ex.Exception e, Unexceptional m) =>
 	-> IO a
 	-> m (Either e a)
 fromIO' f = (return . either (\e -> Left $ fromMaybe (f e) $ castException e) Right) <=< fromIO
-	where
-	castException = Ex.fromException . Ex.toException
 
 castException :: (Ex.Exception e1, Ex.Exception e2) => e1 -> Maybe e2
 castException = Ex.fromException . Ex.toException
 #endif
 
 -- | Re-embed 'UIO' into 'IO'
@@ -259,7  261,7 @@ bracket :: (Unexceptional m) => UIO a -> (a -> UIO ()) -> (a -> UIO c) -> m c
 bracket acquire release body =
 	unsafeFromIO $ Ex.bracket (run acquire) (run . release) (run . body)
 
-#if MIN_VERSION_base(4,6,0)
 #if MIN_VERSION_base(4,7,0)
 -- | Mirrors 'Concurrent.forkFinally', but since the body is 'UIO',
 --   the thread must terminate successfully or because of 'PseudoException'
 forkFinally :: (Unexceptional m) => UIO a -> (Either PseudoException a -> UIO ()) -> m Concurrent.ThreadId
@@ -270,15  272,38 @@ forkFinally body handler = unsafeFromIO $ Concurrent.forkFinally (run body) $ \r
 			Nothing -> error $ "Bug in UnexceptionalIO: forkFinally caught a non-PseudoException: "    show e
 		Right x -> run $ handler $ Right x
 
--- | Mirrors 'Concurrent.forkIO', but re-throws any 'PseudoException'
---   to the parent thread
 -- | Mirrors 'Concurrent.forkIO', but re-throws errors to the parent thread
 --
 -- * Ignores manual thread kills, since those are on purpose.
 -- * Re-throws async exceptions ('SomeAsyncException') as is.
 -- * Re-throws 'ExitCode' as is in an attempt to exit with the requested code.
 -- * Wraps synchronous 'PseudoException' in async 'ChildThreadError'.
 fork :: (Unexceptional m) => UIO () -> m Concurrent.ThreadId
 fork body = do
 	parent <- unsafeFromIO Concurrent.myThreadId
 	forkFinally body $ either (handler parent) (const $ return ())
 	where
 	handler parent e
-		| Just Ex.ThreadKilled <- Ex.fromException (Ex.toException e) = return ()
-		| otherwise = unsafeFromIO $ Concurrent.throwTo parent e
 		-- Thread manually killed. I assume on purpose
 		| Just Ex.ThreadKilled <- castException e = return ()
 		-- Async exception, nothing to do with this thread, propogate directly
 		| Just (Ex.SomeAsyncException _) <- castException e =
 			unsafeFromIO $ Concurrent.throwTo parent e
 		-- Attempt to manually end the process,
 		-- not an async exception, so a bit dangerous to throw async'ly, but
 		-- you really do want this to reach the top as-is for the exit code to
 		-- work.
 		| Just e <- castException e =
 			unsafeFromIO $ Concurrent.throwTo parent (e :: ExitCode)
 		-- Non-async PseudoException, so wrap in an async wrapper before
 		-- throwing async'ly
 		| otherwise = unsafeFromIO $ Concurrent.throwTo parent (ChildThreadError e)
 
 -- | Async signal that a child thread ended due to non-async PseudoException
 newtype ChildThreadError = ChildThreadError PseudoException deriving (Show, Typeable)
 
 instance Ex.Exception ChildThreadError where
 	toException = Ex.asyncExceptionToException
 	fromException = Ex.asyncExceptionFromException
 #endif
 #endif
diff --git a/tests/suite.hs b/tests/suite.hs
@@ -7,6  7,7 @@ import Data.Typeable (Typeable)
 import Control.Monad
 import System.Exit
 import qualified Control.Exception as Ex
 import qualified Control.Concurrent as Concurrent
 
 import qualified UnexceptionalIO as UIO
 
@@ -37,9  38,55 @@ fromIOPasses io = do
 		(\x -> assertFailure $ "fromIO caught: "    show x)
 		caught
 
 #if MIN_VERSION_base(4,7,0)
 threadReturns :: UIO.UIO () -> (Either Ex.SomeException () -> Assertion) -> Assertion
 threadReturns spawn assertion = do
 	mvar <- Concurrent.newEmptyMVar
 	Concurrent.forkFinally (UIO.run spawn >> Concurrent.yield) (Concurrent.putMVar mvar)
 	result <- Concurrent.takeMVar mvar
 	assertion result
 
 assertRightUnit :: (Show e) => Either e () -> Assertion
 assertRightUnit (Left e) = assertFailure $ "Expected Right () got Left "    show e
 assertRightUnit (Right ()) = return ()
 
 assertLeft :: (e -> Assertion) -> Either e () -> Assertion
 assertLeft _ (Right ()) = assertFailure "Expected Left ... got Right ()"
 assertLeft assertion (Left e) = assertion e
 
 assertChildThreadError :: Ex.SomeException -> Assertion
 assertChildThreadError e = case Ex.fromException e of
 	Just (UIO.ChildThreadError _) -> return ()
 	Nothing -> assertFailure $ "Expected ChildThreadError got "    show e
 #endif
 
 tests :: [Test]
 tests =
 	[
 #if MIN_VERSION_base(4,7,0)
 		testGroup "fork" [
 			testCase "ignores success" (threadReturns
 				(void $ UIO.fork $ return ())
 				assertRightUnit
 			),
 			testCase "ignores threadKilled" (threadReturns
 				(UIO.fork (forever $ UIO.unsafeFromIO Concurrent.yield) >>= UIO.unsafeFromIO . Concurrent.killThread)
 				assertRightUnit
 			),
 			testCase "re-throws SomeAsyncException" (threadReturns
 				(void $ UIO.fork (UIO.unsafeFromIO $ Ex.throwIO Ex.UserInterrupt))
 				(assertLeft ((@?= Just Ex.UserInterrupt) . Ex.fromException))
 			),
 			testCase "re-throws ExitCode" (threadReturns
 				(void $ UIO.fork (UIO.unsafeFromIO exitSuccess))
 				(assertLeft ((@?= Just ExitSuccess) . Ex.fromException))
 			),
 			testCase "wraps sync PseudoException in ChildThreadError" (threadReturns
 				(void $ UIO.fork (error "blah"))
 				(assertLeft assertChildThreadError)
 			)
 		],
 #endif
 		testGroup "fromIO catches runtime errors" [
 			testCase "fail" (fromIOCatches $ fail "boo"),
 			testCase "userError" (fromIOCatches $ Ex.throwIO $ userError "boo"),