~singpolyma/cheogram-muc-bridge

ae0b80c93f14746f0f3b0746b5a70b9b0feb9b51 — Stephen Paul Weber 14 days ago 3d6657e
Custom tag per source and nick char filter for target
5 files changed, 44 insertions(+), 27 deletions(-)

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

M ConfigFile.hs => ConfigFile.hs +5 -4
@@ 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

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

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

M gateway.hs => gateway.hs +14 -13
@@ 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,