~singpolyma/cheogram

ba52cd7bc4db7c4764e80694c9d3e2a8ecdfc469 — Stephen Paul Weber 19 days ago c16e49a master
Spawn thread per inbound stanza

Especially now that some stanzas can trigger real inline work (for cacheHTTP),
either all such works needs to be made async, or we can just make stanza
handling async itself.  There's no reason not to do this, and I intended to do
it several times before, and it just never made it in before now.

As a benefit here, we log all exceptions produced by the sub-thread and do not
re-throw them, since nothing that happens handling a single stanza should crash
the whole process.  This increases our exception resiliance quite a bit.
2 files changed, 7 insertions(+), 5 deletions(-)

M Main.hs
M Util.hs
M Main.hs => Main.hs +1 -1
@@ 1170,7 1170,7 @@ component db redis pushStatsd backendHost did cacheOOB adhocBotIQReceiver adhocB
					Redis.hset (encodeUtf8 $ bareTxt from) (encodeUtf8 $ maybe mempty strResource $ jidResource from) val
					Redis.hset (encodeUtf8 $ cheogramBareJid) (encodeUtf8 $ maybe mempty strResource $ jidResource from) val
			_ -> return ()
		case (stanzaFrom $ receivedStanza stanza, stanzaTo $ receivedStanza stanza, mapToBackend backendHost =<< stanzaTo (receivedStanza stanza), fmap strNode . jidNode =<< stanzaTo (receivedStanza stanza), stanza) of
		flip forkFinallyXMPP (either (log "RECEIVE ONE" . show) return) $ case (stanzaFrom $ receivedStanza stanza, stanzaTo $ receivedStanza stanza, mapToBackend backendHost =<< stanzaTo (receivedStanza stanza), fmap strNode . jidNode =<< stanzaTo (receivedStanza stanza), stanza) of
			(_, Just to, _, _, ReceivedIQ iq@(IQ { iqType = IQResult }))
			  | (strResource <$> jidResource to) == Just (s"adhocbot") ->
				adhocBotIQReceiver iq

M Util.hs => Util.hs +6 -4
@@ 232,15 232,17 @@ castException = Ex.fromException . Ex.toException
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 ()))
	forkFinallyXMPP kid (either (handler parent) (const $ return ()))
	where
	handler parent e
		| Just Ex.ThreadKilled <- castException e = return ()
		| otherwise = throwTo parent 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

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