From da8a5bf9cf763ad76d07e4dc5ede0841c3f106bb Mon Sep 17 00:00:00 2001
From: Stephen Paul Weber <singpolyma@singpolyma.net>
Date: Sat, 6 Feb 2021 22:02:24 -0500
Subject: [PATCH] Import forkXMPP from jingle-xmpp

This is a much safer version that rethrows exceptions to the parent instead of
just printing them and terminating the thread.
---
 Main.hs |  5 -----
 Util.hs | 19 +++++++++++++++++++
 2 files changed, 19 insertions(+), 5 deletions(-)

diff --git a/Main.hs b/Main.hs
index 606bacd..eb7fcc9 100644
--- a/Main.hs
+++ b/Main.hs
@@ -127,11 +127,6 @@ getDirectInvitation m = do
 		) <*>
 		Just (attributeText (fromString "password") x)
 
-forkXMPP :: XMPP () -> XMPP ThreadId
-forkXMPP kid = do
-	session <- getSession
-	liftIO $ forkIO $ void $ runXMPP session kid
-
 nickFor db jid existingRoom
 	| fmap bareTxt existingRoom == Just bareFrom = return $ fromMaybe (fromString "nonick") resourceFrom
 	| Just tel <- mfilter isE164 (strNode <$> jidNode jid) = do
diff --git a/Util.hs b/Util.hs
index 8d5003d..6608476 100644
--- a/Util.hs
+++ b/Util.hs
@@ -2,6 +2,7 @@ module Util where
 
 import Prelude ()
 import BasicPrelude
+import Control.Concurrent
 import Control.Concurrent.STM (STM, atomically)
 import Data.Word (Word16)
 import Data.Bits (shiftL, (.|.))
@@ -16,6 +17,7 @@ import Data.Digest.Pure.SHA (sha1, bytestringDigest)
 import Data.Void (absurd)
 import UnexceptionalIO (Unexceptional)
 import qualified UnexceptionalIO       as UIO
+import qualified Control.Exception as Ex
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import qualified Network.Protocol.XMPP as XMPP
@@ -218,3 +220,20 @@ mkSMS from to txt = (XMPP.emptyMessage XMPP.MessageChat) {
 	XMPP.messageFrom = Just from,
 	XMPP.messagePayloads = [XML.Element (fromString "{jabber:component:accept}body") [] [XML.NodeContent $ XML.ContentText txt]]
 }
+
+castException :: (Ex.Exception e1, Ex.Exception e2) => e1 -> Maybe e2
+castException = Ex.fromException . Ex.toException
+
+-- Re-throws all by ThreadKilled async to parent thread
+-- Makes sync child exceptions async in parent, which is a bit sloppy
+forkXMPP :: XMPP.XMPP () -> XMPP.XMPP ThreadId
+forkXMPP kid = do
+	parent <- liftIO myThreadId
+	session <- XMPP.getSession
+	liftIO $ forkFinally
+		(void $ XMPP.runXMPP session kid)
+		(either (handler parent) (const $ return ()))
+	where
+	handler parent e
+		| Just Ex.ThreadKilled <- castException e = return ()
+		| otherwise = throwTo parent e
-- 
2.38.5