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,