5 files changed, 44 insertions(+), 27 deletions(-)

M Config.hs
M ConfigFile.hs
M Session.hs
M config.dhall.example
M gateway.hs

@@ 1,4 1,4 @@
-module Config (setup, Config(..), ConfigFile.ServerConfig(..), ConfigFile.Bridge(..)) where
+module Config (setup, Config(..), ConfigFile.ServerConfig(..), ConfigFile.MUC(..)) where
 
 import Prelude ()
 import BasicPrelude


@@ 18,7 18,7 @@ data Config = Config {
 	bridgeJid :: XMPP.JID,
 	db :: DB.Connection,
 	dbVersion :: Integer,
-	mucs :: [ConfigFile.Bridge]
+	mucs :: [[ConfigFile.MUC]]
 }
 
 -- Not importing Util because Util imports us

@@ 16,9 16,10 @@ data ServerConfig = ServerConfig {
 	port :: Network.PortID
 } deriving (Dhall.Generic, Dhall.FromDhall, Show)
 
-data Bridge = Bridge {
-	muc1 :: XMPP.JID,
-	muc2 :: XMPP.JID
+data MUC = MUC {
+	jid :: XMPP.JID,
+	tag :: Text,
+	nickChars :: Maybe String
 } deriving (Dhall.Generic, Dhall.FromDhall, Show)
 
 data Config = Config {


@@ 27,7 28,7 @@ data Config = Config {
 	secret :: Text,
 	nick :: Text,
 	db :: Text,
-	mucs :: [Bridge]
+	mucs :: [[MUC]]
 } deriving (Dhall.Generic, Dhall.FromDhall, Show)
 
 instance Dhall.FromDhall XMPP.JID where

@@ 55,13 55,18 @@ maybeAddNick muc nick = jid
 	Just jid = XMPP.parseJID $ bareTxt muc ++ s"/" ++ nick
 
 sendPresence :: Config.Config -> XMPP.Presence -> XMPP.JID -> XMPP.XMPP ()
-sendPresence config presence@XMPP.Presence {
+sendPresence config presence targetMuc =
+	sendPresenceToMUC config presence
+		(Config.MUC targetMuc (s"XMPP") Nothing) (s"XMPP")
+
+sendPresenceToMUC :: Config.Config -> XMPP.Presence -> Config.MUC -> Text -> XMPP.XMPP ()
+sendPresenceToMUC config presence@XMPP.Presence {
 	XMPP.presenceFrom = Just from@XMPP.JID {
 		XMPP.jidResource = Just fromResource
 	},
 	XMPP.presenceType = typ,
 	XMPP.presencePayloads = payloads
-} targetMuc = do
+} targetMuc tag = do
 	ghost <- liftIO $ DB.query (Config.db config)
 		(s"SELECT COUNT(1) FROM sessions WHERE target_muc = ? AND target_nick = ? LIMIT 1")
 		(bareTxt from, fromNick)


@@ 78,9 83,11 @@ sendPresence config presence@XMPP.Presence {
 				) payloads
 			}
 	where
-	target = maybeAddNick targetMuc (fromNick ++ s"[x]")
+	nickReplacement = maybe id replaceNotInClass (Config.nickChars targetMuc)
+	target = maybeAddNick (Config.jid targetMuc) $
+		nickReplacement $ fromNick ++ s"[" ++ tag ++ s"]"
 	fromNick = XMPP.strResource fromResource
-sendPresence _ _ _ = return ()
+sendPresenceToMUC _ _ _ _ = return ()
 
 startOfInput :: Atto.Parser t ()
 startOfInput = Atto.Parser $ \t pos more lose suc ->


@@ 89,6 96,14 @@ startOfInput = Atto.Parser $ \t pos more lose suc ->
 	else
 		lose t pos more [] "startOfInput"
 
+replaceNotInClass :: String -> Text -> Text
+replaceNotInClass klass txt = mconcat result
+	where
+	Right result = Atto.parseOnly (many (
+			Atto.takeWhile1 (Atto.inClass klass) <|>
+			(Atto.takeWhile1 (Atto.notInClass klass) *> pure (s"_"))
+		) <* Atto.endOfInput) txt
+
 replaceWords :: [(Text, Text)] -> Text -> Text
 replaceWords replacements txt = mconcat result
 	where

@@ 7,9 7,9 @@
 		port = 5347
 	},
 	mucs = [
-		{
-			muc1 = "first@muc",
-			muc2 = "second@muc"
-		}
+		[
+			{ jid = "first@muc", tag = "first", nickChars = Some "a-z" },
+			{ jid = "second@muc", tag = "second", nickChars = None Text }
+		]
 	]
 }=
\ No newline at end of file

@@ 26,16 26,18 @@ hasMucCode code XMPP.Presence { XMPP.presencePayloads = p } =
 	=<< XML.elementChildren
 	=<< XML.isNamed (s"{http://jabber.org/protocol/muc#user}x") =<< p
 
-targets :: Config.Config -> XMPP.JID -> [XMPP.JID]
-targets config from = mapMaybe (\bridge ->
-		if bareTxt (Config.muc1 bridge) == bareTxt from then
-			Just $ Config.muc2 bridge
-		else if bareTxt (Config.muc2 bridge) == bareTxt from then
-			Just $ Config.muc1 bridge
-		else
-			Nothing
+fullTargets :: Config.Config -> XMPP.JID -> [(Config.MUC, Text)]
+fullTargets config from = concatMap (\bridge ->
+		case find ((bareTxt from ==) . bareTxt . Config.jid) bridge of
+			Just sourceMuc ->
+				map (\muc -> (muc, Config.tag sourceMuc)) $
+				filter ((bareTxt from /=) . bareTxt . Config.jid) bridge
+			Nothing -> []
 	) (Config.mucs config)
 
+targets :: Config.Config -> XMPP.JID -> [XMPP.JID]
+targets = map (Config.jid . fst) .: fullTargets
+
 handlePresence :: Config.Config -> XMPP.Presence -> XMPP.XMPP ()
 handlePresence config presence@XMPP.Presence {
 	XMPP.presenceFrom = Just from,


@@ 46,8 48,8 @@ handlePresence config presence@XMPP.Presence {
 		return ()
 	| hasMucCode 110 presence = -- done joining room, clean up old data
 		Session.cleanOld config from
-	| otherwise = forM_ (targets config from) $
-			Session.sendPresence config presence
+	| otherwise = forM_ (fullTargets config from) $
+			uncurry $ Session.sendPresenceToMUC config presence
 handlePresence _ _ = return ()
 
 handlePresenceError :: Config.Config -> XMPP.Presence -> XMPP.XMPP ()


@@ 185,9 187,8 @@ main = do
 	exceptT print return $
 		runRoutedComponent server (Config.secret config) $ do
 			(sendIQ, iqReceiver) <- iqManager XMPP.putStanza
-			forM_ (Config.mucs config) $ \bridge -> do
-				joinFromBridge config (Config.muc1 bridge)
-				joinFromBridge config (Config.muc2 bridge)
+			forM_ (Config.mucs config) $ mapM_ $ \muc ->
+				joinFromBridge config (Config.jid muc)
 			void $ forkXMPP $ selfPings config sendIQ
 			return $ defaultRoutes {
 				presenceRoute = handlePresence config,