cheogram-muc-bridge/gateway.hs

module Main (main) where

import Prelude ()
import BasicPrelude
import System.IO
	(stdout, stderr, hSetBuffering, BufferMode(LineBuffering))
import Control.Error                   (exceptT, justZ)
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

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 muc
	XMPP.putStanza $ (mucJoin muc (Config.nick config)) {
			XMPP.presenceFrom = Just $ Config.bridgeJid config
		}

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
			forM_ (Config.mucs config) $ \bridge -> do
				joinFromBridge config (Config.muc1 bridge)
				joinFromBridge config (Config.muc2 bridge)
			return $ defaultRoutes {
				presenceRoute = handlePresence config,
				presenceErrorRoute = handlePresenceError config,
				messageGroupChatRoute = handleGroupChat config,
				messageRoute = handleMessage config,
				iqRoute = handleIq config
			}