202 lines
7.2 KiB
Haskell
202 lines
7.2 KiB
Haskell
module Main (main) where
|
|
|
|
import Prelude ()
|
|
import BasicPrelude
|
|
import System.IO
|
|
(stdout, stderr, hSetBuffering, BufferMode(LineBuffering))
|
|
import Control.Error (exceptT, justZ)
|
|
import Control.Concurrent (threadDelay)
|
|
import Control.Concurrent.STM (STM)
|
|
import qualified Database.SQLite.Simple as DB
|
|
import qualified Data.Text as T
|
|
import qualified Data.XML.Types as XML
|
|
import qualified Network.Protocol.XMPP as XMPP
|
|
|
|
import qualified Config
|
|
import qualified Session
|
|
import Router
|
|
import Util
|
|
import IQManager
|
|
|
|
hasMucCode :: Int -> XMPP.Presence -> Bool
|
|
hasMucCode code XMPP.Presence { XMPP.presencePayloads = p } =
|
|
elem (tshow code) $
|
|
maybeToList . XML.attributeText (s"code")
|
|
=<< XML.isNamed (s"{http://jabber.org/protocol/muc#user}status")
|
|
=<< 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
|
|
) (Config.mucs config)
|
|
|
|
handlePresence :: Config.Config -> XMPP.Presence -> XMPP.XMPP ()
|
|
handlePresence config presence@XMPP.Presence {
|
|
XMPP.presenceFrom = Just from,
|
|
XMPP.presenceTo = Just to
|
|
}
|
|
| bareTxt to /= bareTxt (Config.bridgeJid config) =
|
|
-- This is to one of our ghosts, so just ignore it
|
|
return ()
|
|
| hasMucCode 110 presence = -- done joining room, clean up old data
|
|
Session.cleanOld config from
|
|
| Just resource <- XMPP.jidResource from,
|
|
not (s"[x]" `T.isInfixOf` XMPP.strResource resource) = forM_ (targets config from) $
|
|
Session.sendPresence config presence
|
|
handlePresence _ _ = return ()
|
|
|
|
handlePresenceError :: Config.Config -> XMPP.Presence -> XMPP.XMPP ()
|
|
handlePresenceError config XMPP.Presence {
|
|
XMPP.presenceFrom = Just from@XMPP.JID {
|
|
XMPP.jidResource = Just resource
|
|
},
|
|
XMPP.presenceTo = Just XMPP.JID { XMPP.jidNode = Just node },
|
|
XMPP.presencePayloads = p
|
|
} |
|
|
Just originalSource <- XMPP.parseJID $ unescapeJid $ XMPP.strNode node,
|
|
[err] <- XML.isNamed (s"{jabber:component:accept}error") =<< p,
|
|
[_] <- XML.isNamed (s"{urn:ietf:params:xml:ns:xmpp-stanzas}conflict") =<<
|
|
XML.elementChildren err =
|
|
let
|
|
toSend = (mucJoin muc (nick ++ s"_")) {
|
|
XMPP.presenceFrom = Just originalSource
|
|
}
|
|
Just target = XMPP.presenceTo toSend
|
|
in Session.sendPresence config toSend target
|
|
where
|
|
nick = XMPP.strResource resource
|
|
Just muc = XMPP.parseJID $ bareTxt from
|
|
handlePresenceError _ _ = return ()
|
|
|
|
handleGroupChat :: Config.Config -> XMPP.Message -> XMPP.XMPP ()
|
|
handleGroupChat config message@XMPP.Message {
|
|
XMPP.messageFrom = Just from,
|
|
XMPP.messageTo = Just to
|
|
}
|
|
| bareTxt to /= bareTxt (Config.bridgeJid config) =
|
|
-- This is to one of our ghosts, so just ignore it
|
|
return ()
|
|
| otherwise = forM_ (targets config from) $
|
|
Session.sendGroupChat config message
|
|
handleGroupChat _ _ = return ()
|
|
|
|
handleMessage :: Config.Config -> XMPP.Message -> XMPP.XMPP ()
|
|
handleMessage config message@XMPP.Message {
|
|
XMPP.messageFrom = Just from@XMPP.JID { XMPP.jidNode = Just fromNode },
|
|
XMPP.messageTo = Just XMPP.JID { XMPP.jidNode = Just node }
|
|
}
|
|
| not $ null $ targets config from =
|
|
XMPP.putStanza $ message {
|
|
XMPP.messageFrom = Just (proxyJid config from),
|
|
XMPP.messageTo = target
|
|
}
|
|
| Just fakeFrom <- maybeFakeFrom =
|
|
XMPP.putStanza $ message {
|
|
XMPP.messageFrom = Just (proxyJid config fakeFrom),
|
|
XMPP.messageTo = target
|
|
}
|
|
where
|
|
target = XMPP.parseJID $ unescapeJid $ XMPP.strNode node
|
|
-- This is basically just for biboumi
|
|
-- If we get a direct message from a non-MUC source
|
|
-- check if there are any MUCs bridged to the given target
|
|
-- with a domain matching the domain of the from
|
|
-- and if so use the localpart (minus any %suffix) as a nick from that source
|
|
maybeFakeFrom = (XMPP.parseJID =<<) $
|
|
fmap ((++ s"/" ++ T.takeWhile (/='%') (XMPP.strNode fromNode)) . bareTxt) $
|
|
find (\source -> XMPP.jidDomain source == XMPP.jidDomain from) $
|
|
targets config =<< justZ target
|
|
handleMessage _ _ = return ()
|
|
|
|
handleIq :: Config.Config -> XMPP.IQ -> XMPP.XMPP ()
|
|
handleIq config iq@XMPP.IQ {
|
|
XMPP.iqFrom = Just from@XMPP.JID { XMPP.jidNode = Just _ },
|
|
XMPP.iqTo = Just XMPP.JID { XMPP.jidNode = Just node }
|
|
}
|
|
| not $ null $ targets config from =
|
|
XMPP.putStanza $ iq {
|
|
XMPP.iqFrom = Just (proxyJid config from),
|
|
XMPP.iqTo = target
|
|
}
|
|
where
|
|
target = XMPP.parseJID $ unescapeJid $ XMPP.strNode node
|
|
handleIq _ _ = return ()
|
|
|
|
joinFromBridge :: Config.Config -> XMPP.JID -> XMPP.XMPP ()
|
|
joinFromBridge config muc = do
|
|
Session.mkSession config XMPP.PresenceAvailable Nothing target
|
|
XMPP.putStanza presence
|
|
where
|
|
Just target = XMPP.presenceTo presence
|
|
presence = (mucJoin muc (Config.nick config)) {
|
|
XMPP.presenceFrom = Just $ Config.bridgeJid config
|
|
}
|
|
|
|
pingSuccessError :: XML.Element -> [XML.Element]
|
|
pingSuccessError = uncurry (<|>) . (uncurry (<|>) . (
|
|
XML.isNamed (s"{urn:ietf:params:xml:ns:xmpp-stanzas}service-unavaliable")
|
|
&&&
|
|
XML.isNamed (s"{urn:ietf:params:xml:ns:xmpp-stanzas}feature-not-implemented")
|
|
) &&&
|
|
XML.isNamed (s"{urn:ietf:params:xml:ns:xmpp-stanzas}item-not-found")
|
|
)
|
|
|
|
selfPings :: Config.Config -> (XMPP.IQ -> XMPP.XMPP (STM (Maybe XMPP.IQ))) -> XMPP.XMPP ()
|
|
selfPings config sendIQ = forever $ do
|
|
liftIO $ threadDelay 60000000
|
|
sessions <- liftIO $ DB.query_ (Config.db config) (s"SELECT source_muc, source_nick, target_muc, target_nick FROM sessions")
|
|
forM_ sessions $ \(sourceMuc, sourceNick, targetMuc, targetNick) -> void $ forkXMPP $ do
|
|
let Just target = XMPP.parseJID (targetMuc ++ s"/" ++ targetNick)
|
|
reply <- (atomicUIO =<<) $ sendIQ $ (XMPP.emptyIQ XMPP.IQGet) {
|
|
XMPP.iqFrom = sourceJid sourceMuc sourceNick,
|
|
XMPP.iqTo = Just target,
|
|
XMPP.iqPayload = Just $ XML.Element (s"{urn:xmpp:ping}ping") [] []
|
|
}
|
|
if (XMPP.iqType <$> reply) == Just XMPP.IQResult then return () else
|
|
case pingSuccessError =<< XML.elementChildren =<< justZ (XMPP.iqPayload =<< reply) of
|
|
(_:_) -> return ()
|
|
_ | sourceMuc == mempty -> joinFromBridge config target
|
|
_ ->
|
|
Session.sendPresence config ((mucJoin target targetNick) {
|
|
XMPP.presenceFrom = XMPP.parseJID (sourceMuc ++ s"/" ++ sourceNick)
|
|
}) target
|
|
where
|
|
sourceJid muc nick
|
|
| muc == mempty = Just $ Config.bridgeJid config
|
|
| otherwise = proxyJid config <$> XMPP.parseJID (muc ++ s"/" ++ nick)
|
|
|
|
main :: IO ()
|
|
main = do
|
|
hSetBuffering stdout LineBuffering
|
|
hSetBuffering stderr LineBuffering
|
|
|
|
config <- Config.setup =<< fmap head getArgs
|
|
|
|
let server = XMPP.Server
|
|
(Config.componentJid config)
|
|
(Config.host $ Config.server config)
|
|
(Config.port $ Config.server config)
|
|
|
|
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)
|
|
void $ forkXMPP $ selfPings config sendIQ
|
|
return $ defaultRoutes {
|
|
presenceRoute = handlePresence config,
|
|
presenceErrorRoute = handlePresenceError config,
|
|
messageGroupChatRoute = handleGroupChat config,
|
|
messageRoute = handleMessage config,
|
|
iqRoute = \iq -> do
|
|
maybeIq <- iqReceiver iq
|
|
forM_ maybeIq $ handleIq config
|
|
}
|