~singpolyma/cheogram: Spawn thread per inbound stanza

ba52cd7bc4db7c4764e80694c9d3e2a8ecdfc469 — Stephen Paul Weber 2 years ago c16e49a

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.

patch browse .tar.gz

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]