southerntofu
/
cheogram-muc-bridge
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Replace mentioned nicks with their ghost equivalent

This commit is contained in:
Stephen Paul Weber 2021-06-28 20:39:41 -05:00
parent f78d9b9873
commit 2460ca844a
No known key found for this signature in database
GPG Key ID: D11C2911CE519CDE
2 changed files with 53 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
Session.hs
View File

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

7
gateway.hs
View File

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