From ae0b80c93f14746f0f3b0746b5a70b9b0feb9b51 Mon Sep 17 00:00:00 2001 From: Stephen Paul Weber Date: Mon, 19 Jul 2021 20:19:28 -0500 Subject: [PATCH] Custom tag per source and nick char filter for target --- Config.hs | 4 ++-- ConfigFile.hs | 9 +++++---- Session.hs | 23 +++++++++++++++++++---- config.dhall.example | 8 ++++---- gateway.hs | 27 ++++++++++++++------------- 5 files changed, 44 insertions(+), 27 deletions(-) diff --git a/Config.hs b/Config.hs index f3aa4bb..6fb3fb8 100644 --- a/Config.hs +++ b/Config.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 diff --git a/ConfigFile.hs b/ConfigFile.hs index 6cd0123..3e5bd2e 100644 --- a/ConfigFile.hs +++ b/ConfigFile.hs @@ -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 diff --git a/Session.hs b/Session.hs index 81e20b8..e59dd89 100644 --- a/Session.hs +++ b/Session.hs @@ -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 diff --git a/config.dhall.example b/config.dhall.example index 5207a69..6e2cbad 100644 --- a/config.dhall.example +++ b/config.dhall.example @@ -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 diff --git a/gateway.hs b/gateway.hs index 0049a65..7e40e11 100644 --- a/gateway.hs +++ b/gateway.hs @@ -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, -- 2.38.5