~singpolyma/cheogram

0070953e161649c14505de2d0bf228f62e5db66d — Stephen Paul Weber 1 year, 4 months ago a2871b7 + dd4d295
Merge branch 'better-thread-exceptions'

* better-thread-exceptions:
  Terminate on fatal exception
  Import forkXMPP from jingle-xmpp
2 files changed, 22 insertions(+), 10 deletions(-)

M Main.hs
M Util.hs
M Main.hs => Main.hs +3 -10
@@ 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"

M Util.hs => Util.hs +19 -0
@@ 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