~singpolyma/cheogram-muc-bridge

caf03566293d1a36acc340ea4029ccc78c756581 — Stephen Paul Weber 2 days ago a7dfe72 master
Use non-extra-payload algorthm for rooms that don't support it

Such as biboumi rooms
4 files changed, 42 insertions(+), 24 deletions(-)

M ConfigFile.hs
M Session.hs
M config.dhall.example
M gateway.hs
M ConfigFile.hs => ConfigFile.hs +2 -1
@@ 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 {

M Session.hs => Session.hs +36 -19
@@ 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

M config.dhall.example => config.dhall.example +2 -2
@@ 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 }
		]
	]
}

M gateway.hs => gateway.hs +2 -2
@@ 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)