From caf03566293d1a36acc340ea4029ccc78c756581 Mon Sep 17 00:00:00 2001
From: Stephen Paul Weber <singpolyma@singpolyma.net>
Date: Thu, 16 Sep 2021 19:23:42 -0500
Subject: [PATCH] Use non-extra-payload algorthm for rooms that don't support
 it

Such as biboumi rooms
---
 ConfigFile.hs        |  3 ++-
 Session.hs           | 55 +++++++++++++++++++++++++++++---------------
 config.dhall.example |  4 ++--
 gateway.hs           |  4 ++--
 4 files changed, 42 insertions(+), 24 deletions(-)

diff --git a/ConfigFile.hs b/ConfigFile.hs
index dd02d1d..a4991d3 100644
--- a/ConfigFile.hs
+++ b/ConfigFile.hs
@@ -20,7 +20,8 @@ data MUC = MUC {
 	jid :: XMPP.JID,
 	tag :: Maybe Text,
 	nickChars :: Maybe String,
-	nickLength :: Maybe Dhall.Natural
+	nickLength :: Maybe Dhall.Natural,
+	extraPresencePayloads :: Bool
 } deriving (Dhall.Generic, Dhall.FromDhall, Show)
 
 data Config = Config {
diff --git a/Session.hs b/Session.hs
index 1b8bced..d4d21cb 100644
--- a/Session.hs
+++ b/Session.hs
@@ -54,6 +54,16 @@ mkSession config typ source target
 	targetMuc = bareTxt target
 	targetNick = fromMaybe mempty (XMPP.strResource <$> XMPP.jidResource target)
 
+
+isGhost :: (MonadIO m) => Config.Config -> XMPP.JID -> m Bool
+isGhost config from = do
+	ghost <- liftIO $ DB.query (Config.db config)
+		(s"SELECT COUNT(1) FROM sessions WHERE target_muc = ? AND target_nick = ? LIMIT 1")
+		(bareTxt from, nick)
+	return (ghost /= [DB.Only (0::Int)])
+	where
+	nick = fromMaybe mempty $ XMPP.strResource <$> XMPP.jidResource from
+
 maybeAddNick :: XMPP.JID -> Text -> XMPP.JID
 maybeAddNick jid@XMPP.JID { XMPP.jidResource = Just _ } _ = jid
 maybeAddNick muc nick = jid
@@ -63,36 +73,43 @@ maybeAddNick muc nick = jid
 sendPresence :: Config.Config -> XMPP.Presence -> XMPP.JID -> XMPP.XMPP ()
 sendPresence config presence targetMuc =
 	sendPresenceToMUC config presence
-		(Config.MUC targetMuc Nothing Nothing Nothing) Nothing
+		(Config.MUC targetMuc Nothing Nothing Nothing False)
+		(Config.MUC (error "unknown sourceMuc") Nothing Nothing Nothing True)
 
-sendPresenceToMUC :: Config.Config -> XMPP.Presence -> Config.MUC -> Maybe Text -> XMPP.XMPP ()
+sendPresenceToMUC :: Config.Config -> XMPP.Presence -> Config.MUC -> Config.MUC -> XMPP.XMPP ()
 sendPresenceToMUC config presence@XMPP.Presence {
 	XMPP.presenceFrom = Just from@XMPP.JID {
 		XMPP.jidResource = Just fromResource
 	},
 	XMPP.presenceType = typ,
 	XMPP.presencePayloads = payloads
-} targetMuc tag = do
-	when (typ == XMPP.PresenceAvailable) $
-		mkSession config typ (Just from) target
-
-	XMPP.putStanza $ presence {
-			XMPP.presenceType = typ,
-			XMPP.presenceFrom = Just (proxyJid config from),
-			XMPP.presenceTo = Just target,
-			XMPP.presencePayloads = (
-				XML.Element (s"{https://ns.soprani.ca/cheogram-muc-bridge/ghost}ghost") [] []
-			) : map (\payload ->
-				case XML.isNamed (s"{http://jabber.org/protocol/muc#user}x") payload of
-					[_] -> mucJoinX
-					_ -> payload
-			) payloads
-		}
+} targetMuc sourceMuc = do
+	ghost <- if (Config.extraPresencePayloads sourceMuc) then
+		return False
+	else
+		isGhost config from
+
+	when (not ghost) $ do
+		when (typ == XMPP.PresenceAvailable) $
+			mkSession config typ (Just from) target
+
+		XMPP.putStanza $ presence {
+				XMPP.presenceType = typ,
+				XMPP.presenceFrom = Just (proxyJid config from),
+				XMPP.presenceTo = Just target,
+				XMPP.presencePayloads = (
+					XML.Element (s"{https://ns.soprani.ca/cheogram-muc-bridge/ghost}ghost") [] []
+				) : map (\payload ->
+					case XML.isNamed (s"{http://jabber.org/protocol/muc#user}x") payload of
+						[_] -> mucJoinX
+						_ -> payload
+				) payloads
+			}
 	where
 	nickReplacement = maybe id replaceNotInClass (Config.nickChars targetMuc)
 	target = maybeAddNick (Config.jid targetMuc) $ nickReplacement $
 		maybeTruncate nickLength fromNick ++ subscript
-	subscript = maybe mempty (\t -> s"[" ++ t ++ s"]") tag
+	subscript = maybe mempty (\t -> s"[" ++ t ++ s"]") (Config.tag sourceMuc)
 	nickLength = fmap (subtract (T.length subscript) . fromIntegral) $
 		Config.nickLength targetMuc
 	fromNick = XMPP.strResource fromResource
diff --git a/config.dhall.example b/config.dhall.example
index d5bd00d..03d8990 100644
--- a/config.dhall.example
+++ b/config.dhall.example
@@ -9,8 +9,8 @@
 	db = "db.sqlite3",
 	mucs = [
 		[
-			{ jid = "first@muc", tag = "first", nickChars = Some "a-zA-Z0-9`|^_{}[]\\-", nickLength = Some 15 },
-			{ jid = "second@muc", tag = "second", nickChars = None Text, nickLength = None Natural }
+			{ jid = "first@muc", tag = "first", nickChars = Some "a-zA-Z0-9`|^_{}[]\\-", nickLength = Some 15, extraPresencePayloads = False },
+			{ jid = "second@muc", tag = "second", nickChars = None Text, nickLength = None Natural, extraPresencePayloads = True }
 		]
 	]
 }
diff --git a/gateway.hs b/gateway.hs
index dfc5a97..09b86b4 100644
--- a/gateway.hs
+++ b/gateway.hs
@@ -26,11 +26,11 @@ hasMucCode code XMPP.Presence { XMPP.presencePayloads = p } =
 	=<< XML.elementChildren
 	=<< XML.isNamed (s"{http://jabber.org/protocol/muc#user}x") =<< p
 
-fullTargets :: Config.Config -> XMPP.JID -> [(Config.MUC, Maybe Text)]
+fullTargets :: Config.Config -> XMPP.JID -> [(Config.MUC, Config.MUC)]
 fullTargets config from = concatMap (\bridge ->
 		case find ((bareTxt from ==) . bareTxt . Config.jid) bridge of
 			Just sourceMuc ->
-				map (\muc -> (muc, Config.tag sourceMuc)) $
+				map (\muc -> (muc, sourceMuc)) $
 				filter ((bareTxt from /=) . bareTxt . Config.jid) bridge
 			Nothing -> []
 	) (Config.mucs config)
-- 
2.38.5