~singpolyma/cheogram-muc-bridge

2460ca844a747f202ae179a90c2daace5d331657 — Stephen Paul Weber 1 year, 5 months ago f78d9b9
Replace mentioned nicks with their ghost equivalent
2 files changed, 53 insertions(+), 5 deletions(-)

M Session.hs
M gateway.hs
M Session.hs => Session.hs +51 -0
@@ 2,6 2,10 @@ module Session where

import Prelude ()
import BasicPrelude
import Control.Applicative (many)
import qualified Data.Attoparsec.Text  as Atto hiding (Parser)
import qualified Data.Attoparsec.Internal.Types as Atto
import qualified Data.Text             as T
import qualified Database.SQLite.Simple as DB
import qualified Data.XML.Types        as XML
import qualified Network.Protocol.XMPP as XMPP


@@ 59,3 63,50 @@ sendPresence config presence@XMPP.Presence {
	target = maybeAddNick targetMuc (fromNick ++ s"[x]")
	fromNick = XMPP.strResource fromResource
sendPresence _ _ _ = return ()

startOfInput :: Atto.Parser t ()
startOfInput = Atto.Parser $ \t pos more lose suc ->
	if pos == 0 then
		suc t pos more ()
	else
		lose t pos more [] "startOfInput"

replaceWords :: [(Text, Text)] -> Text -> Text
replaceWords replacements txt = mconcat result
	where
	wordClass = "A-Za-z0-9_"
	boundary =
		(startOfInput *> pure mempty) <|>
		(Atto.endOfInput *> pure mempty) <|>
		(T.singleton <$> Atto.satisfy (Atto.notInClass wordClass))
	replacement word newWord = mconcat <$> (
		(:) <$> boundary <*> (
			(:) <$> (Atto.string word *> pure newWord) <*>
			((:) <$> boundary <*> pure [])
		))
	Right result = Atto.parseOnly (many (
			foldr (<|>) (T.singleton <$> Atto.anyChar) (uncurry replacement <$> replacements)
		) <* Atto.endOfInput) txt

sendGroupChat :: Config.Config -> XMPP.Message -> XMPP.JID -> XMPP.XMPP ()
sendGroupChat config message@XMPP.Message {
	XMPP.messageFrom = Just from,
	XMPP.messagePayloads = payloads
} target = do
		nickSwaps1 <- liftIO $ DB.query (Config.db config) (s"SELECT target_nick, source_nick FROM sessions WHERE source_muc=?") (DB.Only $ bareTxt target)
		nickSwaps2 <- liftIO $ DB.query (Config.db config) (s"SELECT source_nick, target_nick FROM sessions WHERE target_muc=? AND source_muc IS NOT NULL") (DB.Only $ bareTxt target)
		XMPP.putStanza $ message {
			XMPP.messageFrom = Just (proxyJid config from),
			XMPP.messageTo = Just target,
			XMPP.messagePayloads = map (\el ->
				case XML.isNamed (s"{jabber:component:accept}body") el of
					[body] ->
						body { XML.elementNodes = [
							XML.NodeContent $ XML.ContentText $
								replaceWords (nickSwaps1 ++ nickSwaps2)
								(mconcat (XML.elementText body))
						]}
					_ -> el
			) payloads
		}
sendGroupChat _ _ _ = return ()

M gateway.hs => gateway.hs +2 -5
@@ 77,11 77,8 @@ handleGroupChat config message@XMPP.Message {
	| bareTxt to /= bareTxt (Config.bridgeJid config) =
		-- This is to one of our ghosts, so just ignore it
		return ()
	| otherwise = forM_ (targets config from) $ \target ->
		XMPP.putStanza $ message {
			XMPP.messageFrom = Just (proxyJid config from),
			XMPP.messageTo = Just target
		}
	| otherwise = forM_ (targets config from) $
		Session.sendGroupChat config message
handleGroupChat _ _ = return ()

handleMessage :: Config.Config -> XMPP.Message -> XMPP.XMPP ()