2 files changed, 22 insertions(+), 10 deletions(-)

M Main.hs
M Util.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


@@ 1977,10 1972,8 @@ main = do
 						}
 				)
 
-			forever $ do
-				log "" "runComponent STARTING"
+			log "" "runComponent STARTING"
 
-				(log "runComponent ENDED" <=< (runExceptT . syncIO)) $
-					runComponent (Server componentJid host (PortNumber port)) secret
-						(component db redis (void . UIO.fromIO . StatsD.push statsd) backendHost did adhocBotIQReceiver (writeTChan adhocBotMessages) toRoomPresences toRejoinManager toJoinPartDebouncer sendToComponent toStanzaProcessor processDirectMessageRouteConfig jingleHandler componentJid [registrationJid] conferences)
+			log "runComponent ENDED" =<< runComponent (Server componentJid host (PortNumber port)) secret
+				(component db redis (void . UIO.fromIO . StatsD.push statsd) backendHost did adhocBotIQReceiver (writeTChan adhocBotMessages) toRoomPresences toRejoinManager toJoinPartDebouncer sendToComponent toStanzaProcessor processDirectMessageRouteConfig jingleHandler componentJid [registrationJid] conferences)
 		_ -> log "ERROR" "Bad arguments"

@@ 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