4 files changed, 42 insertions(+), 24 deletions(-)

M ConfigFile.hs
M Session.hs
M config.dhall.example
M gateway.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 {

@@ 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

@@ 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 }
 		]
 	]
 }

@@ 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)