~singpolyma/cheogram

f11b70aeeb6dcc78c3b4b3b70026b18c6904d0f7 — Stephen Paul Weber 15 days ago f26313c
Make forkXMPP safe

Copy the throw-to-parent patter from unexceptionalio.  The biggest improvement
is making sure that we throw syncronous exceptions inside an asyncronous wrapper
in the parent thread.  Otherwise normal error handling logic in the parent might
catch it as though it were thrown locally, resulting in both wrong and confusing behaviour.
1 files changed, 10 insertions(+), 1 deletions(-)

M Util.hs
M Util.hs => Util.hs +10 -1
@@ 4,6 4,7 @@ import Prelude ()
import BasicPrelude
import Control.Concurrent
import Control.Concurrent.STM (STM, atomically)
import System.Exit (ExitCode)
import GHC.Stack (HasCallStack)
import Data.Word (Word16)
import Data.Bits (shiftL, (.|.))


@@ 238,13 239,21 @@ forkXMPP kid = do
	where
	handler parent e
		| Just Ex.ThreadKilled <- castException e = return ()
		| otherwise = throwTo parent e
		| Just (Ex.SomeAsyncException _) <- castException e = throwTo parent e
		| Just e <- castException e = throwTo parent (e :: ExitCode)
		| otherwise = throwTo parent (ChildThreadError e)

forkFinallyXMPP :: XMPP.XMPP () -> (Either SomeException () -> IO ()) -> XMPP.XMPP ThreadId
forkFinallyXMPP kid handler = do
	session <- XMPP.getSession
	liftIO $ forkFinally (void $ XMPP.runXMPP session kid) handler

newtype ChildThreadError = ChildThreadError SomeException deriving (Show, Typeable)

instance Ex.Exception ChildThreadError where
	toException = Ex.asyncExceptionToException
	fromException = Ex.asyncExceptionFromException

mkElement :: XML.Name -> Text -> XML.Element
mkElement name txt = XML.Element name [] [XML.NodeContent $ XML.ContentText txt]